lxsd / fvn

Download as
Browse Code ยป

Commit 8d883e8a1a3882fb07ea162471fdc9f2c133bf81

Authored by wdaniau
1 parent f6bacaf83a
Exists in master and in 3 other branches geevx, geevx_2020, multi

Integration of kind_definition to fvn_common 

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

Showing 35 changed files with 29 additions and 48 deletions Inline Diff

fvn_common/fvn_common.f90
Diff comments   View file @ 8d883e8
module fvn_common 1 1 module fvn_common
! This module contains routines that are used by more than one fvn submodule 2 2 ! This module contains routines that are used by more than one fvn submodule
3 3
use Kind_Definition 4
implicit none 5 4 implicit none
5 ! Kind Definition Module integrated into fvn_common
6 integer, parameter :: ip_kind = kind(1)
7 integer, parameter :: sp_kind = kind(1.0E0)
8 integer, parameter :: dp_kind = kind(1.0D0)
9
! We define pi and i for the module 6 10 ! We define pi and i for the module
real(kind=dp_kind),parameter :: fvn_pi = 3.141592653589793_dp_kind 7 11 real(kind=dp_kind),parameter :: fvn_pi = 3.141592653589793_dp_kind
12 real(kind=dp_kind),parameter :: fvn_el = 0.5772156649015328_dp_kind
complex(kind=dp_kind),parameter :: fvn_i = (0._dp_kind,1._dp_kind) 8 13 complex(kind=dp_kind),parameter :: fvn_i = (0._dp_kind,1._dp_kind)
9 14
! an integer variable that can be used to store the return status of different fvn subroutines 10 15 ! an integer variable that can be used to store the return status of different fvn subroutines
integer :: fvn_status 11 16 integer :: fvn_status
12 17
interface 13 18 interface
function d1mach(i) 14 19 function d1mach(i)
integer :: i 15 20 integer :: i
double precision :: d1mach 16 21 double precision :: d1mach
end function 17 22 end function
function r1mach(i) 18 23 function r1mach(i)
integer :: i 19 24 integer :: i
real :: r1mach 20 25 real :: r1mach
function besin(n,x,factor,big) 1 1 function besin(n,x,factor,big)
use Kind_Definition 2 2 use fvn_common
implicit none 3 3 implicit none
! This function compute the rank n Bessel J function 4 4 ! This function compute the rank n Bessel J function
! using recurrence relation : 5 5 ! using recurrence relation :
! In+1(x)=-2n/x * In(x) + In-1(x) 6 6 ! In+1(x)=-2n/x * In(x) + In-1(x)
! 7 7 !
! Two optional parameters : 8 8 ! Two optional parameters :
! factor : an integer that is used in Miller's algorithm to determine the 9 9 ! factor : an integer that is used in Miller's algorithm to determine the
! starting point of iteration. Default value is 40, an increase of this value 10 10 ! starting point of iteration. Default value is 40, an increase of this value
! will increase accuracy. Starting point ~ nearest even integer of sqrt(factor*n) 11 11 ! will increase accuracy. Starting point ~ nearest even integer of sqrt(factor*n)
! big : a real that determine the threshold for taking anti overflow counter measure 12 12 ! big : a real that determine the threshold for taking anti overflow counter measure
! default value is 1e10 13 13 ! default value is 1e10
! 14 14 !
real(sp_kind) :: besin 15 15 real(sp_kind) :: besin
integer :: n 16 16 integer :: n
real(sp_kind) :: x 17 17 real(sp_kind) :: x
integer, optional :: factor 18 18 integer, optional :: factor
real(sp_kind), optional :: big 19 19 real(sp_kind), optional :: big
20 20
integer :: tfactor 21 21 integer :: tfactor
real(sp_kind) :: tbig,tsmall 22 22 real(sp_kind) :: tbig,tsmall
real(sp_kind) :: two_on_x,binm1,bin,binp1,absx 23 23 real(sp_kind) :: two_on_x,binm1,bin,binp1,absx
integer :: i,start 24 24 integer :: i,start
real(sp_kind), external :: besi0,besi1 25 25 real(sp_kind), external :: besi0,besi1
26 26
! Initialization of optional parameters 27 27 ! Initialization of optional parameters
tfactor=40 28 28 tfactor=40
if(present(factor)) tfactor=factor 29 29 if(present(factor)) tfactor=factor
tbig=1e10 30 30 tbig=1e10
if(present(big)) tbig=big 31 31 if(present(big)) tbig=big
tsmall=1./tbig 32 32 tsmall=1./tbig
33 33
if (n==0) then 34 34 if (n==0) then
besin=besi0(x) 35 35 besin=besi0(x)
return 36 36 return
end if 37 37 end if
if (n==1) then 38 38 if (n==1) then
besin=besi1(x) 39 39 besin=besi1(x)
return 40 40 return
end if 41 41 end if
if (n < 0) then 42 42 if (n < 0) then
write(*,*) "Error in besin, n must be >= 0" 43 43 write(*,*) "Error in besin, n must be >= 0"
stop 44 44 stop
end if 45 45 end if
46 46
absx=abs(x) 47 47 absx=abs(x)
if (absx == 0.) then 48 48 if (absx == 0.) then
besin=0. 49 49 besin=0.
else 50 50 else
! We use Miller's Algorithm 51 51 ! We use Miller's Algorithm
! as upward reccurence is unstable. 52 52 ! as upward reccurence is unstable.
! This is adapted from Numerical Recipes 53 53 ! This is adapted from Numerical Recipes
! Principle : use of downward recurrence from an arbitrary 54 54 ! Principle : use of downward recurrence from an arbitrary
! higher than n value with an arbitrary seed, 55 55 ! higher than n value with an arbitrary seed,
! and then use the normalization formula : 56 56 ! and then use the normalization formula :
! 1=I0-2I2+2I4-2I6+.... however it is easier to use a 57 57 ! 1=I0-2I2+2I4-2I6+.... however it is easier to use a
! call to besi0 58 58 ! call to besi0
two_on_x=2./absx 59 59 two_on_x=2./absx
start=2*((n+int(sqrt(real(n*tfactor,sp_kind))))/2) ! even start 60 60 start=2*((n+int(sqrt(real(n*tfactor,sp_kind))))/2) ! even start
binp1=0. 61 61 binp1=0.
bin=1. 62 62 bin=1.
do i=start,1,-1 63 63 do i=start,1,-1
! begin downward rec 64 64 ! begin downward rec
binm1=two_on_x*bin*i+binp1 65 65 binm1=two_on_x*bin*i+binp1
binp1=bin 66 66 binp1=bin
bin=binm1 67 67 bin=binm1
! Action to prevent overflow 68 68 ! Action to prevent overflow
if (abs(bin) > tbig) then 69 69 if (abs(bin) > tbig) then
bin=bin*tsmall 70 70 bin=bin*tsmall
binp1=binp1*tsmall 71 71 binp1=binp1*tsmall
besin=besin*tsmall 72 72 besin=besin*tsmall
end if 73 73 end if
if (i==n) besin=binp1 74 74 if (i==n) besin=binp1
end do 75 75 end do
besin=besin*besi0(x)/bin 76 76 besin=besin*besi0(x)/bin
end if 77 77 end if
function besjn(n,x,factor,big) 1 1 function besjn(n,x,factor,big)
use Kind_Definition 2 2 use fvn_common
implicit none 3 3 implicit none
! This function compute the rank n Bessel J function 4 4 ! This function compute the rank n Bessel J function
! using recurrence relation : 5 5 ! using recurrence relation :
! Jn+1(x)=2n/x * Jn(x) - Jn-1(x) 6 6 ! Jn+1(x)=2n/x * Jn(x) - Jn-1(x)
! 7 7 !
! Two optional parameters : 8 8 ! Two optional parameters :
! factor : an integer that is used in Miller's algorithm to determine the 9 9 ! factor : an integer that is used in Miller's algorithm to determine the
! starting point of iteration. Default value is 40, an increase of this value 10 10 ! starting point of iteration. Default value is 40, an increase of this value
! will increase accuracy. Starting point ~ nearest even integer of sqrt(factor*n) 11 11 ! will increase accuracy. Starting point ~ nearest even integer of sqrt(factor*n)
! big : a real that determine the threshold for taking anti overflow counter measure 12 12 ! big : a real that determine the threshold for taking anti overflow counter measure
! default value is 1e10 13 13 ! default value is 1e10
! 14 14 !
real(sp_kind) :: besjn 15 15 real(sp_kind) :: besjn
integer :: n 16 16 integer :: n
real(sp_kind) :: x 17 17 real(sp_kind) :: x
integer, optional :: factor 18 18 integer, optional :: factor
real(sp_kind), optional :: big 19 19 real(sp_kind), optional :: big
20 20
integer :: tfactor 21 21 integer :: tfactor
real(sp_kind) :: tbig,tsmall,som 22 22 real(sp_kind) :: tbig,tsmall,som
real(sp_kind),external :: besj0,besj1 23 23 real(sp_kind),external :: besj0,besj1
real(sp_kind) :: two_on_x,bjnm1,bjn,bjnp1,absx 24 24 real(sp_kind) :: two_on_x,bjnm1,bjn,bjnp1,absx
integer :: i,start 25 25 integer :: i,start
logical :: iseven 26 26 logical :: iseven
27 27
! Initialization of optional parameters 28 28 ! Initialization of optional parameters
tfactor=40 29 29 tfactor=40
if(present(factor)) tfactor=factor 30 30 if(present(factor)) tfactor=factor
tbig=1e10 31 31 tbig=1e10
if(present(big)) tbig=big 32 32 if(present(big)) tbig=big
tsmall=1./tbig 33 33 tsmall=1./tbig
34 34
if (n==0) then 35 35 if (n==0) then
besjn=besj0(x) 36 36 besjn=besj0(x)
return 37 37 return
end if 38 38 end if
if (n==1) then 39 39 if (n==1) then
besjn=besj1(x) 40 40 besjn=besj1(x)
return 41 41 return
end if 42 42 end if
if (n < 0) then 43 43 if (n < 0) then
write(*,*) "Error in besjn, n must be >= 0" 44 44 write(*,*) "Error in besjn, n must be >= 0"
stop 45 45 stop
end if 46 46 end if
47 47
absx=abs(x) 48 48 absx=abs(x)
if (absx == 0.) then 49 49 if (absx == 0.) then
besjn=0. 50 50 besjn=0.
else if (absx > real(n,sp_kind)) then 51 51 else if (absx > real(n,sp_kind)) then
! For x > n upward reccurence is stable 52 52 ! For x > n upward reccurence is stable
two_on_x=2./absx 53 53 two_on_x=2./absx
bjnm1=besj0(absx) 54 54 bjnm1=besj0(absx)
bjn=besj1(absx) 55 55 bjn=besj1(absx)
do i=1,n-1 56 56 do i=1,n-1
bjnp1=two_on_x*bjn*i-bjnm1 57 57 bjnp1=two_on_x*bjn*i-bjnm1
bjnm1=bjn 58 58 bjnm1=bjn
bjn=bjnp1 59 59 bjn=bjnp1
end do 60 60 end do
besjn=bjnp1 61 61 besjn=bjnp1
else 62 62 else
! For x <= n we use Miller's Algorithm 63 63 ! For x <= n we use Miller's Algorithm
! as upward reccurence is unstable. 64 64 ! as upward reccurence is unstable.
! This is adapted from Numerical Recipes 65 65 ! This is adapted from Numerical Recipes
! Principle : use of downward recurrence from an arbitrary 66 66 ! Principle : use of downward recurrence from an arbitrary
! higher than n value with an arbitrary seed, 67 67 ! higher than n value with an arbitrary seed,
! and then use the normalization formula : 68 68 ! and then use the normalization formula :
! 1=J0+2J2+2J4+2J6+.... 69 69 ! 1=J0+2J2+2J4+2J6+....
two_on_x=2./absx 70 70 two_on_x=2./absx
start=2*((n+int(sqrt(real(n*tfactor,sp_kind))))/2) ! even start 71 71 start=2*((n+int(sqrt(real(n*tfactor,sp_kind))))/2) ! even start
som=0. 72 72 som=0.
iseven=.false. 73 73 iseven=.false.
bjnp1=0. 74 74 bjnp1=0.
bjn=1. 75 75 bjn=1.
do i=start,1,-1 76 76 do i=start,1,-1
! begin downward rec 77 77 ! begin downward rec
bjnm1=two_on_x*bjn*i-bjnp1 78 78 bjnm1=two_on_x*bjn*i-bjnp1
bjnp1=bjn 79 79 bjnp1=bjn
bjn=bjnm1 80 80 bjn=bjnm1
! Action to prevent overflow 81 81 ! Action to prevent overflow
if (abs(bjn) > tbig) then 82 82 if (abs(bjn) > tbig) then
bjn=bjn*tsmall 83 83 bjn=bjn*tsmall
bjnp1=bjnp1*tsmall 84 84 bjnp1=bjnp1*tsmall
besjn=besjn*tsmall 85 85 besjn=besjn*tsmall
som=som*tsmall 86 86 som=som*tsmall
end if 87 87 end if
if (iseven) then 88 88 if (iseven) then
som=som+bjn 89 89 som=som+bjn
end if 90 90 end if
iseven= .not. iseven 91 91 iseven= .not. iseven
if (i==n) besjn=bjnp1 92 92 if (i==n) besjn=bjnp1
end do 93 93 end do
som=2.*som-bjn 94 94 som=2.*som-bjn
besjn=besjn/som 95 95 besjn=besjn/som
end if 96 96 end if
function beskn(n,x) 1 1 function beskn(n,x)
use Kind_Definition 2 2 use fvn_common
implicit none 3 3 implicit none
! This function compute the rank n Bessel Y function 4 4 ! This function compute the rank n Bessel Y function
! using recurrence relation : 5 5 ! using recurrence relation :
! Kn+1(x)=2n/x * Kn(x) + Kn-1(x) 6 6 ! Kn+1(x)=2n/x * Kn(x) + Kn-1(x)
! 7 7 !
real(sp_kind) :: beskn 8 8 real(sp_kind) :: beskn
integer :: n 9 9 integer :: n
real(sp_kind) :: x 10 10 real(sp_kind) :: x
11 11
real(sp_kind),external :: besk0,besk1 12 12 real(sp_kind),external :: besk0,besk1
real(sp_kind) :: two_on_x,bknm1,bkn,bktmp 13 13 real(sp_kind) :: two_on_x,bknm1,bkn,bktmp
integer :: i 14 14 integer :: i
15 15
if (n==0) then 16 16 if (n==0) then
beskn=besk0(x) 17 17 beskn=besk0(x)
return 18 18 return
end if 19 19 end if
if (n==1) then 20 20 if (n==1) then
beskn=besk1(x) 21 21 beskn=besk1(x)
return 22 22 return
end if 23 23 end if
24 24
if (n < 0) then 25 25 if (n < 0) then
write(*,*) "Error in beskn, n must be >= 0" 26 26 write(*,*) "Error in beskn, n must be >= 0"
stop 27 27 stop
end if 28 28 end if
if (x <= 0.) then 29 29 if (x <= 0.) then
write(*,*) "Error in beskn, x must be strictly positive" 30 30 write(*,*) "Error in beskn, x must be strictly positive"
end if 31 31 end if
32 32
two_on_x=2./x 33 33 two_on_x=2./x
bknm1=besk0(x) 34 34 bknm1=besk0(x)
bkn=besk1(x) 35 35 bkn=besk1(x)
36 36
do i=1,n-1 37 37 do i=1,n-1
bktmp=two_on_x*bkn*i+bknm1 38 38 bktmp=two_on_x*bkn*i+bknm1
bknm1=bkn 39 39 bknm1=bkn
function besyn(n,x) 1 1 function besyn(n,x)
use Kind_Definition 2 2 use fvn_common
implicit none 3 3 implicit none
! This function compute the rank n Bessel Y function 4 4 ! This function compute the rank n Bessel Y function
! using recurrence relation : 5 5 ! using recurrence relation :
! Yn+1(x)=2n/x * Yn(x) - Yn-1(x) 6 6 ! Yn+1(x)=2n/x * Yn(x) - Yn-1(x)
! 7 7 !
real(sp_kind) :: besyn 8 8 real(sp_kind) :: besyn
integer :: n 9 9 integer :: n
real(sp_kind) :: x 10 10 real(sp_kind) :: x
11 11
real(sp_kind),external :: besy0,besy1 12 12 real(sp_kind),external :: besy0,besy1
real(sp_kind) :: two_on_x,bynm1,byn,bytmp 13 13 real(sp_kind) :: two_on_x,bynm1,byn,bytmp
integer :: i 14 14 integer :: i
15 15
if (n==0) then 16 16 if (n==0) then
besyn=besy0(x) 17 17 besyn=besy0(x)
return 18 18 return
end if 19 19 end if
if (n==1) then 20 20 if (n==1) then
besyn=besy1(x) 21 21 besyn=besy1(x)
return 22 22 return
end if 23 23 end if
24 24
if (n < 0) then 25 25 if (n < 0) then
write(*,*) "Error in besyn, n must be >= 0" 26 26 write(*,*) "Error in besyn, n must be >= 0"
stop 27 27 stop
end if 28 28 end if
if (x <= 0.) then 29 29 if (x <= 0.) then
write(*,*) "Error in besyn, x must be strictly positive" 30 30 write(*,*) "Error in besyn, x must be strictly positive"
end if 31 31 end if
32 32
two_on_x=2./x 33 33 two_on_x=2./x
bynm1=besy0(x) 34 34 bynm1=besy0(x)
byn=besy1(x) 35 35 byn=besy1(x)
36 36
do i=1,n-1 37 37 do i=1,n-1
bytmp=two_on_x*byn*i-bynm1 38 38 bytmp=two_on_x*byn*i-bynm1
bynm1=byn 39 39 bynm1=byn
fvn_fnlib/dbesin.f90
Diff comments   View file @ 8d883e8
function dbesin(n,x,factor,big) 1 1 function dbesin(n,x,factor,big)
use Kind_Definition 2 2 use fvn_common
implicit none 3 3 implicit none
! This function compute the rank n Bessel J function 4 4 ! This function compute the rank n Bessel J function
! using recurrence relation : 5 5 ! using recurrence relation :
! In+1(x)=-2n/x * In(x) + In-1(x) 6 6 ! In+1(x)=-2n/x * In(x) + In-1(x)
! 7 7 !
! Two optional parameters : 8 8 ! Two optional parameters :
! factor : an integer that is used in Miller's algorithm to determine the 9 9 ! factor : an integer that is used in Miller's algorithm to determine the
! starting point of iteration. Default value is 40, an increase of this value 10 10 ! starting point of iteration. Default value is 40, an increase of this value
! will increase accuracy. Starting point ~ nearest even integer of sqrt(factor*n) 11 11 ! will increase accuracy. Starting point ~ nearest even integer of sqrt(factor*n)
! big : a real that determine the threshold for taking anti overflow counter measure 12 12 ! big : a real that determine the threshold for taking anti overflow counter measure
! default value is 1e10 13 13 ! default value is 1e10
! 14 14 !
real(dp_kind) :: dbesin 15 15 real(dp_kind) :: dbesin
integer :: n 16 16 integer :: n
real(dp_kind) :: x 17 17 real(dp_kind) :: x
integer, optional :: factor 18 18 integer, optional :: factor
real(dp_kind), optional :: big 19 19 real(dp_kind), optional :: big
20 20
integer :: tfactor 21 21 integer :: tfactor
real(dp_kind) :: tbig,tsmall 22 22 real(dp_kind) :: tbig,tsmall
real(dp_kind) :: two_on_x,binm1,bin,binp1,absx 23 23 real(dp_kind) :: two_on_x,binm1,bin,binp1,absx
integer :: i,start 24 24 integer :: i,start
real(dp_kind), external :: dbesi0,dbesi1 25 25 real(dp_kind), external :: dbesi0,dbesi1
26 26
! Initialization of optional parameters 27 27 ! Initialization of optional parameters
tfactor=40 28 28 tfactor=40
if(present(factor)) tfactor=factor 29 29 if(present(factor)) tfactor=factor
tbig=1e10 30 30 tbig=1e10
if(present(big)) tbig=big 31 31 if(present(big)) tbig=big
tsmall=1./tbig 32 32 tsmall=1./tbig
33 33
if (n==0) then 34 34 if (n==0) then
dbesin=dbesi0(x) 35 35 dbesin=dbesi0(x)
return 36 36 return
end if 37 37 end if
if (n==1) then 38 38 if (n==1) then
dbesin=dbesi1(x) 39 39 dbesin=dbesi1(x)
return 40 40 return
end if 41 41 end if
42 42
if (n < 0) then 43 43 if (n < 0) then
write(*,*) "Error in dbesin, n must be >= 0" 44 44 write(*,*) "Error in dbesin, n must be >= 0"
stop 45 45 stop
end if 46 46 end if
47 47
absx=abs(x) 48 48 absx=abs(x)
if (absx == 0.) then 49 49 if (absx == 0.) then
dbesin=0. 50 50 dbesin=0.
else 51 51 else
! We use Miller's Algorithm 52 52 ! We use Miller's Algorithm
! as upward reccurence is unstable. 53 53 ! as upward reccurence is unstable.
! This is adapted from Numerical Recipes 54 54 ! This is adapted from Numerical Recipes
! Principle : use of downward recurrence from an arbitrary 55 55 ! Principle : use of downward recurrence from an arbitrary
! higher than n value with an arbitrary seed, 56 56 ! higher than n value with an arbitrary seed,
! and then use the normalization formula : 57 57 ! and then use the normalization formula :
! 1=I0-2I2+2I4-2I6+.... however it is easier to use a 58 58 ! 1=I0-2I2+2I4-2I6+.... however it is easier to use a
! call to besi0 59 59 ! call to besi0
two_on_x=2./absx 60 60 two_on_x=2./absx
start=2*((n+int(sqrt(real(n*tfactor,sp_kind))))/2) ! even start 61 61 start=2*((n+int(sqrt(real(n*tfactor,sp_kind))))/2) ! even start
binp1=0. 62 62 binp1=0.
bin=1. 63 63 bin=1.
do i=start,1,-1 64 64 do i=start,1,-1
! begin downward rec 65 65 ! begin downward rec
binm1=two_on_x*bin*i+binp1 66 66 binm1=two_on_x*bin*i+binp1
binp1=bin 67 67 binp1=bin
bin=binm1 68 68 bin=binm1
! Action to prevent overflow 69 69 ! Action to prevent overflow
if (abs(bin) > tbig) then 70 70 if (abs(bin) > tbig) then
bin=bin*tsmall 71 71 bin=bin*tsmall
binp1=binp1*tsmall 72 72 binp1=binp1*tsmall
dbesin=dbesin*tsmall 73 73 dbesin=dbesin*tsmall
end if 74 74 end if
if (i==n) dbesin=binp1 75 75 if (i==n) dbesin=binp1
end do 76 76 end do
dbesin=dbesin*dbesi0(x)/bin 77 77 dbesin=dbesin*dbesi0(x)/bin
fvn_fnlib/dbesjn.f90
Diff comments   View file @ 8d883e8
function dbesjn(n,x,factor,big) 1 1 function dbesjn(n,x,factor,big)
use Kind_Definition 2 2 use fvn_common
implicit none 3 3 implicit none
! This function compute the rank n Bessel J function 4 4 ! This function compute the rank n Bessel J function
! using recurrence relation : 5 5 ! using recurrence relation :
! Jn+1(x)=2n/x * Jn(x) - Jn-1(x) 6 6 ! Jn+1(x)=2n/x * Jn(x) - Jn-1(x)
! 7 7 !
! Two optional parameters : 8 8 ! Two optional parameters :
! factor : an integer that is used in Miller's algorithm to determine the 9 9 ! factor : an integer that is used in Miller's algorithm to determine the
! starting point of iteration. Default value is 40, an increase of this value 10 10 ! starting point of iteration. Default value is 40, an increase of this value
! will increase accuracy. Starting point ~ nearest even integer of sqrt(factor*n) 11 11 ! will increase accuracy. Starting point ~ nearest even integer of sqrt(factor*n)
! big : a real that determine the threshold for taking anti overflow counter measure 12 12 ! big : a real that determine the threshold for taking anti overflow counter measure
! default value is 1e10 13 13 ! default value is 1e10
! 14 14 !
real(dp_kind) :: dbesjn 15 15 real(dp_kind) :: dbesjn
integer :: n 16 16 integer :: n
real(dp_kind) :: x 17 17 real(dp_kind) :: x
integer, optional :: factor 18 18 integer, optional :: factor
real(dp_kind), optional :: big 19 19 real(dp_kind), optional :: big
20 20
integer :: tfactor 21 21 integer :: tfactor
real(dp_kind) :: tbig,tsmall,som 22 22 real(dp_kind) :: tbig,tsmall,som
real(dp_kind),external :: dbesj0,dbesj1 23 23 real(dp_kind),external :: dbesj0,dbesj1
real(dp_kind) :: two_on_x,bjnm1,bjn,bjnp1,absx 24 24 real(dp_kind) :: two_on_x,bjnm1,bjn,bjnp1,absx
integer :: i,start 25 25 integer :: i,start
logical :: iseven 26 26 logical :: iseven
27 27
! Initialization of optional parameters 28 28 ! Initialization of optional parameters
tfactor=40 29 29 tfactor=40
if(present(factor)) tfactor=factor 30 30 if(present(factor)) tfactor=factor
tbig=1d10 31 31 tbig=1d10
if(present(big)) tbig=big 32 32 if(present(big)) tbig=big
tsmall=1./tbig 33 33 tsmall=1./tbig
34 34
if (n==0) then 35 35 if (n==0) then
dbesjn=dbesj0(x) 36 36 dbesjn=dbesj0(x)
return 37 37 return
end if 38 38 end if
if (n==1) then 39 39 if (n==1) then
dbesjn=dbesj1(x) 40 40 dbesjn=dbesj1(x)
return 41 41 return
end if 42 42 end if
if (n < 0) then 43 43 if (n < 0) then
write(*,*) "Error in dbesjn, n must be >= 0" 44 44 write(*,*) "Error in dbesjn, n must be >= 0"
stop 45 45 stop
end if 46 46 end if
47 47
absx=abs(x) 48 48 absx=abs(x)
if (absx == 0.) then 49 49 if (absx == 0.) then
dbesjn=0. 50 50 dbesjn=0.
else if (absx > real(n,dp_kind)) then 51 51 else if (absx > real(n,dp_kind)) then
! For x > n upward reccurence is stable 52 52 ! For x > n upward reccurence is stable
two_on_x=2./absx 53 53 two_on_x=2./absx
bjnm1=dbesj0(absx) 54 54 bjnm1=dbesj0(absx)
bjn=dbesj1(absx) 55 55 bjn=dbesj1(absx)
do i=1,n-1 56 56 do i=1,n-1
bjnp1=two_on_x*bjn*i-bjnm1 57 57 bjnp1=two_on_x*bjn*i-bjnm1
bjnm1=bjn 58 58 bjnm1=bjn
bjn=bjnp1 59 59 bjn=bjnp1
end do 60 60 end do
dbesjn=bjnp1 61 61 dbesjn=bjnp1
else 62 62 else
! For x <= n we use Miller's Algorithm 63 63 ! For x <= n we use Miller's Algorithm
! as upward reccurence is unstable. 64 64 ! as upward reccurence is unstable.
! This is adapted from Numerical Recipes 65 65 ! This is adapted from Numerical Recipes
! Principle : use of downward recurrence from an arbitrary 66 66 ! Principle : use of downward recurrence from an arbitrary
! higher than n value with an arbitrary seed, 67 67 ! higher than n value with an arbitrary seed,
! and then use the normalization formula : 68 68 ! and then use the normalization formula :
! 1=J0+2J2+2J4+2J6+.... 69 69 ! 1=J0+2J2+2J4+2J6+....
two_on_x=2./absx 70 70 two_on_x=2./absx
start=2*((n+int(sqrt(real(n*tfactor,sp_kind))))/2) ! even start 71 71 start=2*((n+int(sqrt(real(n*tfactor,sp_kind))))/2) ! even start
som=0. 72 72 som=0.
iseven=.false. 73 73 iseven=.false.
bjnp1=0. 74 74 bjnp1=0.
bjn=1. 75 75 bjn=1.
do i=start,1,-1 76 76 do i=start,1,-1
! begin downward rec 77 77 ! begin downward rec
bjnm1=two_on_x*bjn*i-bjnp1 78 78 bjnm1=two_on_x*bjn*i-bjnp1
bjnp1=bjn 79 79 bjnp1=bjn
bjn=bjnm1 80 80 bjn=bjnm1
! Action to prevent overflow 81 81 ! Action to prevent overflow
if (abs(bjn) > tbig) then 82 82 if (abs(bjn) > tbig) then
bjn=bjn*tsmall 83 83 bjn=bjn*tsmall
bjnp1=bjnp1*tsmall 84 84 bjnp1=bjnp1*tsmall
dbesjn=dbesjn*tsmall 85 85 dbesjn=dbesjn*tsmall
som=som*tsmall 86 86 som=som*tsmall
end if 87 87 end if
if (iseven) then 88 88 if (iseven) then
som=som+bjn 89 89 som=som+bjn
end if 90 90 end if
iseven= .not. iseven 91 91 iseven= .not. iseven
if (i==n) dbesjn=bjnp1 92 92 if (i==n) dbesjn=bjnp1
end do 93 93 end do
som=2.*som-bjn 94 94 som=2.*som-bjn
dbesjn=dbesjn/som 95 95 dbesjn=dbesjn/som
end if 96 96 end if
fvn_fnlib/dbeskn.f90
Diff comments   View file @ 8d883e8
function dbeskn(n,x) 1 1 function dbeskn(n,x)
use Kind_Definition 2 2 use fvn_common
implicit none 3 3 implicit none
! This function compute the rank n Bessel Y function 4 4 ! This function compute the rank n Bessel Y function
! using recurrence relation : 5 5 ! using recurrence relation :
! Kn+1(x)=2n/x * Kn(x) + Kn-1(x) 6 6 ! Kn+1(x)=2n/x * Kn(x) + Kn-1(x)
! 7 7 !
real(dp_kind) :: dbeskn 8 8 real(dp_kind) :: dbeskn
integer :: n 9 9 integer :: n
real(dp_kind) :: x 10 10 real(dp_kind) :: x
11 11
real(dp_kind),external :: dbesk0,dbesk1 12 12 real(dp_kind),external :: dbesk0,dbesk1
real(dp_kind) :: two_on_x,bknm1,bkn,bktmp 13 13 real(dp_kind) :: two_on_x,bknm1,bkn,bktmp
integer :: i 14 14 integer :: i
15 15
if (n==0) then 16 16 if (n==0) then
dbeskn=dbesk0(x) 17 17 dbeskn=dbesk0(x)
return 18 18 return
end if 19 19 end if
if (n==1) then 20 20 if (n==1) then
dbeskn=dbesk1(x) 21 21 dbeskn=dbesk1(x)
return 22 22 return
end if 23 23 end if
24 24
if (n < 0) then 25 25 if (n < 0) then
write(*,*) "Error in dbeskn, n must be >= 0" 26 26 write(*,*) "Error in dbeskn, n must be >= 0"
stop 27 27 stop
end if 28 28 end if
if (x <= 0.) then 29 29 if (x <= 0.) then
write(*,*) "Error in dbeskn, x must be strictly positive" 30 30 write(*,*) "Error in dbeskn, x must be strictly positive"
end if 31 31 end if
32 32
two_on_x=2./x 33 33 two_on_x=2./x
bknm1=dbesk0(x) 34 34 bknm1=dbesk0(x)
bkn=dbesk1(x) 35 35 bkn=dbesk1(x)
36 36
do i=1,n-1 37 37 do i=1,n-1
bktmp=two_on_x*bkn*i+bknm1 38 38 bktmp=two_on_x*bkn*i+bknm1
bknm1=bkn 39 39 bknm1=bkn
fvn_fnlib/dbesyn.f90
Diff comments   View file @ 8d883e8
function dbesyn(n,x) 1 1 function dbesyn(n,x)
use Kind_Definition 2 2 use fvn_common
implicit none 3 3 implicit none
! This function compute the rank n Bessel Y function 4 4 ! This function compute the rank n Bessel Y function
! using recurrence relation : 5 5 ! using recurrence relation :
! Yn+1(x)=2n/x * Yn(x) - Yn-1(x) 6 6 ! Yn+1(x)=2n/x * Yn(x) - Yn-1(x)
! 7 7 !
real(dp_kind) :: dbesyn 8 8 real(dp_kind) :: dbesyn
integer :: n 9 9 integer :: n
real(dp_kind) :: x 10 10 real(dp_kind) :: x
11 11
real(dp_kind),external :: dbesy0,dbesy1 12 12 real(dp_kind),external :: dbesy0,dbesy1
real(dp_kind) :: two_on_x,bynm1,byn,bytmp 13 13 real(dp_kind) :: two_on_x,bynm1,byn,bytmp
integer :: i 14 14 integer :: i
15 15
if (n==0) then 16 16 if (n==0) then
dbesyn=dbesy0(x) 17 17 dbesyn=dbesy0(x)
return 18 18 return
end if 19 19 end if
if (n==1) then 20 20 if (n==1) then
dbesyn=dbesy1(x) 21 21 dbesyn=dbesy1(x)
return 22 22 return
end if 23 23 end if
if (n < 0) then 24 24 if (n < 0) then
write(*,*) "Error in dbesyn, n must be >= 0" 25 25 write(*,*) "Error in dbesyn, n must be >= 0"
stop 26 26 stop
end if 27 27 end if
if (x <= 0.) then 28 28 if (x <= 0.) then
write(*,*) "Error in dbesyn, x must be strictly positive" 29 29 write(*,*) "Error in dbesyn, x must be strictly positive"
end if 30 30 end if
31 31
two_on_x=2./x 32 32 two_on_x=2./x
bynm1=dbesy0(x) 33 33 bynm1=dbesy0(x)
byn=dbesy1(x) 34 34 byn=dbesy1(x)
35 35
do i=1,n-1 36 36 do i=1,n-1
bytmp=two_on_x*byn*i-bynm1 37 37 bytmp=two_on_x*byn*i-bynm1
bynm1=byn 38 38 bynm1=byn
byn=bytmp 39 39 byn=bytmp
fvn_fnlib/fvn_fnlib.f90
Diff comments   View file @ 8d883e8
module fvn_fnlib 1 1 module fvn_fnlib
use fvn_common 2 2 use fvn_common
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 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 function carg(z) 14 14 real function carg(z)
complex :: z 15 15 complex :: z
end function carg 16 16 end function carg
real(kind(1.d0)) function zarg(z) 17 17 real(kind(1.d0)) function zarg(z)
complex(kind(1.d0)) :: z 18 18 complex(kind(1.d0)) :: 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 function cbrt(x) 24 24 real function cbrt(x)
real :: x 25 25 real :: x
end function cbrt 26 26 end function cbrt
real(kind(1.d0)) function dcbrt(x) 27 27 real(kind(1.d0)) function dcbrt(x)
real(kind(1.d0)) :: x 28 28 real(kind(1.d0)) :: x
end function dcbrt 29 29 end function dcbrt
complex function ccbrt(z) 30 30 complex function ccbrt(z)
complex :: z 31 31 complex :: z
end function ccbrt 32 32 end function ccbrt
complex(kind(1.d0)) function zcbrt(z) 33 33 complex(kind(1.d0)) function zcbrt(z)
complex(kind(1.d0)) :: z 34 34 complex(kind(1.d0)) :: 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 function exprel(x) 40 40 real function exprel(x)
real :: x 41 41 real :: x
end function exprel 42 42 end function exprel
real(kind(1.d0)) function dexprl(x) 43 43 real(kind(1.d0)) function dexprl(x)
real(kind(1.d0)) :: x 44 44 real(kind(1.d0)) :: x
end function dexprl 45 45 end function dexprl
complex function cexprl(z) 46 46 complex function cexprl(z)
complex :: z 47 47 complex :: z
end function cexprl 48 48 end function cexprl
complex(kind(1.d0)) function zexprl(z) 49 49 complex(kind(1.d0)) function zexprl(z)
complex(kind(1.d0)) :: z 50 50 complex(kind(1.d0)) :: 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 function clog10(z) 56 56 complex function clog10(z)
complex :: z 57 57 complex :: z
end function clog10 58 58 end function clog10
complex(kind(1.d0)) function zlog10(z) 59 59 complex(kind(1.d0)) function zlog10(z)
complex(kind(1.d0)) :: z 60 60 complex(kind(1.d0)) :: 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 function alnrel(x) 66 66 real function alnrel(x)
real :: x 67 67 real :: x
end function alnrel 68 68 end function alnrel
real(kind(1.d0)) function dlnrel(x) 69 69 real(kind(1.d0)) function dlnrel(x)
real(kind(1.d0)) :: x 70 70 real(kind(1.d0)) :: x
end function dlnrel 71 71 end function dlnrel
complex function clnrel(z) 72 72 complex function clnrel(z)
complex :: z 73 73 complex :: z
end function clnrel 74 74 end function clnrel
complex(kind(1.d0)) function zlnrel(z) 75 75 complex(kind(1.d0)) function zlnrel(z)
complex(kind(1.d0)) :: z 76 76 complex(kind(1.d0)) :: 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 function ctan(z) 91 91 complex function ctan(z)
complex :: z 92 92 complex :: z
end function ctan 93 93 end function ctan
complex(kind(1.d0)) function ztan(z) 94 94 complex(kind(1.d0)) function ztan(z)
complex(kind(1.d0)) :: z 95 95 complex(kind(1.d0)) :: 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 function cot(x) 101 101 real function cot(x)
real :: x 102 102 real :: x
end function cot 103 103 end function cot
real(kind(1.d0)) function dcot(x) 104 104 real(kind(1.d0)) function dcot(x)
real(kind(1.d0)) :: x 105 105 real(kind(1.d0)) :: x
end function dcot 106 106 end function dcot
complex function ccot(z) 107 107 complex function ccot(z)
complex :: z 108 108 complex :: z
end function ccot 109 109 end function ccot
complex(kind(1.d0)) function zcot(z) 110 110 complex(kind(1.d0)) function zcot(z)
complex(kind(1.d0)) :: z 111 111 complex(kind(1.d0)) :: 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 function sindg(x) 117 117 real function sindg(x)
real :: x 118 118 real :: x
end function sindg 119 119 end function sindg
real(kind(1.d0)) function dsindg(x) 120 120 real(kind(1.d0)) function dsindg(x)
real(kind(1.d0)) :: x 121 121 real(kind(1.d0)) :: 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 function cosdg(x) 127 127 real function cosdg(x)
real :: x 128 128 real :: x
end function cosdg 129 129 end function cosdg
real(kind(1.d0)) function dcosdg(x) 130 130 real(kind(1.d0)) function dcosdg(x)
real(kind(1.d0)) :: x 131 131 real(kind(1.d0)) :: 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 function casin(z) 138 138 complex function casin(z)
complex :: z 139 139 complex :: z
end function casin 140 140 end function casin
complex(kind(1.d0)) function zasin(z) 141 141 complex(kind(1.d0)) function zasin(z)
complex(kind(1.d0)) :: z 142 142 complex(kind(1.d0)) :: 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 function cacos(z) 148 148 complex function cacos(z)
complex :: z 149 149 complex :: z
end function cacos 150 150 end function cacos
complex(kind(1.d0)) function zacos(z) 151 151 complex(kind(1.d0)) function zacos(z)
complex(kind(1.d0)) :: z 152 152 complex(kind(1.d0)) :: 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 function catan(z) 158 158 complex function catan(z)
complex :: z 159 159 complex :: z
end function catan 160 160 end function catan
complex(kind(1.d0)) function zatan(z) 161 161 complex(kind(1.d0)) function zatan(z)
complex(kind(1.d0)) :: z 162 162 complex(kind(1.d0)) :: 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 function catan2(csn,ccs) 168 168 complex function catan2(csn,ccs)
complex :: csn,ccs 169 169 complex :: csn,ccs
end function catan2 170 170 end function catan2
complex(kind(1.d0)) function zatan2(csn,ccs) 171 171 complex(kind(1.d0)) function zatan2(csn,ccs)
complex(kind(1.d0)) :: csn,ccs 172 172 complex(kind(1.d0)) :: 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 function csinh(z) 182 182 complex function csinh(z)
complex :: z 183 183 complex :: z
end function csinh 184 184 end function csinh
complex(kind(1.d0)) function zsinh(z) 185 185 complex(kind(1.d0)) function zsinh(z)
complex(kind(1.d0)) :: z 186 186 complex(kind(1.d0)) :: 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 function ccosh(z) 192 192 complex function ccosh(z)
complex :: z 193 193 complex :: z
end function ccosh 194 194 end function ccosh
complex(kind(1.d0)) function zcosh(z) 195 195 complex(kind(1.d0)) function zcosh(z)
complex(kind(1.d0)) :: z 196 196 complex(kind(1.d0)) :: 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 function ctanh(z) 202 202 complex function ctanh(z)
complex :: z 203 203 complex :: z
end function ctanh 204 204 end function ctanh
complex(kind(1.d0)) function ztanh(z) 205 205 complex(kind(1.d0)) function ztanh(z)
complex(kind(1.d0)) :: z 206 206 complex(kind(1.d0)) :: 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 function asinh(x) 212 212 real function asinh(x)
real :: x 213 213 real :: x
end function asinh 214 214 end function asinh
real(kind(1.d0)) function dasinh(x) 215 215 real(kind(1.d0)) function dasinh(x)
real(kind(1.d0)) :: x 216 216 real(kind(1.d0)) :: x
end function dasinh 217 217 end function dasinh
complex function casinh(z) 218 218 complex function casinh(z)
complex :: z 219 219 complex :: z
end function casinh 220 220 end function casinh
complex(kind(1.d0)) function zasinh(z) 221 221 complex(kind(1.d0)) function zasinh(z)
complex(kind(1.d0)) :: z 222 222 complex(kind(1.d0)) :: 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 function acosh(x) 228 228 real function acosh(x)
real :: x 229 229 real :: x
end function acosh 230 230 end function acosh
real(kind(1.d0)) function dacosh(x) 231 231 real(kind(1.d0)) function dacosh(x)
real(kind(1.d0)) :: x 232 232 real(kind(1.d0)) :: x
end function dacosh 233 233 end function dacosh
complex function cacosh(z) 234 234 complex function cacosh(z)
complex :: z 235 235 complex :: z
end function cacosh 236 236 end function cacosh
complex(kind(1.d0)) function zacosh(z) 237 237 complex(kind(1.d0)) function zacosh(z)
complex(kind(1.d0)) :: z 238 238 complex(kind(1.d0)) :: z
end function zacosh 239 239 end function zacosh
end interface acosh 240 240 end interface acosh
241 241
! Arc tangente hyperbolique 242 242 ! Arc tangente hyperbolique
interface atanh 243 243 interface atanh
real function atanh(x) 244 244 real function atanh(x)
real :: x 245 245 real :: x
end function atanh 246 246 end function atanh
real(kind(1.d0)) function datanh(x) 247 247 real(kind(1.d0)) function datanh(x)
real(kind(1.d0)) :: x 248 248 real(kind(1.d0)) :: x
end function datanh 249 249 end function datanh
complex function catanh(z) 250 250 complex function catanh(z)
complex :: z 251 251 complex :: z
end function catanh 252 252 end function catanh
complex(kind(1.d0)) function zatanh(z) 253 253 complex(kind(1.d0)) function zatanh(z)
complex(kind(1.d0)) :: z 254 254 complex(kind(1.d0)) :: z
end function zatanh 255 255 end function zatanh
end interface atanh 256 256 end interface atanh
257 257
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 258 258 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! END Trigonometry 259 259 ! END Trigonometry
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 260 260 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
261 261
262 262
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 263 263 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Exponential integral and related 264 264 ! Exponential integral and related
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 265 265 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
266 266
! Exponential integral ei(x) 267 267 ! Exponential integral ei(x)
interface ei 268 268 interface ei
real function ei(x) 269 269 real function ei(x)
real :: x 270 270 real :: x
end function ei 271 271 end function ei
real(kind(1.d0)) function dei(x) 272 272 real(kind(1.d0)) function dei(x)
real(kind(1.d0)) :: x 273 273 real(kind(1.d0)) :: x
end function dei 274 274 end function dei
end interface ei 275 275 end interface ei
276 276
! Exponential integral e1(x) 277 277 ! Exponential integral e1(x)
interface e1 278 278 interface e1
real function e1(x) 279 279 real function e1(x)
real :: x 280 280 real :: x
end function e1 281 281 end function e1
real(kind(1.d0)) function de1(x) 282 282 real(kind(1.d0)) function de1(x)
real(kind(1.d0)) :: x 283 283 real(kind(1.d0)) :: x
end function de1 284 284 end function de1
complex(kind(1.d0)) function ze1(x) 285 285 complex(kind(1.d0)) function ze1(x)
complex(kind(1.d0)) :: x 286 286 complex(kind(1.d0)) :: x
end function 287 287 end function
end interface e1 288 288 end interface e1
289 289
!!!!!!!!!!!!!!! 290 290 !!!!!!!!!!!!!!!
! MISSING ENE 291 291 ! MISSING ENE
!!!!!!!!!!!!!!! 292 292 !!!!!!!!!!!!!!!
293 293
! Logarithm integral 294 294 ! Logarithm integral
interface ali 295 295 interface ali
real function ali(x) 296 296 real function ali(x)
real :: x 297 297 real :: x
end function ali 298 298 end function ali
real(kind(1.d0)) function dli(x) 299 299 real(kind(1.d0)) function dli(x)
real(kind(1.d0)) :: x 300 300 real(kind(1.d0)) :: x
end function dli 301 301 end function dli
end interface ali 302 302 end interface ali
303 303
! Sine integral 304 304 ! Sine integral
interface si 305 305 interface si
real function si(x) 306 306 real function si(x)
real :: x 307 307 real :: x
end function si 308 308 end function si
real(kind(1.d0)) function dsi(x) 309 309 real(kind(1.d0)) function dsi(x)
real(kind(1.d0)) :: x 310 310 real(kind(1.d0)) :: x
end function dsi 311 311 end function dsi
end interface si 312 312 end interface si
313 313
! Cosine integral 314 314 ! Cosine integral
interface ci 315 315 interface ci
real function ci(x) 316 316 real function ci(x)
real :: x 317 317 real :: x
end function ci 318 318 end function ci
real(kind(1.d0)) function dci(x) 319 319 real(kind(1.d0)) function dci(x)
real(kind(1.d0)) :: x 320 320 real(kind(1.d0)) :: x
end function dci 321 321 end function dci
end interface ci 322 322 end interface ci
323 323
! Cosine integral alternate definition 324 324 ! Cosine integral alternate definition
interface cin 325 325 interface cin
real function cin(x) 326 326 real function cin(x)
real :: x 327 327 real :: x
end function cin 328 328 end function cin
real(kind(1.d0)) function dcin(x) 329 329 real(kind(1.d0)) function dcin(x)
real(kind(1.d0)) :: x 330 330 real(kind(1.d0)) :: x
end function dcin 331 331 end function dcin
end interface cin 332 332 end interface cin
333 333
! Hyperbolic sine integral 334 334 ! Hyperbolic sine integral
interface shi 335 335 interface shi
real function shi(x) 336 336 real function shi(x)
real :: x 337 337 real :: x
end function shi 338 338 end function shi
real(kind(1.d0)) function dshi(x) 339 339 real(kind(1.d0)) function dshi(x)
real(kind(1.d0)) :: x 340 340 real(kind(1.d0)) :: x
end function dshi 341 341 end function dshi
end interface shi 342 342 end interface shi
343 343
! Hyperbolic cosine integral 344 344 ! Hyperbolic cosine integral
interface chi 345 345 interface chi
real function chi(x) 346 346 real function chi(x)
real :: x 347 347 real :: x
end function chi 348 348 end function chi
real(kind(1.d0)) function dchi(x) 349 349 real(kind(1.d0)) function dchi(x)
real(kind(1.d0)) :: x 350 350 real(kind(1.d0)) :: x
end function dchi 351 351 end function dchi
end interface chi 352 352 end interface chi
353 353
! Hyperbolic cosine integral alternate definition 354 354 ! Hyperbolic cosine integral alternate definition
interface cinh 355 355 interface cinh
real function cinh(x) 356 356 real function cinh(x)
real :: x 357 357 real :: x
end function cinh 358 358 end function cinh
real(kind(1.d0)) function dcinh(x) 359 359 real(kind(1.d0)) function dcinh(x)
real(kind(1.d0)) :: x 360 360 real(kind(1.d0)) :: x
end function dcinh 361 361 end function dcinh
end interface cinh 362 362 end interface cinh
363 363
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 364 364 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! END Exponential integral and related 365 365 ! END Exponential integral and related
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 366 366 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
367 367
368 368
369 369
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 370 370 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Gamma family 371 371 ! Gamma family
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 372 372 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
373 373
! No generic interface for fac and binom but we still 374 374 ! No generic interface for fac and binom but we still
! define their prototypes 375 375 ! define their prototypes
! Factorial 376 376 ! Factorial
interface 377 377 interface
real function fac(n) 378 378 real function fac(n)
integer :: n 379 379 integer :: n
end function fac 380 380 end function fac
real(kind(1.d0)) function dfac(n) 381 381 real(kind(1.d0)) function dfac(n)
integer :: n 382 382 integer :: n
end function dfac 383 383 end function dfac
! Binomial coefficient 384 384 ! Binomial coefficient
real function binom(n,m) 385 385 real function binom(n,m)
integer :: n,m 386 386 integer :: n,m
end function binom 387 387 end function binom
real(kind(1.d0)) function dbinom(n,m) 388 388 real(kind(1.d0)) function dbinom(n,m)
integer :: n,m 389 389 integer :: n,m
end function dbinom 390 390 end function dbinom
end interface 391 391 end interface
392 392
! Gamma function 393 393 ! Gamma function
interface gamma 394 394 interface gamma
real function gamma(x) 395 395 real function gamma(x)
real :: x 396 396 real :: x
end function gamma 397 397 end function gamma
real(kind(1.d0)) function dgamma(x) 398 398 real(kind(1.d0)) function dgamma(x)
real(kind(1.d0)) :: x 399 399 real(kind(1.d0)) :: x
end function dgamma 400 400 end function dgamma
complex function cgamma(z) 401 401 complex function cgamma(z)
complex :: z 402 402 complex :: z
end function cgamma 403 403 end function cgamma
complex(kind(1.d0)) function zgamma(z) 404 404 complex(kind(1.d0)) function zgamma(z)
complex(kind(1.d0)) :: z 405 405 complex(kind(1.d0)) :: z
end function zgamma 406 406 end function zgamma
end interface gamma 407 407 end interface gamma
408 408
! Reciprocal of gamma function 409 409 ! Reciprocal of gamma function
interface gamr 410 410 interface gamr
real function gamr(x) 411 411 real function gamr(x)
real :: x 412 412 real :: x
end function gamr 413 413 end function gamr
real(kind(1.d0)) function dgamr(x) 414 414 real(kind(1.d0)) function dgamr(x)
real(kind(1.d0)) :: x 415 415 real(kind(1.d0)) :: x
end function dgamr 416 416 end function dgamr
complex function cgamr(z) 417 417 complex function cgamr(z)
complex :: z 418 418 complex :: z
end function cgamr 419 419 end function cgamr
complex(kind(1.d0)) function zgamr(z) 420 420 complex(kind(1.d0)) function zgamr(z)
complex(kind(1.d0)) :: z 421 421 complex(kind(1.d0)) :: z
end function zgamr 422 422 end function zgamr
end interface gamr 423 423 end interface gamr
424 424
! natural log of abs(gamma) 425 425 ! natural log of abs(gamma)
interface alngam 426 426 interface alngam
real function alngam(x) 427 427 real function alngam(x)
real :: x 428 428 real :: x
end function alngam 429 429 end function alngam
real(kind(1.d0)) function dlngam(x) 430 430 real(kind(1.d0)) function dlngam(x)
real(kind(1.d0)) :: x 431 431 real(kind(1.d0)) :: x
end function dlngam 432 432 end function dlngam
complex function clngam(z) 433 433 complex function clngam(z)
complex :: z 434 434 complex :: z
end function clngam 435 435 end function clngam
complex(kind(1.d0)) function zlngam(z) 436 436 complex(kind(1.d0)) function zlngam(z)
complex(kind(1.d0)) :: z 437 437 complex(kind(1.d0)) :: z
end function zlngam 438 438 end function zlngam
end interface alngam 439 439 end interface alngam
440 440
! log abs gamma and sign 441 441 ! log abs gamma and sign
interface algams 442 442 interface algams
subroutine algams(x,algam,sgngam) 443 443 subroutine algams(x,algam,sgngam)
real :: x 444 444 real :: x
end subroutine algams 445 445 end subroutine algams
subroutine dlgams(x,algam,sgngam) 446 446 subroutine dlgams(x,algam,sgngam)
real(kind(1.d0)) :: x 447 447 real(kind(1.d0)) :: x
end subroutine dlgams 448 448 end subroutine dlgams
end interface algams 449 449 end interface algams
450 450
! Incomplete gamma function 451 451 ! Incomplete gamma function
interface gami 452 452 interface gami
real function gami(a,x) 453 453 real function gami(a,x)
real :: a,x 454 454 real :: a,x
end function gami 455 455 end function gami
real(kind(1.d0)) function dgami(a,x) 456 456 real(kind(1.d0)) function dgami(a,x)
real(kind(1.d0)) :: a,x 457 457 real(kind(1.d0)) :: a,x
end function dgami 458 458 end function dgami
end interface gami 459 459 end interface gami
460 460
! Complementary incomplete gamma function 461 461 ! Complementary incomplete gamma function
interface gamic 462 462 interface gamic
real function gamic(a,x) 463 463 real function gamic(a,x)
real :: a,x 464 464 real :: a,x
end function gamic 465 465 end function gamic
real(kind(1.d0)) function dgamic(a,x) 466 466 real(kind(1.d0)) function dgamic(a,x)
real(kind(1.d0)) :: a,x 467 467 real(kind(1.d0)) :: a,x
end function dgamic 468 468 end function dgamic
end interface gamic 469 469 end interface gamic
470 470
! Tricomi's incomplete gamma function 471 471 ! Tricomi's incomplete gamma function
interface gamit 472 472 interface gamit
real function gamit(a,x) 473 473 real function gamit(a,x)
real :: a,x 474 474 real :: a,x
end function gamit 475 475 end function gamit
real(kind(1.d0)) function dgamit(a,x) 476 476 real(kind(1.d0)) function dgamit(a,x)
real(kind(1.d0)) :: a,x 477 477 real(kind(1.d0)) :: a,x
end function dgamit 478 478 end function dgamit
end interface gamit 479 479 end interface gamit
480 480
! Psi function 481 481 ! Psi function
interface psi 482 482 interface psi
real function psi(x) 483 483 real function psi(x)
real :: x 484 484 real :: x
end function psi 485 485 end function psi
real(kind(1.d0)) function dpsi(x) 486 486 real(kind(1.d0)) function dpsi(x)
real(kind(1.d0)) :: x 487 487 real(kind(1.d0)) :: x
end function dpsi 488 488 end function dpsi
complex function cpsi(z) 489 489 complex function cpsi(z)
complex :: z 490 490 complex :: z
end function cpsi 491 491 end function cpsi
complex(kind(1.d0)) function zpsi(z) 492 492 complex(kind(1.d0)) function zpsi(z)
complex(kind(1.d0)) :: z 493 493 complex(kind(1.d0)) :: z
end function zpsi 494 494 end function zpsi
end interface psi 495 495 end interface psi
496 496
! Pochhammer 497 497 ! Pochhammer
interface poch 498 498 interface poch
real function poch(a,x) 499 499 real function poch(a,x)
real :: a,x 500 500 real :: a,x
end function poch 501 501 end function poch
real(kind(1.d0)) function dpoch(a,x) 502 502 real(kind(1.d0)) function dpoch(a,x)
real(kind(1.d0)) :: a,x 503 503 real(kind(1.d0)) :: a,x
end function dpoch 504 504 end function dpoch
end interface poch 505 505 end interface poch
506 506
! Pochhammer first order 507 507 ! Pochhammer first order
interface poch1 508 508 interface poch1
real function poch1(a,x) 509 509 real function poch1(a,x)
real :: a,x 510 510 real :: a,x
end function poch1 511 511 end function poch1
real(kind(1.d0)) function dpoch1(a,x) 512 512 real(kind(1.d0)) function dpoch1(a,x)
real(kind(1.d0)) :: a,x 513 513 real(kind(1.d0)) :: a,x
end function dpoch1 514 514 end function dpoch1
end interface poch1 515 515 end interface poch1
516 516
! Beta function 517 517 ! Beta function
interface beta 518 518 interface beta
real function beta(a,b) 519 519 real function beta(a,b)
real :: a,b 520 520 real :: a,b
end function beta 521 521 end function beta
real(kind(1.d0)) function dbeta(a,b) 522 522 real(kind(1.d0)) function dbeta(a,b)
real(kind(1.d0)) :: a,b 523 523 real(kind(1.d0)) :: a,b
end function dbeta 524 524 end function dbeta
complex function cbeta(a,b) 525 525 complex function cbeta(a,b)
complex :: a,b 526 526 complex :: a,b
end function cbeta 527 527 end function cbeta
complex(kind(1.d0)) function zbeta(a,b) 528 528 complex(kind(1.d0)) function zbeta(a,b)
complex(kind(1.d0)) :: a,b 529 529 complex(kind(1.d0)) :: a,b
end function zbeta 530 530 end function zbeta
end interface beta 531 531 end interface beta
532 532
! natural log of beta 533 533 ! natural log of beta
interface albeta 534 534 interface albeta
real function albeta(a,b) 535 535 real function albeta(a,b)
real :: a,b 536 536 real :: a,b
end function albeta 537 537 end function albeta
real(kind(1.d0)) function dlbeta(a,b) 538 538 real(kind(1.d0)) function dlbeta(a,b)
real(kind(1.d0)) :: a,b 539 539 real(kind(1.d0)) :: a,b
end function dlbeta 540 540 end function dlbeta
complex function clbeta(a,b) 541 541 complex function clbeta(a,b)
complex :: a,b 542 542 complex :: a,b
end function clbeta 543 543 end function clbeta
complex(kind(1.d0)) function zlbeta(a,b) 544 544 complex(kind(1.d0)) function zlbeta(a,b)
complex(kind(1.d0)) :: a,b 545 545 complex(kind(1.d0)) :: a,b
end function zlbeta 546 546 end function zlbeta
end interface albeta 547 547 end interface albeta
548 548
! Incomplete beta function 549 549 ! Incomplete beta function
interface betai 550 550 interface betai
real function betai(x,pin,qin) 551 551 real function betai(x,pin,qin)
real :: x,pin,qin 552 552 real :: x,pin,qin
end function betai 553 553 end function betai
real(kind(1.d0)) function dbetai(x,pin,qin) 554 554 real(kind(1.d0)) function dbetai(x,pin,qin)
real(kind(1.d0)) :: x,pin,qin 555 555 real(kind(1.d0)) :: x,pin,qin
end function dbetai 556 556 end function dbetai
end interface betai 557 557 end interface betai
558 558
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 559 559 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! END Gamma family 560 560 ! END Gamma family
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 561 561 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
562 562
563 563
564 564
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 565 565 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Error function and related 566 566 ! Error function and related
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 567 567 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
568 568
! Error function 569 569 ! Error function
interface erf 570 570 interface erf
real function erf(x) 571 571 real function erf(x)
real :: x 572 572 real :: x
end function erf 573 573 end function erf
real(kind(1.d0)) function derf(x) 574 574 real(kind(1.d0)) function derf(x)
real(kind(1.d0)) :: x 575 575 real(kind(1.d0)) :: x
end function derf 576 576 end function derf
end interface erf 577 577 end interface erf
578 578
! Complementary error function 579 579 ! Complementary error function
interface erfc 580 580 interface erfc
real function erfc(x) 581 581 real function erfc(x)
real :: x 582 582 real :: x
end function erfc 583 583 end function erfc
real(kind(1.d0)) function derfc(x) 584 584 real(kind(1.d0)) function derfc(x)
real(kind(1.d0)) :: x 585 585 real(kind(1.d0)) :: x
end function derfc 586 586 end function derfc
end interface erfc 587 587 end interface erfc
588 588
!!!!!!!!!!! 589 589 !!!!!!!!!!!
! MISSING ERFCE 590 590 ! MISSING ERFCE
! MISSING CERFI 591 591 ! MISSING CERFI
! MISSING ERFI 592 592 ! MISSING ERFI
! MISSING ERFCI 593 593 ! MISSING ERFCI
!!!!!!!!!!!!!! 594 594 !!!!!!!!!!!!!!
595 595
! Dawson's function 596 596 ! Dawson's function
interface daws 597 597 interface daws
real function daws(x) 598 598 real function daws(x)
real :: x 599 599 real :: x
end function daws 600 600 end function daws
real(kind(1.d0)) function ddaws(x) 601 601 real(kind(1.d0)) function ddaws(x)
real(kind(1.d0)) :: x 602 602 real(kind(1.d0)) :: x
end function ddaws 603 603 end function ddaws
end interface daws 604 604 end interface daws
605 605
!!!!!!!!!!!!!!!!! 606 606 !!!!!!!!!!!!!!!!!
! MISSING FRESC 607 607 ! MISSING FRESC
! MISSING FRESS 608 608 ! MISSING FRESS
!!!!!!!!!!!!!!!!! 609 609 !!!!!!!!!!!!!!!!!
610 610
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 611 611 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! END Error function and related 612 612 ! END Error function and related
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 613 613 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
614 614
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 615 615 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Bessel functions and related 616 616 ! Bessel functions and related
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 617 617 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
618 618
!J0(x) 619 619 !J0(x)
interface bsj0 620 620 interface bsj0
real function besj0(x) 621 621 real function besj0(x)
real :: x 622 622 real :: x
end function besj0 623 623 end function besj0
real(kind(1.d0)) function dbesj0(x) 624 624 real(kind(1.d0)) function dbesj0(x)
real(kind(1.d0)) :: x 625 625 real(kind(1.d0)) :: x
end function dbesj0 626 626 end function dbesj0
end interface bsj0 627 627 end interface bsj0
628 628
!J1(x) 629 629 !J1(x)
interface bsj1 630 630 interface bsj1
real function besj1(x) 631 631 real function besj1(x)
real :: x 632 632 real :: x
end function besj1 633 633 end function besj1
real(kind(1.d0)) function dbesj1(x) 634 634 real(kind(1.d0)) function dbesj1(x)
real(kind(1.d0)) :: x 635 635 real(kind(1.d0)) :: x
end function dbesj1 636 636 end function dbesj1
end interface bsj1 637 637 end interface bsj1
638 638
!Y0(x) 639 639 !Y0(x)
interface bsy0 640 640 interface bsy0
real function besy0(x) 641 641 real function besy0(x)
real :: x 642 642 real :: x
end function besy0 643 643 end function besy0
real(kind(1.d0)) function dbesy0(x) 644 644 real(kind(1.d0)) function dbesy0(x)
real(kind(1.d0)) x 645 645 real(kind(1.d0)) x
end function dbesy0 646 646 end function dbesy0
end interface bsy0 647 647 end interface bsy0
648 648
!Y1(x) 649 649 !Y1(x)
interface bsy1 650 650 interface bsy1
real function besy1(x) 651 651 real function besy1(x)
real :: x 652 652 real :: x
end function besy1 653 653 end function besy1
real(kind(1.d0)) function dbesy1(x) 654 654 real(kind(1.d0)) function dbesy1(x)
real(kind(1.d0)) x 655 655 real(kind(1.d0)) x
end function dbesy1 656 656 end function dbesy1
end interface bsy1 657 657 end interface bsy1
658 658
!I0(x) 659 659 !I0(x)
interface bsi0 660 660 interface bsi0
real function besi0(x) 661 661 real function besi0(x)
real :: x 662 662 real :: x
end function besi0 663 663 end function besi0
real(kind(1.d0)) function dbesi0(x) 664 664 real(kind(1.d0)) function dbesi0(x)
real(kind(1.d0)) x 665 665 real(kind(1.d0)) x
end function dbesi0 666 666 end function dbesi0
end interface bsi0 667 667 end interface bsi0
668 668
!I1(x) 669 669 !I1(x)
interface bsi1 670 670 interface bsi1
real function besi1(x) 671 671 real function besi1(x)
real :: x 672 672 real :: x
end function besi1 673 673 end function besi1
real(kind(1.d0)) function dbesi1(x) 674 674 real(kind(1.d0)) function dbesi1(x)
real(kind(1.d0)) x 675 675 real(kind(1.d0)) x
end function dbesi1 676 676 end function dbesi1
end interface bsi1 677 677 end interface bsi1
678 678
!K0(x) 679 679 !K0(x)
interface bsk0 680 680 interface bsk0
real function besk0(x) 681 681 real function besk0(x)
real :: x 682 682 real :: x
end function besk0 683 683 end function besk0
real(kind(1.d0)) function dbesk0(x) 684 684 real(kind(1.d0)) function dbesk0(x)
real(kind(1.d0)) x 685 685 real(kind(1.d0)) x
end function dbesk0 686 686 end function dbesk0
end interface bsk0 687 687 end interface bsk0
688 688
!K1(x) 689 689 !K1(x)
interface bsk1 690 690 interface bsk1
real function besk1(x) 691 691 real function besk1(x)
real :: x 692 692 real :: x
end function besk1 693 693 end function besk1
real(kind(1.d0)) function dbesk1(x) 694 694 real(kind(1.d0)) function dbesk1(x)
real(kind(1.d0)) x 695 695 real(kind(1.d0)) x
end function dbesk1 696 696 end function dbesk1
end interface bsk1 697 697 end interface bsk1
698 698
! Exponentially scaled I0 699 699 ! Exponentially scaled I0
interface bsi0e 700 700 interface bsi0e
real function besi0e(x) 701 701 real function besi0e(x)
real :: x 702 702 real :: x
end function besi0e 703 703 end function besi0e
real(kind(1.d0)) function dbsi0e(x) 704 704 real(kind(1.d0)) function dbsi0e(x)
real(kind(1.d0)) :: x 705 705 real(kind(1.d0)) :: x
end function dbsi0e 706 706 end function dbsi0e
end interface bsi0e 707 707 end interface bsi0e
708 708
! Exponentially scaled I1 709 709 ! Exponentially scaled I1
interface bsi1e 710 710 interface bsi1e
real function besi1e(x) 711 711 real function besi1e(x)
real :: x 712 712 real :: x
end function besi1e 713 713 end function besi1e
real(kind(1.d0)) function dbsi1e(x) 714 714 real(kind(1.d0)) function dbsi1e(x)
real(kind(1.d0)) :: x 715 715 real(kind(1.d0)) :: x
end function dbsi1e 716 716 end function dbsi1e
end interface bsi1e 717 717 end interface bsi1e
718 718
! Exponentially scaled K0 719 719 ! Exponentially scaled K0
interface bsk0e 720 720 interface bsk0e
real function besk0e(x) 721 721 real function besk0e(x)
real :: x 722 722 real :: x
end function besk0e 723 723 end function besk0e
real(kind(1.d0)) function dbsk0e(x) 724 724 real(kind(1.d0)) function dbsk0e(x)
real(kind(1.d0)) :: x 725 725 real(kind(1.d0)) :: x
end function dbsk0e 726 726 end function dbsk0e
end interface bsk0e 727 727 end interface bsk0e
728 728
! Exponentially scaled K1 729 729 ! Exponentially scaled K1
interface bsk1e 730 730 interface bsk1e
real function besk1e(x) 731 731 real function besk1e(x)
real :: x 732 732 real :: x
end function besk1e 733 733 end function besk1e
real(kind(1.d0)) function dbsk1e(x) 734 734 real(kind(1.d0)) function dbsk1e(x)
real(kind(1.d0)) :: x 735 735 real(kind(1.d0)) :: x
end function dbsk1e 736 736 end function dbsk1e
end interface bsk1e 737 737 end interface bsk1e
738 738
! nth order J 739 739 ! nth order J
interface bsjn 740 740 interface bsjn
real function besjn(n,x,factor,big) 741 741 real function besjn(n,x,factor,big)
integer :: n 742 742 integer :: n
real :: x 743 743 real :: x
integer, optional :: factor 744 744 integer, optional :: factor
real, optional :: big 745 745 real, optional :: big
end function besjn 746 746 end function besjn
real(kind(1.d0)) function dbesjn(n,x,factor,big) 747 747 real(kind(1.d0)) function dbesjn(n,x,factor,big)
integer :: n 748 748 integer :: n
real(kind(1.d0)) :: x 749 749 real(kind(1.d0)) :: x
integer, optional :: factor 750 750 integer, optional :: factor
real(kind(1.d0)), optional :: big 751 751 real(kind(1.d0)), optional :: big
end function dbesjn 752 752 end function dbesjn
end interface bsjn 753 753 end interface bsjn
754 754
! nth order Y 755 755 ! nth order Y
interface bsyn 756 756 interface bsyn
real function besyn(n,x) 757 757 real function besyn(n,x)
integer :: n 758 758 integer :: n
real :: x 759 759 real :: x
end function besyn 760 760 end function besyn
real(kind(1.d0)) function dbesyn(n,x) 761 761 real(kind(1.d0)) function dbesyn(n,x)
integer :: n 762 762 integer :: n
real(kind(1.d0)) :: x 763 763 real(kind(1.d0)) :: x
end function dbesyn 764 764 end function dbesyn
end interface bsyn 765 765 end interface bsyn
766 766
! nth order I 767 767 ! nth order I
interface bsin 768 768 interface bsin
real function besin(n,x,factor,big) 769 769 real function besin(n,x,factor,big)
integer :: n 770 770 integer :: n
real :: x 771 771 real :: x
integer, optional :: factor 772 772 integer, optional :: factor
real, optional :: big 773 773 real, optional :: big
end function besin 774 774 end function besin
real(kind(1.d0)) function dbesin(n,x,factor,big) 775 775 real(kind(1.d0)) function dbesin(n,x,factor,big)
integer :: n 776 776 integer :: n
real(kind(1.d0)) :: x 777 777 real(kind(1.d0)) :: x
integer, optional :: factor 778 778 integer, optional :: factor
real(kind(1.d0)), optional :: big 779 779 real(kind(1.d0)), optional :: big
end function dbesin 780 780 end function dbesin
end interface bsin 781 781 end interface bsin
782 782
! nth order K 783 783 ! nth order K
interface bskn 784 784 interface bskn
real function beskn(n,x) 785 785 real function beskn(n,x)
integer :: n 786 786 integer :: n
real :: x 787 787 real :: x
end function beskn 788 788 end function beskn
real(kind(1.d0)) function dbeskn(n,x) 789 789 real(kind(1.d0)) function dbeskn(n,x)
integer :: n 790 790 integer :: n
real(kind(1.d0)) :: x 791 791 real(kind(1.d0)) :: x
end function dbeskn 792 792 end function dbeskn
end interface bskn 793 793 end interface bskn
794 794
!!!!!!!!!!!!!!!!!!!!! 795 795 !!!!!!!!!!!!!!!!!!!!!
! MISSING BSJNS, replaced by dbesrj (ChW 11/2009) 796 796 ! MISSING BSJNS, replaced by dbesrj (ChW 11/2009)
! MISSING BSINS, replaced by dbesri (ChW 11/2009) 797 797 ! MISSING BSINS, replaced by dbesri (ChW 11/2009)
! MISSING BSJS 798 798 ! MISSING BSJS
! MISSING BSYS 799 799 ! MISSING BSYS
! MISSING BSIS 800 800 ! MISSING BSIS
! MISSING BSIES 801 801 ! MISSING BSIES
!!!!!!!!!!!!!!!!!!!!! 802 802 !!!!!!!!!!!!!!!!!!!!!
! vector b of Bessel J values of x from order 0 to order (n-1) 803 803 ! vector b of Bessel J values of x from order 0 to order (n-1)
interface dbesrj 804 804 interface besrj
subroutine dbesrj(x,n,b) 805 805 subroutine dbesrj(x,n,b)
real(kind(1.d0)) :: x 806 806 real(kind(1.d0)) :: x
integer :: n 807 807 integer :: n
real(kind(1.d0)) :: b(n) 808 808 real(kind(1.d0)) :: b(n)
end subroutine dbesrj 809 809 end subroutine dbesrj
end interface dbesrj 810 810 end interface besrj
811 811
! vector b of Bessel I values of x from order 0 to order (n-1) 812 812 ! vector b of Bessel I values of x from order 0 to order (n-1)
interface dbesri 813 813 interface besri
subroutine dbesri(x,n,b) 814 814 subroutine dbesri(x,n,b)
real(kind(1.d0)) :: x 815 815 real(kind(1.d0)) :: x
integer :: n 816 816 integer :: n
real(kind(1.d0)) :: b(n) 817 817 real(kind(1.d0)) :: b(n)
end subroutine dbesri 818 818 end subroutine dbesri
end interface dbesri 819 819 end interface besri
820 820
! K nu + k 821 821 ! K nu + k
interface bsks 822 822 interface bsks
subroutine besks(xnu,x,nin,bk) 823 823 subroutine besks(xnu,x,nin,bk)
real :: xnu,x 824 824 real :: xnu,x
integer :: nin 825 825 integer :: nin
real, dimension(nin) :: bk 826 826 real, dimension(nin) :: bk
end subroutine besks 827 827 end subroutine besks
subroutine dbesks(xnu,x,nin,bk) 828 828 subroutine dbesks(xnu,x,nin,bk)
real(kind(1.d0)) :: xnu,x 829 829 real(kind(1.d0)) :: xnu,x
integer :: nin 830 830 integer :: nin
real(kind(1.d0)), dimension(nin) :: bk 831 831 real(kind(1.d0)), dimension(nin) :: bk
end subroutine dbesks 832 832 end subroutine dbesks
end interface bsks 833 833 end interface bsks
834 834
! Exponentially scaled K nu + k 835 835 ! Exponentially scaled K nu + k
interface bskes 836 836 interface bskes
subroutine beskes(xnu,x,nin,bke) 837 837 subroutine beskes(xnu,x,nin,bke)
real :: xnu,x 838 838 real :: xnu,x
integer :: nin 839 839 integer :: nin
real,dimension(nin) :: bke 840 840 real,dimension(nin) :: bke
end subroutine beskes 841 841 end subroutine beskes
subroutine dbskes(xnu,x,nin,bke) 842 842 subroutine dbskes(xnu,x,nin,bke)
real(kind(1.d0)) :: xnu,x 843 843 real(kind(1.d0)) :: xnu,x
integer :: nin 844 844 integer :: nin
real(kind(1.d0)),dimension(nin) :: bke 845 845 real(kind(1.d0)),dimension(nin) :: bke
end subroutine dbskes 846 846 end subroutine dbskes
end interface bskes 847 847 end interface bskes
848 848
!!!!!!!!!!!!!!!!!! 849 849 !!!!!!!!!!!!!!!!!!
! MISSING CBJS 850 850 ! MISSING CBJS
! MISSING CBYS 851 851 ! MISSING CBYS
! MISSING CBIS 852 852 ! MISSING CBIS
!!!!!!!!!!!!!!!!!! 853 853 !!!!!!!!!!!!!!!!!!
854 854
855 855
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 856 856 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! END Bessel functions and related 857 857 ! END Bessel functions and related
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 858 858 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
859 859
860 860
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 861 861 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Airy functions and related 862 862 ! Airy functions and related
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 863 863 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
864 864
!ai(x) 865 865 !ai(x)
interface ai 866 866 interface ai
real function ai(x) 867 867 real function ai(x)
real :: x 868 868 real :: x
end function ai 869 869 end function ai
real(kind(1.d0)) function dai(x) 870 870 real(kind(1.d0)) function dai(x)
real(kind(1.d0)) :: x 871 871 real(kind(1.d0)) :: x
end function dai 872 872 end function dai
end interface ai 873 873 end interface ai
874 874
!bi(x) 875 875 !bi(x)
interface bi 876 876 interface bi
real function bi(x) 877 877 real function bi(x)
real :: x 878 878 real :: x
end function bi 879 879 end function bi
real(kind(1.d0)) function dbi(x) 880 880 real(kind(1.d0)) function dbi(x)
real(kind(1.d0)) :: x 881 881 real(kind(1.d0)) :: x
end function dbi 882 882 end function dbi
end interface bi 883 883 end interface bi
884 884
!ai'(x) 885 885 !ai'(x)
interface aid 886 886 interface aid
real function aid(x) 887 887 real function aid(x)
real :: x 888 888 real :: x
end function aid 889 889 end function aid
real(kind(1.d0)) function daid(x) 890 890 real(kind(1.d0)) function daid(x)
real(kind(1.d0)) :: x 891 891 real(kind(1.d0)) :: x
end function daid 892 892 end function daid
end interface aid 893 893 end interface aid
894 894
!bi'(x) 895 895 !bi'(x)
interface bid 896 896 interface bid
real function bid(x) 897 897 real function bid(x)
real :: x 898 898 real :: x
function ze1(z) 1 1 function ze1(z)
! 2 2 !
! ==================================================== 3 3 ! ====================================================
! Purpose: Compute complex exponential integral E1(z) 4 4 ! Purpose: Compute complex exponential integral E1(z)
! Input : z --- Argument of E1(z) 5 5 ! Input : z --- Argument of E1(z)
! Output: CE1 --- E1(z) 6 6 ! Output: CE1 --- E1(z)
! ==================================================== 7 7 ! ====================================================
! 8 8 !
! Dรฉclaration des variables en passage de paramรจtre 9 9 ! Dรฉclaration des variables en passage de paramรจtre
! 10 10 !
use kind_definition 11 11 use fvn_common
implicit none 12 12 implicit none
complex(kind=dp_kind), intent(in) :: z 13 13 complex(kind=dp_kind), intent(in) :: z
complex(kind=dp_kind) :: ze1 14 14 complex(kind=dp_kind) :: ze1
! 15 15 !
! Dรฉclaration des variables locales 16 16 ! Dรฉclaration des variables locales
! 17 17 !
integer(kind=ip_kind) :: k 18 18 integer(kind=ip_kind) :: k
real(kind=dp_kind) :: pi,el,x,a0 19 19 real(kind=dp_kind) :: x,a0
complex(kind=dp_kind) :: cr,ct0,ct 20 20 complex(kind=dp_kind) :: cr,ct0,ct
parameter(pi=3.141592653589793D0,el=0.5772156649015328D0) 21 21
! 22 22 !
! traitement en fonction des diffรฉrents cas 23 23 ! traitement en fonction des diffรฉrents cas
! - Z nul entraรฎne E1 infini 24 24 ! - Z nul entraรฎne E1 infini
! - module de Z infรฉrieur ร  10 ou 20 : formule log+gam+somme 25 25 ! - module de Z infรฉrieur ร  10 ou 20 : formule log+gam+somme
! - module de Z supรฉrieur ร  10 ou 20 : formule asymptotique 26 26 ! - module de Z supรฉrieur ร  10 ou 20 : formule asymptotique
! 27 27 !
x=real(z) 28 28 x=real(z)
a0=abs(z) 29 29 a0=abs(z)
if (a0==0.0D0) then 30 30 if (a0==0.0D0) then
ze1 = cmplx(1.0D+300,0.0D0,dp_kind) 31 31 ze1 = cmplx(1.0D+300,0.0D0,dp_kind)
else if ((a0 <= 10.D0).or.(x <= 0.D0.and.a0 <= 20.D0)) then 32 32 else if ((a0 <= 10.D0).or.(x <= 0.D0.and.a0 <= 20.D0)) then
ze1 = cmplx(1.0D0,0.0D0,dp_kind) 33 33 ze1 = cmplx(1.0D0,0.0D0,dp_kind)
cr = cmplx(1.0D0,0.0D0,dp_kind) 34 34 cr = cmplx(1.0D0,0.0D0,dp_kind)
k=0 35 35 k=0
do while (abs(cr)>=abs(ze1)*1.0D-15) 36 36 do while (abs(cr)>=abs(ze1)*1.0D-15)
k = k+1 37 37 k = k+1
cr = -cr*k*z/(k+1.0D0)**2 38 38 cr = -cr*k*z/(k+1.0D0)**2
ze1 = ze1+cr 39 39 ze1 = ze1+cr
end do 40 40 end do
ze1 = -el-log(z)+z*ze1 41 41 ze1 = -fvn_el-log(z)+z*ze1
else 42 42 else
ct0 = cmplx(0.0D0,0.0D0,dp_kind) 43 43 ct0 = cmplx(0.0D0,0.0D0,dp_kind)
do k=120,1,-1 44 44 do k=120,1,-1
ct0 = k/(1.0D0+k/(z+ct0)) 45 45 ct0 = k/(1.0D0+k/(z+ct0))
end do 46 46 end do
ct = 1.0D0/(z+ct0) 47 47 ct = 1.0D0/(z+ct0)
ze1 = exp(-z)*ct 48 48 ze1 = exp(-z)*ct
if (x <= 0.D0 .AND. aimag(z) == 0.0d0) ze1 = ze1-pi*cmplx(0.D0,1.D0,dp_kind) 49 49 if (x <= 0.D0 .AND. aimag(z) == 0.0d0) ze1 = ze1-fvn_pi*cmplx(0.D0,1.D0,dp_kind)
end if 50 50 end if
! 51 51 !
return 52 52 return
end function 53 53 end function
54 54
fvn_interpol/fvn_interpol.f90
Diff comments   View file @ 8d883e8
module fvn_interpol 1 1 module fvn_interpol
use kind_definition 2
use fvn_common 3 2 use fvn_common
implicit none 4 3 implicit none
5 4
6 5
! Utility procedure find interval 7 6 ! Utility procedure find interval
interface fvn_find_interval 8 7 interface fvn_find_interval
module procedure fvn_s_find_interval,fvn_d_find_interval 9 8 module procedure fvn_s_find_interval,fvn_d_find_interval
end interface fvn_find_interval 10 9 end interface fvn_find_interval
11 10
! Quadratic 1D interpolation 12 11 ! Quadratic 1D interpolation
interface fvn_quad_interpol 13 12 interface fvn_quad_interpol
module procedure fvn_s_quad_interpol,fvn_d_quad_interpol 14 13 module procedure fvn_s_quad_interpol,fvn_d_quad_interpol
end interface fvn_quad_interpol 15 14 end interface fvn_quad_interpol
16 15
! Quadratic 2D interpolation 17 16 ! Quadratic 2D interpolation
interface fvn_quad_2d_interpol 18 17 interface fvn_quad_2d_interpol
module procedure fvn_s_quad_2d_interpol,fvn_d_quad_2d_interpol 19 18 module procedure fvn_s_quad_2d_interpol,fvn_d_quad_2d_interpol
end interface fvn_quad_2d_interpol 20 19 end interface fvn_quad_2d_interpol
21 20
! Quadratic 3D interpolation 22 21 ! Quadratic 3D interpolation
interface fvn_quad_3d_interpol 23 22 interface fvn_quad_3d_interpol
module procedure fvn_s_quad_3d_interpol,fvn_d_quad_3d_interpol 24 23 module procedure fvn_s_quad_3d_interpol,fvn_d_quad_3d_interpol
end interface fvn_quad_3d_interpol 25 24 end interface fvn_quad_3d_interpol
26 25
! Akima interpolation 27 26 ! Akima interpolation
interface fvn_akima 28 27 interface fvn_akima
module procedure fvn_s_akima,fvn_d_akima 29 28 module procedure fvn_s_akima,fvn_d_akima
end interface fvn_akima 30 29 end interface fvn_akima
31 30
! Akima evaluation 32 31 ! Akima evaluation
interface fvn_spline_eval 33 32 interface fvn_spline_eval
module procedure fvn_s_spline_eval,fvn_d_spline_eval 34 33 module procedure fvn_s_spline_eval,fvn_d_spline_eval
end interface fvn_spline_eval 35 34 end interface fvn_spline_eval
36 35
contains 37 36 contains
38 37
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 39 38 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 40 39 !
! Quadratic interpolation of tabulated function of 1,2 or 3 variables 41 40 ! Quadratic interpolation of tabulated function of 1,2 or 3 variables
! 42 41 !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 43 42 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
44 43
subroutine fvn_s_find_interval(x,i,xdata,n) 45 44 subroutine fvn_s_find_interval(x,i,xdata,n)
implicit none 46 45 implicit none
! This routine find the indice i where xdata(i) <= x < xdata(i+1) 47 46 ! This routine find the indice i where xdata(i) <= x < xdata(i+1)
! xdata(n) must contains a set of increasingly ordered values 48 47 ! xdata(n) must contains a set of increasingly ordered values
! if x < xdata(1) i=0 is returned 49 48 ! if x < xdata(1) i=0 is returned
! if x > xdata(n) i=n is returned 50 49 ! if x > xdata(n) i=n is returned
! special case is where x=xdata(n) then n-1 is returned so 51 50 ! special case is where x=xdata(n) then n-1 is returned so
! we will not exclude the upper limit 52 51 ! we will not exclude the upper limit
! a simple dichotomy method is used 53 52 ! a simple dichotomy method is used
54 53
real(kind=sp_kind), intent(in) :: x 55 54 real(kind=sp_kind), intent(in) :: x
integer(kind=sp_kind), intent(in) :: n 56 55 integer(kind=sp_kind), intent(in) :: n
real(kind=sp_kind), intent(in), dimension(n) :: xdata 57 56 real(kind=sp_kind), intent(in), dimension(n) :: xdata
integer(kind=sp_kind), intent(out) :: i 58 57 integer(kind=sp_kind), intent(out) :: i
59 58
integer(kind=sp_kind) :: imin,imax,imoyen 60 59 integer(kind=sp_kind) :: imin,imax,imoyen
61 60
! special case is where x=xdata(n) then n-1 is returned so 62 61 ! special case is where x=xdata(n) then n-1 is returned so
! we will not exclude the upper limit 63 62 ! we will not exclude the upper limit
if (x == xdata(n)) then 64 63 if (x == xdata(n)) then
i=n-1 65 64 i=n-1
return 66 65 return
end if 67 66 end if
68 67
! if x < xdata(1) i=0 is returned 69 68 ! if x < xdata(1) i=0 is returned
if (x < xdata(1)) then 70 69 if (x < xdata(1)) then
i=0 71 70 i=0
return 72 71 return
end if 73 72 end if
74 73
! if x > xdata(n) i=n is returned 75 74 ! if x > xdata(n) i=n is returned
if (x > xdata(n)) then 76 75 if (x > xdata(n)) then
i=n 77 76 i=n
return 78 77 return
end if 79 78 end if
80 79
! here xdata(1) <= x <= xdata(n) 81 80 ! here xdata(1) <= x <= xdata(n)
imin=0 82 81 imin=0
imax=n+1 83 82 imax=n+1
84 83
do while((imax-imin) > 1) 85 84 do while((imax-imin) > 1)
imoyen=(imax+imin)/2 86 85 imoyen=(imax+imin)/2
if (x >= xdata(imoyen)) then 87 86 if (x >= xdata(imoyen)) then
imin=imoyen 88 87 imin=imoyen
else 89 88 else
imax=imoyen 90 89 imax=imoyen
end if 91 90 end if
end do 92 91 end do
93 92
i=imin 94 93 i=imin
95 94
end subroutine 96 95 end subroutine
97 96
98 97
subroutine fvn_d_find_interval(x,i,xdata,n) 99 98 subroutine fvn_d_find_interval(x,i,xdata,n)
implicit none 100 99 implicit none
! This routine find the indice i where xdata(i) <= x < xdata(i+1) 101 100 ! This routine find the indice i where xdata(i) <= x < xdata(i+1)
! xdata(n) must contains a set of increasingly ordered values 102 101 ! xdata(n) must contains a set of increasingly ordered values
! if x < xdata(1) i=0 is returned 103 102 ! if x < xdata(1) i=0 is returned
! if x > xdata(n) i=n is returned 104 103 ! if x > xdata(n) i=n is returned
! special case is where x=xdata(n) then n-1 is returned so 105 104 ! special case is where x=xdata(n) then n-1 is returned so
! we will not exclude the upper limit 106 105 ! we will not exclude the upper limit
! a simple dichotomy method is used 107 106 ! a simple dichotomy method is used
108 107
real(kind=dp_kind), intent(in) :: x 109 108 real(kind=dp_kind), intent(in) :: x
integer(kind=sp_kind), intent(in) :: n 110 109 integer(kind=sp_kind), intent(in) :: n
real(kind=dp_kind), intent(in), dimension(n) :: xdata 111 110 real(kind=dp_kind), intent(in), dimension(n) :: xdata
integer(kind=sp_kind), intent(out) :: i 112 111 integer(kind=sp_kind), intent(out) :: i
113 112
integer(kind=sp_kind) :: imin,imax,imoyen 114 113 integer(kind=sp_kind) :: imin,imax,imoyen
115 114
! special case is where x=xdata(n) then n-1 is returned so 116 115 ! special case is where x=xdata(n) then n-1 is returned so
! we will not exclude the upper limit 117 116 ! we will not exclude the upper limit
if (x == xdata(n)) then 118 117 if (x == xdata(n)) then
i=n-1 119 118 i=n-1
return 120 119 return
end if 121 120 end if
122 121
! if x < xdata(1) i=0 is returned 123 122 ! if x < xdata(1) i=0 is returned
if (x < xdata(1)) then 124 123 if (x < xdata(1)) then
i=0 125 124 i=0
return 126 125 return
end if 127 126 end if
128 127
! if x > xdata(n) i=n is returned 129 128 ! if x > xdata(n) i=n is returned
if (x > xdata(n)) then 130 129 if (x > xdata(n)) then
i=n 131 130 i=n
return 132 131 return
end if 133 132 end if
134 133
! here xdata(1) <= x <= xdata(n) 135 134 ! here xdata(1) <= x <= xdata(n)
imin=0 136 135 imin=0
imax=n+1 137 136 imax=n+1
138 137
do while((imax-imin) > 1) 139 138 do while((imax-imin) > 1)
imoyen=(imax+imin)/2 140 139 imoyen=(imax+imin)/2
if (x >= xdata(imoyen)) then 141 140 if (x >= xdata(imoyen)) then
imin=imoyen 142 141 imin=imoyen
else 143 142 else
imax=imoyen 144 143 imax=imoyen
end if 145 144 end if
end do 146 145 end do
147 146
i=imin 148 147 i=imin
149 148
end subroutine 150 149 end subroutine
151 150
152 151
function fvn_s_quad_interpol(x,n,xdata,ydata) 153 152 function fvn_s_quad_interpol(x,n,xdata,ydata)
implicit none 154 153 implicit none
! This function evaluate the value of a function defined by a set of points 155 154 ! This function evaluate the value of a function defined by a set of points
! and values, using a quadratic interpolation 156 155 ! and values, using a quadratic interpolation
! xdata must be increasingly ordered 157 156 ! xdata must be increasingly ordered
! x must be within xdata(1) and xdata(n) to actually do interpolation 158 157 ! x must be within xdata(1) and xdata(n) to actually do interpolation
! otherwise extrapolation is done 159 158 ! otherwise extrapolation is done
integer(kind=sp_kind), intent(in) :: n 160 159 integer(kind=sp_kind), intent(in) :: n
real(kind=sp_kind), intent(in), dimension(n) :: xdata,ydata 161 160 real(kind=sp_kind), intent(in), dimension(n) :: xdata,ydata
real(kind=sp_kind), intent(in) :: x 162 161 real(kind=sp_kind), intent(in) :: x
real(kind=sp_kind) :: fvn_s_quad_interpol 163 162 real(kind=sp_kind) :: fvn_s_quad_interpol
164 163
integer(kind=sp_kind) :: iinf,base,i,j 165 164 integer(kind=sp_kind) :: iinf,base,i,j
real(kind=sp_kind) :: p 166 165 real(kind=sp_kind) :: p
167 166
call fvn_s_find_interval(x,iinf,xdata,n) 168 167 call fvn_s_find_interval(x,iinf,xdata,n)
169 168
! Settings for extrapolation 170 169 ! Settings for extrapolation
if (iinf==0) then 171 170 if (iinf==0) then
! TODO -> Lower bound extrapolation warning 172 171 ! TODO -> Lower bound extrapolation warning
iinf=1 173 172 iinf=1
end if 174 173 end if
175 174
if (iinf==n) then 176 175 if (iinf==n) then
! TODO -> Higher bound extrapolation warning 177 176 ! TODO -> Higher bound extrapolation warning
iinf=n-1 178 177 iinf=n-1
end if 179 178 end if
180 179
! The three points we will use are iinf-1,iinf and iinf+1 with the 181 180 ! 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 182 181 ! exception of the first interval, where iinf=1 we will use 1,2 and 3
if (iinf==1) then 183 182 if (iinf==1) then
base=0 184 183 base=0
else 185 184 else
base=iinf-2 186 185 base=iinf-2
end if 187 186 end if
188 187
! The three points we will use are : 189 188 ! The three points we will use are :
! xdata/ydata(base+1),xdata/ydata(base+2),xdata/ydata(base+3) 190 189 ! xdata/ydata(base+1),xdata/ydata(base+2),xdata/ydata(base+3)
191 190
! Straight forward Lagrange polynomial 192 191 ! Straight forward Lagrange polynomial
fvn_s_quad_interpol=0. 193 192 fvn_s_quad_interpol=0.
do i=1,3 194 193 do i=1,3
! polynome i 195 194 ! polynome i
p=ydata(base+i) 196 195 p=ydata(base+i)
do j=1,3 197 196 do j=1,3
if (j /= i) then 198 197 if (j /= i) then
p=p*(x-xdata(base+j))/(xdata(base+i)-xdata(base+j)) 199 198 p=p*(x-xdata(base+j))/(xdata(base+i)-xdata(base+j))
end if 200 199 end if
end do 201 200 end do
fvn_s_quad_interpol=fvn_s_quad_interpol+p 202 201 fvn_s_quad_interpol=fvn_s_quad_interpol+p
end do 203 202 end do
204 203
end function 205 204 end function
206 205
207 206
function fvn_d_quad_interpol(x,n,xdata,ydata) 208 207 function fvn_d_quad_interpol(x,n,xdata,ydata)
implicit none 209 208 implicit none
! This function evaluate the value of a function defined by a set of points 210 209 ! This function evaluate the value of a function defined by a set of points
! and values, using a quadratic interpolation 211 210 ! and values, using a quadratic interpolation
! xdata must be increasingly ordered 212 211 ! xdata must be increasingly ordered
! x must be within xdata(1) and xdata(n) to actually do interpolation 213 212 ! x must be within xdata(1) and xdata(n) to actually do interpolation
! otherwise extrapolation is done 214 213 ! otherwise extrapolation is done
integer(kind=sp_kind), intent(in) :: n 215 214 integer(kind=sp_kind), intent(in) :: n
real(kind=dp_kind), intent(in), dimension(n) :: xdata,ydata 216 215 real(kind=dp_kind), intent(in), dimension(n) :: xdata,ydata
real(kind=dp_kind), intent(in) :: x 217 216 real(kind=dp_kind), intent(in) :: x
real(kind=dp_kind) :: fvn_d_quad_interpol 218 217 real(kind=dp_kind) :: fvn_d_quad_interpol
219 218
integer(kind=sp_kind) :: iinf,base,i,j 220 219 integer(kind=sp_kind) :: iinf,base,i,j
real(kind=dp_kind) :: p 221 220 real(kind=dp_kind) :: p
222 221
call fvn_d_find_interval(x,iinf,xdata,n) 223 222 call fvn_d_find_interval(x,iinf,xdata,n)
224 223
! Settings for extrapolation 225 224 ! Settings for extrapolation
if (iinf==0) then 226 225 if (iinf==0) then
! TODO -> Lower bound extrapolation warning 227 226 ! TODO -> Lower bound extrapolation warning
iinf=1 228 227 iinf=1
end if 229 228 end if
230 229
if (iinf==n) then 231 230 if (iinf==n) then
! TODO Higher bound extrapolation warning 232 231 ! TODO Higher bound extrapolation warning
iinf=n-1 233 232 iinf=n-1
end if 234 233 end if
235 234
! The three points we will use are iinf-1,iinf and iinf+1 with the 236 235 ! 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 237 236 ! exception of the first interval, where iinf=1 we will use 1,2 and 3
if (iinf==1) then 238 237 if (iinf==1) then
base=0 239 238 base=0
else 240 239 else
base=iinf-2 241 240 base=iinf-2
end if 242 241 end if
243 242
! The three points we will use are : 244 243 ! The three points we will use are :
! xdata/ydata(base+1),xdata/ydata(base+2),xdata/ydata(base+3) 245 244 ! xdata/ydata(base+1),xdata/ydata(base+2),xdata/ydata(base+3)
246 245
! Straight forward Lagrange polynomial 247 246 ! Straight forward Lagrange polynomial
fvn_d_quad_interpol=0. 248 247 fvn_d_quad_interpol=0.
do i=1,3 249 248 do i=1,3
! polynome i 250 249 ! polynome i
p=ydata(base+i) 251 250 p=ydata(base+i)
do j=1,3 252 251 do j=1,3
if (j /= i) then 253 252 if (j /= i) then
p=p*(x-xdata(base+j))/(xdata(base+i)-xdata(base+j)) 254 253 p=p*(x-xdata(base+j))/(xdata(base+i)-xdata(base+j))
end if 255 254 end if
end do 256 255 end do
fvn_d_quad_interpol=fvn_d_quad_interpol+p 257 256 fvn_d_quad_interpol=fvn_d_quad_interpol+p
end do 258 257 end do
259 258
end function 260 259 end function
261 260
262 261
function fvn_s_quad_2d_interpol(x,y,nx,xdata,ny,ydata,zdata) 263 262 function fvn_s_quad_2d_interpol(x,y,nx,xdata,ny,ydata,zdata)
implicit none 264 263 implicit none
! This function evaluate the value of a two variable function defined by a 265 264 ! This function evaluate the value of a two variable function defined by a
! set of points and values, using a quadratic interpolation 266 265 ! set of points and values, using a quadratic interpolation
! xdata and ydata must be increasingly ordered 267 266 ! xdata and ydata must be increasingly ordered
! the couple (x,y) must be as x within xdata(1) and xdata(nx) and 268 267 ! 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 269 268 ! y within ydata(1) and ydata(ny) to actually do interpolation
! otherwise extrapolation is done 270 269 ! otherwise extrapolation is done
integer(kind=sp_kind), intent(in) :: nx,ny 271 270 integer(kind=sp_kind), intent(in) :: nx,ny
real(kind=sp_kind), intent(in) :: x,y 272 271 real(kind=sp_kind), intent(in) :: x,y
real(kind=sp_kind), intent(in), dimension(nx) :: xdata 273 272 real(kind=sp_kind), intent(in), dimension(nx) :: xdata
real(kind=sp_kind), intent(in), dimension(ny) :: ydata 274 273 real(kind=sp_kind), intent(in), dimension(ny) :: ydata
real(kind=sp_kind), intent(in), dimension(nx,ny) :: zdata 275 274 real(kind=sp_kind), intent(in), dimension(nx,ny) :: zdata
real(kind=sp_kind) :: fvn_s_quad_2d_interpol 276 275 real(kind=sp_kind) :: fvn_s_quad_2d_interpol
277 276
integer(kind=sp_kind) :: ixinf,iyinf,basex,basey,i 278 277 integer(kind=sp_kind) :: ixinf,iyinf,basex,basey,i
real(kind=sp_kind),dimension(3) :: ztmp 279 278 real(kind=sp_kind),dimension(3) :: ztmp
!real(kind=4), external :: fvn_s_quad_interpol 280 279 !real(kind=4), external :: fvn_s_quad_interpol
281 280
call fvn_s_find_interval(x,ixinf,xdata,nx) 282 281 call fvn_s_find_interval(x,ixinf,xdata,nx)
call fvn_s_find_interval(y,iyinf,ydata,ny) 283 282 call fvn_s_find_interval(y,iyinf,ydata,ny)
284 283
! Settings for extrapolation 285 284 ! Settings for extrapolation
if (ixinf==0) then 286 285 if (ixinf==0) then
! TODO -> Lower x bound extrapolation warning 287 286 ! TODO -> Lower x bound extrapolation warning
ixinf=1 288 287 ixinf=1
end if 289 288 end if
290 289
if (ixinf==nx) then 291 290 if (ixinf==nx) then
! TODO -> Higher x bound extrapolation warning 292 291 ! TODO -> Higher x bound extrapolation warning
ixinf=nx-1 293 292 ixinf=nx-1
end if 294 293 end if
295 294
if (iyinf==0) then 296 295 if (iyinf==0) then
! TODO -> Lower y bound extrapolation warning 297 296 ! TODO -> Lower y bound extrapolation warning
iyinf=1 298 297 iyinf=1
end if 299 298 end if
300 299
if (iyinf==ny) then 301 300 if (iyinf==ny) then
! TODO -> Higher y bound extrapolation warning 302 301 ! TODO -> Higher y bound extrapolation warning
iyinf=ny-1 303 302 iyinf=ny-1
end if 304 303 end if
305 304
! The three points we will use are iinf-1,iinf and iinf+1 with the 306 305 ! 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 307 306 ! exception of the first interval, where iinf=1 we will use 1,2 and 3
if (ixinf==1) then 308 307 if (ixinf==1) then
basex=0 309 308 basex=0
else 310 309 else
basex=ixinf-2 311 310 basex=ixinf-2
end if 312 311 end if
313 312
if (iyinf==1) then 314 313 if (iyinf==1) then
basey=0 315 314 basey=0
else 316 315 else
basey=iyinf-2 317 316 basey=iyinf-2
end if 318 317 end if
319 318
! First we make 3 interpolations for x at y(base+1),y(base+2),y(base+3) 320 319 ! First we make 3 interpolations for x at y(base+1),y(base+2),y(base+3)
! stored in ztmp(1:3) 321 320 ! stored in ztmp(1:3)
do i=1,3 322 321 do i=1,3
ztmp(i)=fvn_s_quad_interpol(x,nx,xdata,zdata(:,basey+i)) 323 322 ztmp(i)=fvn_s_quad_interpol(x,nx,xdata,zdata(:,basey+i))
end do 324 323 end do
325 324
! Then we make an interpolation for y using previous interpolations 326 325 ! 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) 327 326 fvn_s_quad_2d_interpol=fvn_s_quad_interpol(y,3,ydata(basey+1:basey+3),ztmp)
end function 328 327 end function
329 328
330 329
function fvn_d_quad_2d_interpol(x,y,nx,xdata,ny,ydata,zdata) 331 330 function fvn_d_quad_2d_interpol(x,y,nx,xdata,ny,ydata,zdata)
implicit none 332 331 implicit none
! This function evaluate the value of a two variable function defined by a 333 332 ! This function evaluate the value of a two variable function defined by a
! set of points and values, using a quadratic interpolation 334 333 ! set of points and values, using a quadratic interpolation
! xdata and ydata must be increasingly ordered 335 334 ! xdata and ydata must be increasingly ordered
! the couple (x,y) must be as x within xdata(1) and xdata(nx) and 336 335 ! 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 337 336 ! y within ydata(1) and ydata(ny) to actually do interpolation
! otherwise extrapolation is done 338 337 ! otherwise extrapolation is done
integer(kind=sp_kind), intent(in) :: nx,ny 339 338 integer(kind=sp_kind), intent(in) :: nx,ny
real(kind=dp_kind), intent(in) :: x,y 340 339 real(kind=dp_kind), intent(in) :: x,y
real(kind=dp_kind), intent(in), dimension(nx) :: xdata 341 340 real(kind=dp_kind), intent(in), dimension(nx) :: xdata
real(kind=dp_kind), intent(in), dimension(ny) :: ydata 342 341 real(kind=dp_kind), intent(in), dimension(ny) :: ydata
real(kind=dp_kind), intent(in), dimension(nx,ny) :: zdata 343 342 real(kind=dp_kind), intent(in), dimension(nx,ny) :: zdata
real(kind=dp_kind) :: fvn_d_quad_2d_interpol 344 343 real(kind=dp_kind) :: fvn_d_quad_2d_interpol
345 344
integer(kind=sp_kind) :: ixinf,iyinf,basex,basey,i 346 345 integer(kind=sp_kind) :: ixinf,iyinf,basex,basey,i
real(kind=dp_kind),dimension(3) :: ztmp 347 346 real(kind=dp_kind),dimension(3) :: ztmp
!real(kind=8), external :: fvn_d_quad_interpol 348 347 !real(kind=8), external :: fvn_d_quad_interpol
349 348
call fvn_d_find_interval(x,ixinf,xdata,nx) 350 349 call fvn_d_find_interval(x,ixinf,xdata,nx)
call fvn_d_find_interval(y,iyinf,ydata,ny) 351 350 call fvn_d_find_interval(y,iyinf,ydata,ny)
352 351
! Settings for extrapolation 353 352 ! Settings for extrapolation
if (ixinf==0) then 354 353 if (ixinf==0) then
! TODO -> Lower x bound extrapolation warning 355 354 ! TODO -> Lower x bound extrapolation warning
ixinf=1 356 355 ixinf=1
end if 357 356 end if
358 357
if (ixinf==nx) then 359 358 if (ixinf==nx) then
! TODO -> Higher x bound extrapolation warning 360 359 ! TODO -> Higher x bound extrapolation warning
ixinf=nx-1 361 360 ixinf=nx-1
end if 362 361 end if
363 362
if (iyinf==0) then 364 363 if (iyinf==0) then
! TODO -> Lower y bound extrapolation warning 365 364 ! TODO -> Lower y bound extrapolation warning
iyinf=1 366 365 iyinf=1
end if 367 366 end if
368 367
if (iyinf==ny) then 369 368 if (iyinf==ny) then
! TODO -> Higher y bound extrapolation warning 370 369 ! TODO -> Higher y bound extrapolation warning
iyinf=ny-1 371 370 iyinf=ny-1
end if 372 371 end if
373 372
! The three points we will use are iinf-1,iinf and iinf+1 with the 374 373 ! 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 375 374 ! exception of the first interval, where iinf=1 we will use 1,2 and 3
if (ixinf==1) then 376 375 if (ixinf==1) then
basex=0 377 376 basex=0
else 378 377 else
basex=ixinf-2 379 378 basex=ixinf-2
end if 380 379 end if
381 380
if (iyinf==1) then 382 381 if (iyinf==1) then
basey=0 383 382 basey=0
else 384 383 else
basey=iyinf-2 385 384 basey=iyinf-2
end if 386 385 end if
387 386
! First we make 3 interpolations for x at y(base+1),y(base+2),y(base+3) 388 387 ! First we make 3 interpolations for x at y(base+1),y(base+2),y(base+3)
! stored in ztmp(1:3) 389 388 ! stored in ztmp(1:3)
do i=1,3 390 389 do i=1,3
ztmp(i)=fvn_d_quad_interpol(x,nx,xdata,zdata(:,basey+i)) 391 390 ztmp(i)=fvn_d_quad_interpol(x,nx,xdata,zdata(:,basey+i))
end do 392 391 end do
393 392
! Then we make an interpolation for y using previous interpolations 394 393 ! 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) 395 394 fvn_d_quad_2d_interpol=fvn_d_quad_interpol(y,3,ydata(basey+1:basey+3),ztmp)
end function 396 395 end function
397 396
398 397
function fvn_s_quad_3d_interpol(x,y,z,nx,xdata,ny,ydata,nz,zdata,tdata) 399 398 function fvn_s_quad_3d_interpol(x,y,z,nx,xdata,ny,ydata,nz,zdata,tdata)
implicit none 400 399 implicit none
! This function evaluate the value of a 3 variables function defined by a 401 400 ! This function evaluate the value of a 3 variables function defined by a
! set of points and values, using a quadratic interpolation 402 401 ! set of points and values, using a quadratic interpolation
! xdata, ydata and zdata must be increasingly ordered 403 402 ! xdata, ydata and zdata must be increasingly ordered
! The triplet (x,y,z) must be within xdata,ydata and zdata to actually 404 403 ! The triplet (x,y,z) must be within xdata,ydata and zdata to actually
! perform an interpolation, otherwise extrapolation is done 405 404 ! perform an interpolation, otherwise extrapolation is done
integer(kind=sp_kind), intent(in) :: nx,ny,nz 406 405 integer(kind=sp_kind), intent(in) :: nx,ny,nz
real(kind=sp_kind), intent(in) :: x,y,z 407 406 real(kind=sp_kind), intent(in) :: x,y,z
real(kind=sp_kind), intent(in), dimension(nx) :: xdata 408 407 real(kind=sp_kind), intent(in), dimension(nx) :: xdata
real(kind=sp_kind), intent(in), dimension(ny) :: ydata 409 408 real(kind=sp_kind), intent(in), dimension(ny) :: ydata
real(kind=sp_kind), intent(in), dimension(nz) :: zdata 410 409 real(kind=sp_kind), intent(in), dimension(nz) :: zdata
real(kind=sp_kind), intent(in), dimension(nx,ny,nz) :: tdata 411 410 real(kind=sp_kind), intent(in), dimension(nx,ny,nz) :: tdata
real(kind=sp_kind) :: fvn_s_quad_3d_interpol 412 411 real(kind=sp_kind) :: fvn_s_quad_3d_interpol
413 412
integer(kind=sp_kind) :: ixinf,iyinf,izinf,basex,basey,basez,i,j 414 413 integer(kind=sp_kind) :: ixinf,iyinf,izinf,basex,basey,basez,i,j
!real(kind=4), external :: fvn_s_quad_interpol,fvn_s_quad_2d_interpol 415 414 !real(kind=4), external :: fvn_s_quad_interpol,fvn_s_quad_2d_interpol
real(kind=sp_kind),dimension(3,3) :: ttmp 416 415 real(kind=sp_kind),dimension(3,3) :: ttmp
417 416
call fvn_s_find_interval(x,ixinf,xdata,nx) 418 417 call fvn_s_find_interval(x,ixinf,xdata,nx)
call fvn_s_find_interval(y,iyinf,ydata,ny) 419 418 call fvn_s_find_interval(y,iyinf,ydata,ny)
call fvn_s_find_interval(z,izinf,zdata,nz) 420 419 call fvn_s_find_interval(z,izinf,zdata,nz)
421 420
! Settings for extrapolation 422 421 ! Settings for extrapolation
if (ixinf==0) then 423 422 if (ixinf==0) then
! TODO -> Lower x bound extrapolation warning 424 423 ! TODO -> Lower x bound extrapolation warning
ixinf=1 425 424 ixinf=1
end if 426 425 end if
427 426
if (ixinf==nx) then 428 427 if (ixinf==nx) then
! TODO -> Higher x bound extrapolation warning 429 428 ! TODO -> Higher x bound extrapolation warning
ixinf=nx-1 430 429 ixinf=nx-1
end if 431 430 end if
432 431
if (iyinf==0) then 433 432 if (iyinf==0) then
! TODO -> Lower y bound extrapolation warning 434 433 ! TODO -> Lower y bound extrapolation warning
iyinf=1 435 434 iyinf=1
end if 436 435 end if
437 436
if (iyinf==ny) then 438 437 if (iyinf==ny) then
! TODO -> Higher y bound extrapolation warning 439 438 ! TODO -> Higher y bound extrapolation warning
iyinf=ny-1 440 439 iyinf=ny-1
end if 441 440 end if
442 441
if (izinf==0) then 443 442 if (izinf==0) then
! TODO -> Lower z bound extrapolation warning 444 443 ! TODO -> Lower z bound extrapolation warning
izinf=1 445 444 izinf=1
end if 446 445 end if
447 446
if (izinf==nz) then 448 447 if (izinf==nz) then
! TODO -> Higher z bound extrapolation warning 449 448 ! TODO -> Higher z bound extrapolation warning
izinf=nz-1 450 449 izinf=nz-1
end if 451 450 end if
452 451
! The three points we will use are iinf-1,iinf and iinf+1 with the 453 452 ! 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 454 453 ! exception of the first interval, where iinf=1 we will use 1,2 and 3
if (ixinf==1) then 455 454 if (ixinf==1) then
basex=0 456 455 basex=0
else 457 456 else
basex=ixinf-2 458 457 basex=ixinf-2
end if 459 458 end if
460 459
if (iyinf==1) then 461 460 if (iyinf==1) then
basey=0 462 461 basey=0
else 463 462 else
basey=iyinf-2 464 463 basey=iyinf-2
end if 465 464 end if
466 465
if (izinf==1) then 467 466 if (izinf==1) then
basez=0 468 467 basez=0
else 469 468 else
basez=izinf-2 470 469 basez=izinf-2
end if 471 470 end if
472 471
! We first make 9 one dimensional interpolation on variable x. 473 472 ! We first make 9 one dimensional interpolation on variable x.
! results are stored in ttmp 474 473 ! results are stored in ttmp
do i=1,3 475 474 do i=1,3
do j=1,3 476 475 do j=1,3
ttmp(i,j)=fvn_s_quad_interpol(x,nx,xdata,tdata(:,basey+i,basez+j)) 477 476 ttmp(i,j)=fvn_s_quad_interpol(x,nx,xdata,tdata(:,basey+i,basez+j))
end do 478 477 end do
end do 479 478 end do
480 479
! We then make a 2 dimensionnal interpolation on variables y and z 481 480 ! We then make a 2 dimensionnal interpolation on variables y and z
fvn_s_quad_3d_interpol=fvn_s_quad_2d_interpol(y,z, & 482 481 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) 483 482 3,ydata(basey+1:basey+3),3,zdata(basez+1:basez+3),ttmp)
end function 484 483 end function
485 484
486 485
function fvn_d_quad_3d_interpol(x,y,z,nx,xdata,ny,ydata,nz,zdata,tdata) 487 486 function fvn_d_quad_3d_interpol(x,y,z,nx,xdata,ny,ydata,nz,zdata,tdata)
implicit none 488 487 implicit none
! This function evaluate the value of a 3 variables function defined by a 489 488 ! This function evaluate the value of a 3 variables function defined by a
! set of points and values, using a quadratic interpolation 490 489 ! set of points and values, using a quadratic interpolation
! xdata, ydata and zdata must be increasingly ordered 491 490 ! xdata, ydata and zdata must be increasingly ordered
! The triplet (x,y,z) must be within xdata,ydata and zdata to actually 492 491 ! The triplet (x,y,z) must be within xdata,ydata and zdata to actually
! perform an interpolation, otherwise extrapolation is done 493 492 ! perform an interpolation, otherwise extrapolation is done
integer(kind=sp_kind), intent(in) :: nx,ny,nz 494 493 integer(kind=sp_kind), intent(in) :: nx,ny,nz
real(kind=dp_kind), intent(in) :: x,y,z 495 494 real(kind=dp_kind), intent(in) :: x,y,z
real(kind=dp_kind), intent(in), dimension(nx) :: xdata 496 495 real(kind=dp_kind), intent(in), dimension(nx) :: xdata
real(kind=dp_kind), intent(in), dimension(ny) :: ydata 497 496 real(kind=dp_kind), intent(in), dimension(ny) :: ydata
real(kind=dp_kind), intent(in), dimension(nz) :: zdata 498 497 real(kind=dp_kind), intent(in), dimension(nz) :: zdata
real(kind=dp_kind), intent(in), dimension(nx,ny,nz) :: tdata 499 498 real(kind=dp_kind), intent(in), dimension(nx,ny,nz) :: tdata
real(kind=dp_kind) :: fvn_d_quad_3d_interpol 500 499 real(kind=dp_kind) :: fvn_d_quad_3d_interpol
501 500
integer(kind=sp_kind) :: ixinf,iyinf,izinf,basex,basey,basez,i,j 502 501 integer(kind=sp_kind) :: ixinf,iyinf,izinf,basex,basey,basez,i,j
!real(kind=8), external :: fvn_d_quad_interpol,fvn_d_quad_2d_interpol 503 502 !real(kind=8), external :: fvn_d_quad_interpol,fvn_d_quad_2d_interpol
real(kind=dp_kind),dimension(3,3) :: ttmp 504 503 real(kind=dp_kind),dimension(3,3) :: ttmp
505 504
call fvn_d_find_interval(x,ixinf,xdata,nx) 506 505 call fvn_d_find_interval(x,ixinf,xdata,nx)
call fvn_d_find_interval(y,iyinf,ydata,ny) 507 506 call fvn_d_find_interval(y,iyinf,ydata,ny)
call fvn_d_find_interval(z,izinf,zdata,nz) 508 507 call fvn_d_find_interval(z,izinf,zdata,nz)
509 508
! Settings for extrapolation 510 509 ! Settings for extrapolation
if (ixinf==0) then 511 510 if (ixinf==0) then
! TODO -> Lower x bound extrapolation warning 512 511 ! TODO -> Lower x bound extrapolation warning
ixinf=1 513 512 ixinf=1
end if 514 513 end if
515 514
if (ixinf==nx) then 516 515 if (ixinf==nx) then
! TODO -> Higher x bound extrapolation warning 517 516 ! TODO -> Higher x bound extrapolation warning
ixinf=nx-1 518 517 ixinf=nx-1
end if 519 518 end if
520 519
if (iyinf==0) then 521 520 if (iyinf==0) then
! TODO -> Lower y bound extrapolation warning 522 521 ! TODO -> Lower y bound extrapolation warning
iyinf=1 523 522 iyinf=1
end if 524 523 end if
525 524
if (iyinf==ny) then 526 525 if (iyinf==ny) then
! TODO -> Higher y bound extrapolation warning 527 526 ! TODO -> Higher y bound extrapolation warning
iyinf=ny-1 528 527 iyinf=ny-1
end if 529 528 end if
530 529
if (izinf==0) then 531 530 if (izinf==0) then
! TODO -> Lower z bound extrapolation warning 532 531 ! TODO -> Lower z bound extrapolation warning
izinf=1 533 532 izinf=1
end if 534 533 end if
535 534
if (izinf==nz) then 536 535 if (izinf==nz) then
! TODO -> Higher z bound extrapolation warning 537 536 ! TODO -> Higher z bound extrapolation warning
izinf=nz-1 538 537 izinf=nz-1
end if 539 538 end if
540 539
! The three points we will use are iinf-1,iinf and iinf+1 with the 541 540 ! 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 542 541 ! exception of the first interval, where iinf=1 we will use 1,2 and 3
if (ixinf==1) then 543 542 if (ixinf==1) then
basex=0 544 543 basex=0
else 545 544 else
basex=ixinf-2 546 545 basex=ixinf-2
end if 547 546 end if
548 547
if (iyinf==1) then 549 548 if (iyinf==1) then
basey=0 550 549 basey=0
else 551 550 else
basey=iyinf-2 552 551 basey=iyinf-2
end if 553 552 end if
554 553
if (izinf==1) then 555 554 if (izinf==1) then
basez=0 556 555 basez=0
else 557 556 else
basez=izinf-2 558 557 basez=izinf-2
end if 559 558 end if
560 559
! We first make 9 one dimensional interpolation on variable x. 561 560 ! We first make 9 one dimensional interpolation on variable x.
! results are stored in ttmp 562 561 ! results are stored in ttmp
do i=1,3 563 562 do i=1,3
do j=1,3 564 563 do j=1,3
ttmp(i,j)=fvn_d_quad_interpol(x,nx,xdata,tdata(:,basey+i,basez+j)) 565 564 ttmp(i,j)=fvn_d_quad_interpol(x,nx,xdata,tdata(:,basey+i,basez+j))
end do 566 565 end do
end do 567 566 end do
568 567
! We then make a 2 dimensionnal interpolation on variables y and z 569 568 ! We then make a 2 dimensionnal interpolation on variables y and z
fvn_d_quad_3d_interpol=fvn_d_quad_2d_interpol(y,z, & 570 569 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) 571 570 3,ydata(basey+1:basey+3),3,zdata(basez+1:basez+3),ttmp)
end function 572 571 end function
573 572
574 573
575 574
576 575
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 577 576 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 578 577 !
! Akima spline interpolation and spline evaluation 579 578 ! Akima spline interpolation and spline evaluation
! 580 579 !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 581 580 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
582 581
! Single precision 583 582 ! Single precision
subroutine fvn_s_akima(n,x,y,br,co) 584 583 subroutine fvn_s_akima(n,x,y,br,co)
implicit none 585 584 implicit none
integer, intent(in) :: n 586 585 integer, intent(in) :: n
real, intent(in) :: x(n) 587 586 real, intent(in) :: x(n)
real, intent(in) :: y(n) 588 587 real, intent(in) :: y(n)
real, intent(out) :: br(n) 589 588 real, intent(out) :: br(n)
real, intent(out) :: co(4,n) 590 589 real, intent(out) :: co(4,n)
591 590
real, allocatable :: var(:),z(:) 592 591 real, allocatable :: var(:),z(:)
real :: wi_1,wi 593 592 real :: wi_1,wi
integer :: i 594 593 integer :: i
real :: dx,a,b 595 594 real :: dx,a,b
596 595
! br is just a copy of x 597 596 ! br is just a copy of x
br(:)=x(:) 598 597 br(:)=x(:)
599 598
allocate(var(n+3)) 600 599 allocate(var(n+3))
allocate(z(n)) 601 600 allocate(z(n))
! evaluate the variations 602 601 ! evaluate the variations
do i=1, n-1 603 602 do i=1, n-1
var(i+2)=(y(i+1)-y(i))/(x(i+1)-x(i)) 604 603 var(i+2)=(y(i+1)-y(i))/(x(i+1)-x(i))
end do 605 604 end do
var(n+2)=2.e0*var(n+1)-var(n) 606 605 var(n+2)=2.e0*var(n+1)-var(n)
var(n+3)=2.e0*var(n+2)-var(n+1) 607 606 var(n+3)=2.e0*var(n+2)-var(n+1)
var(2)=2.e0*var(3)-var(4) 608 607 var(2)=2.e0*var(3)-var(4)
var(1)=2.e0*var(2)-var(3) 609 608 var(1)=2.e0*var(2)-var(3)
610 609
do i = 1, n 611 610 do i = 1, n
wi_1=abs(var(i+3)-var(i+2)) 612 611 wi_1=abs(var(i+3)-var(i+2))
wi=abs(var(i+1)-var(i)) 613 612 wi=abs(var(i+1)-var(i))
if ((wi_1+wi).eq.0.e0) then 614 613 if ((wi_1+wi).eq.0.e0) then
z(i)=(var(i+2)+var(i+1))/2.e0 615 614 z(i)=(var(i+2)+var(i+1))/2.e0
else 616 615 else
z(i)=(wi_1*var(i+1)+wi*var(i+2))/(wi_1+wi) 617 616 z(i)=(wi_1*var(i+1)+wi*var(i+2))/(wi_1+wi)
end if 618 617 end if
end do 619 618 end do
620 619
do i=1, n-1 621 620 do i=1, n-1
dx=x(i+1)-x(i) 622 621 dx=x(i+1)-x(i)
a=(z(i+1)-z(i))*dx ! coeff intermediaires pour calcul wd 623 622 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 624 623 b=y(i+1)-y(i)-z(i)*dx ! coeff intermediaires pour calcul wd
co(1,i)=y(i) 625 624 co(1,i)=y(i)
co(2,i)=z(i) 626 625 co(2,i)=z(i)
!co(3,i)=-(a-3.*b)/dx**2 ! mรฉthode wd 627 626 !co(3,i)=-(a-3.*b)/dx**2 ! mรฉthode wd
!co(4,i)=(a-2.*b)/dx**3 ! mรฉthode wd 628 627 !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 629 628 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 ! 630 629 co(4,i)=(z(i)+z(i+1)-2.e0*var(i+2))/dx**2 !
fvn_linear/fvn_linear.f90
Diff comments   View file @ 8d883e8
module fvn_linear 1 1 module fvn_linear
use kind_definition 2
use fvn_common 3 2 use fvn_common
implicit none 4 3 implicit none
5 4
6 5
! 7 6 !
! Interfaces for matrix operators 8 7 ! Interfaces for matrix operators
9 8
! .x. matrix multiplication 10 9 ! .x. matrix multiplication
interface operator(.x.) 11 10 interface operator(.x.)
module procedure fvn_op_s_matmul,fvn_op_d_matmul,fvn_op_c_matmul,fvn_op_z_matmul 12 11 module procedure fvn_op_s_matmul,fvn_op_d_matmul,fvn_op_c_matmul,fvn_op_z_matmul
end interface 13 12 end interface
14 13
! .t. matrix transposition 15 14 ! .t. matrix transposition
interface operator(.t.) 16 15 interface operator(.t.)
module procedure fvn_op_s_transpose,fvn_op_d_transpose,fvn_op_c_transpose,fvn_op_z_transpose 17 16 module procedure fvn_op_s_transpose,fvn_op_d_transpose,fvn_op_c_transpose,fvn_op_z_transpose
end interface 18 17 end interface
19 18
! .tx. transpose first operand and multiply 20 19 ! .tx. transpose first operand and multiply
interface operator(.tx.) 21 20 interface operator(.tx.)
module procedure fvn_op_s_tx,fvn_op_d_tx,fvn_op_c_tx,fvn_op_z_tx 22 21 module procedure fvn_op_s_tx,fvn_op_d_tx,fvn_op_c_tx,fvn_op_z_tx
end interface 23 22 end interface
24 23
! .xt. transpose second operand and multiply 25 24 ! .xt. transpose second operand and multiply
interface operator(.xt.) 26 25 interface operator(.xt.)
module procedure fvn_op_s_xt,fvn_op_d_xt,fvn_op_c_xt,fvn_op_z_xt 27 26 module procedure fvn_op_s_xt,fvn_op_d_xt,fvn_op_c_xt,fvn_op_z_xt
end interface 28 27 end interface
29 28
! .i. inverse matrix 30 29 ! .i. inverse matrix
interface operator(.i.) 31 30 interface operator(.i.)
module procedure fvn_op_s_matinv,fvn_op_d_matinv,fvn_op_c_matinv,fvn_op_z_matinv 32 31 module procedure fvn_op_s_matinv,fvn_op_d_matinv,fvn_op_c_matinv,fvn_op_z_matinv
end interface 33 32 end interface
34 33
! .ix. inverse first operand and multiply 35 34 ! .ix. inverse first operand and multiply
interface operator(.ix.) 36 35 interface operator(.ix.)
module procedure fvn_op_s_ix,fvn_op_d_ix,fvn_op_c_ix,fvn_op_z_ix 37 36 module procedure fvn_op_s_ix,fvn_op_d_ix,fvn_op_c_ix,fvn_op_z_ix
end interface 38 37 end interface
39 38
! .xi. inverse second operand and multiply 40 39 ! .xi. inverse second operand and multiply
interface operator(.xi.) 41 40 interface operator(.xi.)
module procedure fvn_op_s_xi,fvn_op_d_xi,fvn_op_c_xi,fvn_op_z_xi 42 41 module procedure fvn_op_s_xi,fvn_op_d_xi,fvn_op_c_xi,fvn_op_z_xi
end interface 43 42 end interface
44 43
! .h. transpose conjugate (adjoint) 45 44 ! .h. transpose conjugate (adjoint)
interface operator(.h.) 46 45 interface operator(.h.)
module procedure fvn_op_s_transpose,fvn_op_d_transpose,fvn_op_c_conj_transpose,fvn_op_z_conj_transpose 47 46 module procedure fvn_op_s_transpose,fvn_op_d_transpose,fvn_op_c_conj_transpose,fvn_op_z_conj_transpose
end interface 48 47 end interface
49 48
! .hx. transpose conjugate first operand and multiply 50 49 ! .hx. transpose conjugate first operand and multiply
interface operator(.hx.) 51 50 interface operator(.hx.)
module procedure fvn_op_s_tx,fvn_op_d_tx,fvn_op_c_hx,fvn_op_z_hx 52 51 module procedure fvn_op_s_tx,fvn_op_d_tx,fvn_op_c_hx,fvn_op_z_hx
end interface 53 52 end interface
54 53
! .xh. transpose conjugate second operand and multiply 55 54 ! .xh. transpose conjugate second operand and multiply
interface operator(.xh.) 56 55 interface operator(.xh.)
module procedure fvn_op_s_xt,fvn_op_d_xt,fvn_op_c_xh,fvn_op_z_xh 57 56 module procedure fvn_op_s_xt,fvn_op_d_xt,fvn_op_c_xh,fvn_op_z_xh
end interface 58 57 end interface
59 58
60 59
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 61 60 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 62 61 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Generic interface Definition 63 62 ! Generic interface Definition
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 64 63 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 65 64 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
66 65
! Matrix inversion 67 66 ! Matrix inversion
interface fvn_matinv 68 67 interface fvn_matinv
module procedure fvn_s_matinv,fvn_d_matinv,fvn_c_matinv,fvn_z_matinv 69 68 module procedure fvn_s_matinv,fvn_d_matinv,fvn_c_matinv,fvn_z_matinv
end interface fvn_matinv 70 69 end interface fvn_matinv
71 70
! Determinant 72 71 ! Determinant
interface fvn_det 73 72 interface fvn_det
module procedure fvn_s_det,fvn_d_det,fvn_c_det,fvn_z_det 74 73 module procedure fvn_s_det,fvn_d_det,fvn_c_det,fvn_z_det
end interface fvn_det 75 74 end interface fvn_det
76 75
! Condition 77 76 ! Condition
interface fvn_matcon 78 77 interface fvn_matcon
module procedure fvn_s_matcon,fvn_d_matcon,fvn_c_matcon,fvn_z_matcon 79 78 module procedure fvn_s_matcon,fvn_d_matcon,fvn_c_matcon,fvn_z_matcon
end interface fvn_matcon 80 79 end interface fvn_matcon
81 80
! Eigen 82 81 ! Eigen
interface fvn_matev 83 82 interface fvn_matev
module procedure fvn_s_matev,fvn_d_matev,fvn_c_matev,fvn_z_matev 84 83 module procedure fvn_s_matev,fvn_d_matev,fvn_c_matev,fvn_z_matev
end interface fvn_matev 85 84 end interface fvn_matev
86 85
! Least square polynomial 87 86 ! Least square polynomial
interface fvn_lspoly 88 87 interface fvn_lspoly
module procedure fvn_s_lspoly,fvn_d_lspoly 89 88 module procedure fvn_s_lspoly,fvn_d_lspoly
end interface fvn_lspoly 90 89 end interface fvn_lspoly
91 90
92 91
contains 93 92 contains
94 93
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 95 94 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 96 95 !
! Linear operators 97 96 ! Linear operators
! 98 97 !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 99 98 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
100 99
! 101 100 !
! .x. 102 101 ! .x.
! 103 102 !
function fvn_op_s_matmul(a,b) 104 103 function fvn_op_s_matmul(a,b)
implicit none 105 104 implicit none
real(kind=sp_kind), dimension(:,:),intent(in) :: a,b 106 105 real(kind=sp_kind), dimension(:,:),intent(in) :: a,b
real(kind=sp_kind), dimension(size(a,1),size(b,2)) :: fvn_op_s_matmul 107 106 real(kind=sp_kind), dimension(size(a,1),size(b,2)) :: fvn_op_s_matmul
fvn_op_s_matmul=matmul(a,b) 108 107 fvn_op_s_matmul=matmul(a,b)
end function 109 108 end function
function fvn_op_d_matmul(a,b) 110 109 function fvn_op_d_matmul(a,b)
implicit none 111 110 implicit none
real(kind=dp_kind), dimension(:,:),intent(in) :: a,b 112 111 real(kind=dp_kind), dimension(:,:),intent(in) :: a,b
real(kind=dp_kind), dimension(size(a,1),size(b,2)) :: fvn_op_d_matmul 113 112 real(kind=dp_kind), dimension(size(a,1),size(b,2)) :: fvn_op_d_matmul
fvn_op_d_matmul=matmul(a,b) 114 113 fvn_op_d_matmul=matmul(a,b)
end function 115 114 end function
function fvn_op_c_matmul(a,b) 116 115 function fvn_op_c_matmul(a,b)
implicit none 117 116 implicit none
complex(kind=sp_kind), dimension(:,:),intent(in) :: a,b 118 117 complex(kind=sp_kind), dimension(:,:),intent(in) :: a,b
complex(kind=sp_kind), dimension(size(a,1),size(b,2)) :: fvn_op_c_matmul 119 118 complex(kind=sp_kind), dimension(size(a,1),size(b,2)) :: fvn_op_c_matmul
fvn_op_c_matmul=matmul(a,b) 120 119 fvn_op_c_matmul=matmul(a,b)
end function 121 120 end function
function fvn_op_z_matmul(a,b) 122 121 function fvn_op_z_matmul(a,b)
implicit none 123 122 implicit none
complex(kind=dp_kind), dimension(:,:), intent(in) :: a,b 124 123 complex(kind=dp_kind), dimension(:,:), intent(in) :: a,b
complex(kind=dp_kind), dimension(size(a,1),size(b,2)) :: fvn_op_z_matmul 125 124 complex(kind=dp_kind), dimension(size(a,1),size(b,2)) :: fvn_op_z_matmul
fvn_op_z_matmul=matmul(a,b) 126 125 fvn_op_z_matmul=matmul(a,b)
end function 127 126 end function
128 127
! 129 128 !
! .tx. 130 129 ! .tx.
! 131 130 !
function fvn_op_s_tx(a,b) 132 131 function fvn_op_s_tx(a,b)
implicit none 133 132 implicit none
real(kind=sp_kind), dimension(:,:), intent(in) :: a,b 134 133 real(kind=sp_kind), dimension(:,:), intent(in) :: a,b
real(kind=sp_kind), dimension(size(a,2),size(b,2)) :: fvn_op_s_tx 135 134 real(kind=sp_kind), dimension(size(a,2),size(b,2)) :: fvn_op_s_tx
fvn_op_s_tx=matmul(transpose(a),b) 136 135 fvn_op_s_tx=matmul(transpose(a),b)
end function 137 136 end function
function fvn_op_d_tx(a,b) 138 137 function fvn_op_d_tx(a,b)
implicit none 139 138 implicit none
real(kind=dp_kind), dimension(:,:), intent(in) :: a,b 140 139 real(kind=dp_kind), dimension(:,:), intent(in) :: a,b
real(kind=dp_kind), dimension(size(a,2),size(b,2)) :: fvn_op_d_tx 141 140 real(kind=dp_kind), dimension(size(a,2),size(b,2)) :: fvn_op_d_tx
fvn_op_d_tx=matmul(transpose(a),b) 142 141 fvn_op_d_tx=matmul(transpose(a),b)
end function 143 142 end function
function fvn_op_c_tx(a,b) 144 143 function fvn_op_c_tx(a,b)
implicit none 145 144 implicit none
complex(kind=sp_kind), dimension(:,:), intent(in) :: a,b 146 145 complex(kind=sp_kind), dimension(:,:), intent(in) :: a,b
complex(kind=sp_kind), dimension(size(a,2),size(b,2)) :: fvn_op_c_tx 147 146 complex(kind=sp_kind), dimension(size(a,2),size(b,2)) :: fvn_op_c_tx
fvn_op_c_tx=matmul(transpose(a),b) 148 147 fvn_op_c_tx=matmul(transpose(a),b)
end function 149 148 end function
function fvn_op_z_tx(a,b) 150 149 function fvn_op_z_tx(a,b)
implicit none 151 150 implicit none
complex(kind=dp_kind), dimension(:,:), intent(in) :: a,b 152 151 complex(kind=dp_kind), dimension(:,:), intent(in) :: a,b
complex(kind=dp_kind), dimension(size(a,2),size(b,2)) :: fvn_op_z_tx 153 152 complex(kind=dp_kind), dimension(size(a,2),size(b,2)) :: fvn_op_z_tx
fvn_op_z_tx=matmul(transpose(a),b) 154 153 fvn_op_z_tx=matmul(transpose(a),b)
end function 155 154 end function
156 155
157 156
! 158 157 !
! .xt. 159 158 ! .xt.
! 160 159 !
function fvn_op_s_xt(a,b) 161 160 function fvn_op_s_xt(a,b)
implicit none 162 161 implicit none
real(kind=sp_kind), dimension(:,:), intent(in) :: a,b 163 162 real(kind=sp_kind), dimension(:,:), intent(in) :: a,b
real(kind=sp_kind), dimension(size(a,1),size(b,1)) :: fvn_op_s_xt 164 163 real(kind=sp_kind), dimension(size(a,1),size(b,1)) :: fvn_op_s_xt
fvn_op_s_xt=matmul(a,transpose(b)) 165 164 fvn_op_s_xt=matmul(a,transpose(b))
end function 166 165 end function
function fvn_op_d_xt(a,b) 167 166 function fvn_op_d_xt(a,b)
implicit none 168 167 implicit none
real(kind=dp_kind), dimension(:,:), intent(in) :: a,b 169 168 real(kind=dp_kind), dimension(:,:), intent(in) :: a,b
real(kind=dp_kind), dimension(size(a,1),size(b,1)) :: fvn_op_d_xt 170 169 real(kind=dp_kind), dimension(size(a,1),size(b,1)) :: fvn_op_d_xt
fvn_op_d_xt=matmul(a,transpose(b)) 171 170 fvn_op_d_xt=matmul(a,transpose(b))
end function 172 171 end function
function fvn_op_c_xt(a,b) 173 172 function fvn_op_c_xt(a,b)
implicit none 174 173 implicit none
complex(kind=sp_kind), dimension(:,:), intent(in) :: a,b 175 174 complex(kind=sp_kind), dimension(:,:), intent(in) :: a,b
complex(kind=sp_kind), dimension(size(a,1),size(b,1)) :: fvn_op_c_xt 176 175 complex(kind=sp_kind), dimension(size(a,1),size(b,1)) :: fvn_op_c_xt
fvn_op_c_xt=matmul(a,transpose(b)) 177 176 fvn_op_c_xt=matmul(a,transpose(b))
end function 178 177 end function
function fvn_op_z_xt(a,b) 179 178 function fvn_op_z_xt(a,b)
implicit none 180 179 implicit none
complex(kind=dp_kind), dimension(:,:), intent(in) :: a,b 181 180 complex(kind=dp_kind), dimension(:,:), intent(in) :: a,b
complex(kind=dp_kind), dimension(size(a,1),size(b,1)) :: fvn_op_z_xt 182 181 complex(kind=dp_kind), dimension(size(a,1),size(b,1)) :: fvn_op_z_xt
fvn_op_z_xt=matmul(a,transpose(b)) 183 182 fvn_op_z_xt=matmul(a,transpose(b))
end function 184 183 end function
185 184
! 186 185 !
! .t. 187 186 ! .t.
! 188 187 !
function fvn_op_s_transpose(a) 189 188 function fvn_op_s_transpose(a)
implicit none 190 189 implicit none
real(kind=sp_kind),dimension(:,:),intent(in) :: a 191 190 real(kind=sp_kind),dimension(:,:),intent(in) :: a
real(kind=sp_kind),dimension(size(a,2),size(a,1)) :: fvn_op_s_transpose 192 191 real(kind=sp_kind),dimension(size(a,2),size(a,1)) :: fvn_op_s_transpose
fvn_op_s_transpose=transpose(a) 193 192 fvn_op_s_transpose=transpose(a)
end function 194 193 end function
function fvn_op_d_transpose(a) 195 194 function fvn_op_d_transpose(a)
implicit none 196 195 implicit none
real(kind=dp_kind),dimension(:,:),intent(in) :: a 197 196 real(kind=dp_kind),dimension(:,:),intent(in) :: a
real(kind=dp_kind),dimension(size(a,2),size(a,1)) :: fvn_op_d_transpose 198 197 real(kind=dp_kind),dimension(size(a,2),size(a,1)) :: fvn_op_d_transpose
fvn_op_d_transpose=transpose(a) 199 198 fvn_op_d_transpose=transpose(a)
end function 200 199 end function
function fvn_op_c_transpose(a) 201 200 function fvn_op_c_transpose(a)
implicit none 202 201 implicit none
complex(kind=sp_kind),dimension(:,:),intent(in) :: a 203 202 complex(kind=sp_kind),dimension(:,:),intent(in) :: a
complex(kind=sp_kind),dimension(size(a,2),size(a,1)) :: fvn_op_c_transpose 204 203 complex(kind=sp_kind),dimension(size(a,2),size(a,1)) :: fvn_op_c_transpose
fvn_op_c_transpose=transpose(a) 205 204 fvn_op_c_transpose=transpose(a)
end function 206 205 end function
function fvn_op_z_transpose(a) 207 206 function fvn_op_z_transpose(a)
implicit none 208 207 implicit none
complex(kind=dp_kind),dimension(:,:),intent(in) :: a 209 208 complex(kind=dp_kind),dimension(:,:),intent(in) :: a
complex(kind=dp_kind),dimension(size(a,2),size(a,1)) :: fvn_op_z_transpose 210 209 complex(kind=dp_kind),dimension(size(a,2),size(a,1)) :: fvn_op_z_transpose
fvn_op_z_transpose=transpose(a) 211 210 fvn_op_z_transpose=transpose(a)
end function 212 211 end function
213 212
! 214 213 !
! .i. 215 214 ! .i.
! 216 215 !
! It seems that there's a problem with automatic arrays with gfortran 217 216 ! It seems that there's a problem with automatic arrays with gfortran
! in some circumstances. To allow compilation with gfortran we use here a temporary array 218 217 ! in some circumstances. To allow compilation with gfortran we use here a temporary array
! for the call. Without that there's a warning at compile time and a segmentation fault 219 218 ! for the call. Without that there's a warning at compile time and a segmentation fault
! during execution. This is odd as we double memory use. 220 219 ! during execution. This is odd as we double memory use.
function fvn_op_s_matinv(a) 221 220 function fvn_op_s_matinv(a)
implicit none 222 221 implicit none
real(kind=sp_kind),dimension(:,:),intent(in) :: a 223 222 real(kind=sp_kind),dimension(:,:),intent(in) :: a
real(kind=sp_kind),dimension(size(a,1),size(a,1)) :: fvn_op_s_matinv,tmp_array 224 223 real(kind=sp_kind),dimension(size(a,1),size(a,1)) :: fvn_op_s_matinv,tmp_array
call fvn_s_matinv(size(a,1),a,tmp_array,fvn_status) 225 224 call fvn_s_matinv(size(a,1),a,tmp_array,fvn_status)
fvn_op_s_matinv=tmp_array 226 225 fvn_op_s_matinv=tmp_array
end function 227 226 end function
function fvn_op_d_matinv(a) 228 227 function fvn_op_d_matinv(a)
implicit none 229 228 implicit none
real(kind=dp_kind),dimension(:,:),intent(in) :: a 230 229 real(kind=dp_kind),dimension(:,:),intent(in) :: a
real(kind=dp_kind),dimension(size(a,1),size(a,1)) :: fvn_op_d_matinv,tmp_array 231 230 real(kind=dp_kind),dimension(size(a,1),size(a,1)) :: fvn_op_d_matinv,tmp_array
call fvn_d_matinv(size(a,1),a,tmp_array,fvn_status) 232 231 call fvn_d_matinv(size(a,1),a,tmp_array,fvn_status)
fvn_op_d_matinv=tmp_array 233 232 fvn_op_d_matinv=tmp_array
end function 234 233 end function
function fvn_op_c_matinv(a) 235 234 function fvn_op_c_matinv(a)
implicit none 236 235 implicit none
complex(kind=sp_kind),dimension(:,:),intent(in) :: a 237 236 complex(kind=sp_kind),dimension(:,:),intent(in) :: a
complex(kind=sp_kind),dimension(size(a,1),size(a,1)) :: fvn_op_c_matinv,tmp_array 238 237 complex(kind=sp_kind),dimension(size(a,1),size(a,1)) :: fvn_op_c_matinv,tmp_array
call fvn_c_matinv(size(a,1),a,tmp_array,fvn_status) 239 238 call fvn_c_matinv(size(a,1),a,tmp_array,fvn_status)
fvn_op_c_matinv=tmp_array 240 239 fvn_op_c_matinv=tmp_array
end function 241 240 end function
function fvn_op_z_matinv(a) 242 241 function fvn_op_z_matinv(a)
implicit none 243 242 implicit none
complex(kind=dp_kind),dimension(:,:),intent(in) :: a 244 243 complex(kind=dp_kind),dimension(:,:),intent(in) :: a
complex(kind=dp_kind),dimension(size(a,1),size(a,1)) :: fvn_op_z_matinv,tmp_array 245 244 complex(kind=dp_kind),dimension(size(a,1),size(a,1)) :: fvn_op_z_matinv,tmp_array
call fvn_z_matinv(size(a,1),a,tmp_array,fvn_status) 246 245 call fvn_z_matinv(size(a,1),a,tmp_array,fvn_status)
fvn_op_z_matinv=tmp_array 247 246 fvn_op_z_matinv=tmp_array
end function 248 247 end function
249 248
! 250 249 !
! .ix. 251 250 ! .ix.
! 252 251 !
function fvn_op_s_ix(a,b) 253 252 function fvn_op_s_ix(a,b)
implicit none 254 253 implicit none
real(kind=sp_kind), dimension(:,:), intent(in) :: a,b 255 254 real(kind=sp_kind), dimension(:,:), intent(in) :: a,b
real(kind=sp_kind), dimension(size(a,1),size(b,2)) :: fvn_op_s_ix 256 255 real(kind=sp_kind), dimension(size(a,1),size(b,2)) :: fvn_op_s_ix
fvn_op_s_ix=matmul(fvn_op_s_matinv(a),b) 257 256 fvn_op_s_ix=matmul(fvn_op_s_matinv(a),b)
end function 258 257 end function
function fvn_op_d_ix(a,b) 259 258 function fvn_op_d_ix(a,b)
implicit none 260 259 implicit none
real(kind=dp_kind), dimension(:,:), intent(in) :: a,b 261 260 real(kind=dp_kind), dimension(:,:), intent(in) :: a,b
real(kind=dp_kind), dimension(size(a,1),size(b,2)) :: fvn_op_d_ix 262 261 real(kind=dp_kind), dimension(size(a,1),size(b,2)) :: fvn_op_d_ix
fvn_op_d_ix=matmul(fvn_op_d_matinv(a),b) 263 262 fvn_op_d_ix=matmul(fvn_op_d_matinv(a),b)
end function 264 263 end function
function fvn_op_c_ix(a,b) 265 264 function fvn_op_c_ix(a,b)
implicit none 266 265 implicit none
complex(kind=sp_kind), dimension(:,:), intent(in) :: a,b 267 266 complex(kind=sp_kind), dimension(:,:), intent(in) :: a,b
complex(kind=sp_kind), dimension(size(a,1),size(b,2)) :: fvn_op_c_ix 268 267 complex(kind=sp_kind), dimension(size(a,1),size(b,2)) :: fvn_op_c_ix
fvn_op_c_ix=matmul(fvn_op_c_matinv(a),b) 269 268 fvn_op_c_ix=matmul(fvn_op_c_matinv(a),b)
end function 270 269 end function
function fvn_op_z_ix(a,b) 271 270 function fvn_op_z_ix(a,b)
implicit none 272 271 implicit none
complex(kind=dp_kind), dimension(:,:), intent(in) :: a,b 273 272 complex(kind=dp_kind), dimension(:,:), intent(in) :: a,b
complex(kind=dp_kind), dimension(size(a,1),size(b,2)) :: fvn_op_z_ix 274 273 complex(kind=dp_kind), dimension(size(a,1),size(b,2)) :: fvn_op_z_ix
fvn_op_z_ix=matmul(fvn_op_z_matinv(a),b) 275 274 fvn_op_z_ix=matmul(fvn_op_z_matinv(a),b)
end function 276 275 end function
277 276
! 278 277 !
! .xi. 279 278 ! .xi.
! 280 279 !
function fvn_op_s_xi(a,b) 281 280 function fvn_op_s_xi(a,b)
implicit none 282 281 implicit none
real(kind=sp_kind), dimension(:,:), intent(in) :: a,b 283 282 real(kind=sp_kind), dimension(:,:), intent(in) :: a,b
real(kind=sp_kind), dimension(size(a,1),size(b,2)) :: fvn_op_s_xi 284 283 real(kind=sp_kind), dimension(size(a,1),size(b,2)) :: fvn_op_s_xi
fvn_op_s_xi=matmul(a,fvn_op_s_matinv(b)) 285 284 fvn_op_s_xi=matmul(a,fvn_op_s_matinv(b))
end function 286 285 end function
function fvn_op_d_xi(a,b) 287 286 function fvn_op_d_xi(a,b)
implicit none 288 287 implicit none
real(kind=dp_kind), dimension(:,:), intent(in) :: a,b 289 288 real(kind=dp_kind), dimension(:,:), intent(in) :: a,b
real(kind=dp_kind), dimension(size(a,1),size(b,2)) :: fvn_op_d_xi 290 289 real(kind=dp_kind), dimension(size(a,1),size(b,2)) :: fvn_op_d_xi
fvn_op_d_xi=matmul(a,fvn_op_d_matinv(b)) 291 290 fvn_op_d_xi=matmul(a,fvn_op_d_matinv(b))
end function 292 291 end function
function fvn_op_c_xi(a,b) 293 292 function fvn_op_c_xi(a,b)
implicit none 294 293 implicit none
complex(kind=sp_kind), dimension(:,:), intent(in) :: a,b 295 294 complex(kind=sp_kind), dimension(:,:), intent(in) :: a,b
complex(kind=sp_kind), dimension(size(a,1),size(b,2)) :: fvn_op_c_xi 296 295 complex(kind=sp_kind), dimension(size(a,1),size(b,2)) :: fvn_op_c_xi
fvn_op_c_xi=matmul(a,fvn_op_c_matinv(b)) 297 296 fvn_op_c_xi=matmul(a,fvn_op_c_matinv(b))
end function 298 297 end function
function fvn_op_z_xi(a,b) 299 298 function fvn_op_z_xi(a,b)
implicit none 300 299 implicit none
complex(kind=dp_kind), dimension(:,:), intent(in) :: a,b 301 300 complex(kind=dp_kind), dimension(:,:), intent(in) :: a,b
complex(kind=dp_kind), dimension(size(a,1),size(b,2)) :: fvn_op_z_xi 302 301 complex(kind=dp_kind), dimension(size(a,1),size(b,2)) :: fvn_op_z_xi
fvn_op_z_xi=matmul(a,fvn_op_z_matinv(b)) 303 302 fvn_op_z_xi=matmul(a,fvn_op_z_matinv(b))
end function 304 303 end function
305 304
! 306 305 !
! .h. 307 306 ! .h.
! 308 307 !
function fvn_op_c_conj_transpose(a) 309 308 function fvn_op_c_conj_transpose(a)
implicit none 310 309 implicit none
complex(kind=sp_kind),dimension(:,:),intent(in) :: a 311 310 complex(kind=sp_kind),dimension(:,:),intent(in) :: a
complex(kind=sp_kind),dimension(size(a,2),size(a,1)) :: fvn_op_c_conj_transpose 312 311 complex(kind=sp_kind),dimension(size(a,2),size(a,1)) :: fvn_op_c_conj_transpose
fvn_op_c_conj_transpose=transpose(conjg(a)) 313 312 fvn_op_c_conj_transpose=transpose(conjg(a))
end function 314 313 end function
function fvn_op_z_conj_transpose(a) 315 314 function fvn_op_z_conj_transpose(a)
implicit none 316 315 implicit none
complex(kind=dp_kind),dimension(:,:),intent(in) :: a 317 316 complex(kind=dp_kind),dimension(:,:),intent(in) :: a
complex(kind=dp_kind),dimension(size(a,2),size(a,1)) :: fvn_op_z_conj_transpose 318 317 complex(kind=dp_kind),dimension(size(a,2),size(a,1)) :: fvn_op_z_conj_transpose
fvn_op_z_conj_transpose=transpose(conjg(a)) 319 318 fvn_op_z_conj_transpose=transpose(conjg(a))
end function 320 319 end function
321 320
322 321
! 323 322 !
! .hx. 324 323 ! .hx.
! 325 324 !
function fvn_op_c_hx(a,b) 326 325 function fvn_op_c_hx(a,b)
implicit none 327 326 implicit none
complex(kind=sp_kind), dimension(:,:), intent(in) :: a,b 328 327 complex(kind=sp_kind), dimension(:,:), intent(in) :: a,b
complex(kind=sp_kind), dimension(size(a,2),size(b,2)) :: fvn_op_c_hx 329 328 complex(kind=sp_kind), dimension(size(a,2),size(b,2)) :: fvn_op_c_hx
fvn_op_c_hx=matmul(transpose(conjg(a)),b) 330 329 fvn_op_c_hx=matmul(transpose(conjg(a)),b)
end function 331 330 end function
function fvn_op_z_hx(a,b) 332 331 function fvn_op_z_hx(a,b)
implicit none 333 332 implicit none
complex(kind=dp_kind), dimension(:,:), intent(in) :: a,b 334 333 complex(kind=dp_kind), dimension(:,:), intent(in) :: a,b
complex(kind=dp_kind), dimension(size(a,2),size(b,2)) :: fvn_op_z_hx 335 334 complex(kind=dp_kind), dimension(size(a,2),size(b,2)) :: fvn_op_z_hx
fvn_op_z_hx=matmul(transpose(conjg(a)),b) 336 335 fvn_op_z_hx=matmul(transpose(conjg(a)),b)
end function 337 336 end function
338 337
339 338
! 340 339 !
! .xh. 341 340 ! .xh.
! 342 341 !
function fvn_op_c_xh(a,b) 343 342 function fvn_op_c_xh(a,b)
implicit none 344 343 implicit none
complex(kind=sp_kind), dimension(:,:), intent(in) :: a,b 345 344 complex(kind=sp_kind), dimension(:,:), intent(in) :: a,b
complex(kind=sp_kind), dimension(size(a,1),size(b,1)) :: fvn_op_c_xh 346 345 complex(kind=sp_kind), dimension(size(a,1),size(b,1)) :: fvn_op_c_xh
fvn_op_c_xh=matmul(a,transpose(conjg(b))) 347 346 fvn_op_c_xh=matmul(a,transpose(conjg(b)))
end function 348 347 end function
function fvn_op_z_xh(a,b) 349 348 function fvn_op_z_xh(a,b)
implicit none 350 349 implicit none
complex(kind=dp_kind), dimension(:,:), intent(in) :: a,b 351 350 complex(kind=dp_kind), dimension(:,:), intent(in) :: a,b
complex(kind=dp_kind), dimension(size(a,1),size(b,1)) :: fvn_op_z_xh 352 351 complex(kind=dp_kind), dimension(size(a,1),size(b,1)) :: fvn_op_z_xh
fvn_op_z_xh=matmul(a,transpose(conjg(b))) 353 352 fvn_op_z_xh=matmul(a,transpose(conjg(b)))
end function 354 353 end function
355 354
356 355
357 356
358 357
359 358
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 360 359 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 361 360 !
! Identity Matrix 362 361 ! Identity Matrix
! 363 362 !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 364 363 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
function fvn_d_ident(n) 365 364 function fvn_d_ident(n)
implicit none 366 365 implicit none
integer(kind=ip_kind) :: n 367 366 integer(kind=ip_kind) :: n
real(kind=dp_kind), dimension(n,n) :: fvn_d_ident 368 367 real(kind=dp_kind), dimension(n,n) :: fvn_d_ident
369 368
real(kind=dp_kind),dimension(n*n) :: vect 370 369 real(kind=dp_kind),dimension(n*n) :: vect
integer(kind=ip_kind) :: i 371 370 integer(kind=ip_kind) :: i
372 371
vect=0._dp_kind 373 372 vect=0._dp_kind
vect(1:n*n:n+1) = 1._dp_kind 374 373 vect(1:n*n:n+1) = 1._dp_kind
fvn_d_ident=reshape(vect, shape = (/ n,n /)) 375 374 fvn_d_ident=reshape(vect, shape = (/ n,n /))
end function 376 375 end function
377 376
function fvn_s_ident(n) 378 377 function fvn_s_ident(n)
implicit none 379 378 implicit none
integer(kind=ip_kind) :: n 380 379 integer(kind=ip_kind) :: n
real(kind=sp_kind), dimension(n,n) :: fvn_s_ident 381 380 real(kind=sp_kind), dimension(n,n) :: fvn_s_ident
382 381
real(kind=sp_kind),dimension(n*n) :: vect 383 382 real(kind=sp_kind),dimension(n*n) :: vect
integer(kind=ip_kind) :: i 384 383 integer(kind=ip_kind) :: i
385 384
vect=0._sp_kind 386 385 vect=0._sp_kind
vect(1:n*n:n+1) = 1._sp_kind 387 386 vect(1:n*n:n+1) = 1._sp_kind
fvn_s_ident=reshape(vect, shape = (/ n,n /)) 388 387 fvn_s_ident=reshape(vect, shape = (/ n,n /))
end function 389 388 end function
390 389
function fvn_c_ident(n) 391 390 function fvn_c_ident(n)
implicit none 392 391 implicit none
integer(kind=ip_kind) :: n 393 392 integer(kind=ip_kind) :: n
complex(kind=sp_kind), dimension(n,n) :: fvn_c_ident 394 393 complex(kind=sp_kind), dimension(n,n) :: fvn_c_ident
395 394
complex(kind=sp_kind),dimension(n*n) :: vect 396 395 complex(kind=sp_kind),dimension(n*n) :: vect
integer(kind=ip_kind) :: i 397 396 integer(kind=ip_kind) :: i
398 397
vect=(0._sp_kind,0._sp_kind) 399 398 vect=(0._sp_kind,0._sp_kind)
vect(1:n*n:n+1) = (1._sp_kind,0._sp_kind) 400 399 vect(1:n*n:n+1) = (1._sp_kind,0._sp_kind)
fvn_c_ident=reshape(vect, shape = (/ n,n /)) 401 400 fvn_c_ident=reshape(vect, shape = (/ n,n /))
end function 402 401 end function
403 402
function fvn_z_ident(n) 404 403 function fvn_z_ident(n)
implicit none 405 404 implicit none
integer(kind=ip_kind) :: n 406 405 integer(kind=ip_kind) :: n
complex(kind=dp_kind), dimension(n,n) :: fvn_z_ident 407 406 complex(kind=dp_kind), dimension(n,n) :: fvn_z_ident
408 407
complex(kind=dp_kind),dimension(n*n) :: vect 409 408 complex(kind=dp_kind),dimension(n*n) :: vect
integer(kind=ip_kind) :: i 410 409 integer(kind=ip_kind) :: i
411 410
vect=(0._dp_kind,0._dp_kind) 412 411 vect=(0._dp_kind,0._dp_kind)
vect(1:n*n:n+1) = (1._dp_kind,0._dp_kind) 413 412 vect(1:n*n:n+1) = (1._dp_kind,0._dp_kind)
fvn_z_ident=reshape(vect, shape = (/ n,n /)) 414 413 fvn_z_ident=reshape(vect, shape = (/ n,n /))
end function 415 414 end function
416 415
417 416
418 417
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 419 418 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 420 419 !
! Matrix inversion subroutines 421 420 ! Matrix inversion subroutines
! 422 421 !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 423 422 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
424 423
subroutine fvn_s_matinv(d,a,inva,status) 425 424 subroutine fvn_s_matinv(d,a,inva,status)
! 426 425 !
! Matrix inversion of a real(kind=sp_kind) matrix using BLAS and LAPACK 427 426 ! Matrix inversion of a real(kind=sp_kind) matrix using BLAS and LAPACK
! 428 427 !
! d (in) : matrix rank 429 428 ! d (in) : matrix rank
! a (in) : input matrix 430 429 ! a (in) : input matrix
! inva (out) : inversed matrix 431 430 ! inva (out) : inversed matrix
! status (ou) : =0 if something failed 432 431 ! status (ou) : =0 if something failed
! 433 432 !
implicit none 434 433 implicit none
integer(kind=ip_kind), intent(in) :: d 435 434 integer(kind=ip_kind), intent(in) :: d
real(kind=sp_kind), intent(in) :: a(d,d) 436 435 real(kind=sp_kind), intent(in) :: a(d,d)
real(kind=sp_kind), intent(out) :: inva(d,d) 437 436 real(kind=sp_kind), intent(out) :: inva(d,d)
integer(kind=ip_kind), intent(out),optional :: status 438 437 integer(kind=ip_kind), intent(out),optional :: status
439 438
integer(kind=ip_kind), allocatable :: ipiv(:) 440 439 integer(kind=ip_kind), allocatable :: ipiv(:)
real(kind=sp_kind), allocatable :: work(:) 441 440 real(kind=sp_kind), allocatable :: work(:)
real(kind=sp_kind) twork(1) 442 441 real(kind=sp_kind) twork(1)
integer(kind=ip_kind) :: info 443 442 integer(kind=ip_kind) :: info
integer(kind=ip_kind) :: lwork 444 443 integer(kind=ip_kind) :: lwork
445 444
if (present(status)) status=1 446 445 if (present(status)) status=1
447 446
allocate(ipiv(d)) 448 447 allocate(ipiv(d))
! copy a into inva using BLAS 449 448 ! copy a into inva using BLAS
!call scopy(d*d,a,1,inva,1) 450 449 !call scopy(d*d,a,1,inva,1)
inva(:,:)=a(:,:) 451 450 inva(:,:)=a(:,:)
! LU factorization using LAPACK 452 451 ! LU factorization using LAPACK
call sgetrf(d,d,inva,d,ipiv,info) 453 452 call sgetrf(d,d,inva,d,ipiv,info)
! if info is not equal to 0, something went wrong we exit setting status to 0 454 453 ! if info is not equal to 0, something went wrong we exit setting status to 0
if (info /= 0) then 455 454 if (info /= 0) then
if (present(status)) status=0 456 455 if (present(status)) status=0
deallocate(ipiv) 457 456 deallocate(ipiv)
return 458 457 return
end if 459 458 end if
! we use the query fonction of xxxtri to obtain the optimal workspace size 460 459 ! we use the query fonction of xxxtri to obtain the optimal workspace size
call sgetri(d,inva,d,ipiv,twork,-1,info) 461 460 call sgetri(d,inva,d,ipiv,twork,-1,info)
lwork=int(twork(1)) 462 461 lwork=int(twork(1))
allocate(work(lwork)) 463 462 allocate(work(lwork))
! Matrix inversion using LAPACK 464 463 ! Matrix inversion using LAPACK
call sgetri(d,inva,d,ipiv,work,lwork,info) 465 464 call sgetri(d,inva,d,ipiv,work,lwork,info)
! again if info is not equal to 0, we exit setting status to 0 466 465 ! again if info is not equal to 0, we exit setting status to 0
if (info /= 0) then 467 466 if (info /= 0) then
if (present(status)) status=0 468 467 if (present(status)) status=0
end if 469 468 end if
deallocate(work) 470 469 deallocate(work)
deallocate(ipiv) 471 470 deallocate(ipiv)
end subroutine 472 471 end subroutine
473 472
subroutine fvn_d_matinv(d,a,inva,status) 474 473 subroutine fvn_d_matinv(d,a,inva,status)
! 475 474 !
! Matrix inversion of a real(kind=dp_kind) matrix using BLAS and LAPACK 476 475 ! Matrix inversion of a real(kind=dp_kind) matrix using BLAS and LAPACK
! 477 476 !
! d (in) : matrix rank 478 477 ! d (in) : matrix rank
! a (in) : input matrix 479 478 ! a (in) : input matrix
! inva (out) : inversed matrix 480 479 ! inva (out) : inversed matrix
! status (ou) : =0 if something failed 481 480 ! status (ou) : =0 if something failed
! 482 481 !
implicit none 483 482 implicit none
integer(kind=ip_kind), intent(in) :: d 484 483 integer(kind=ip_kind), intent(in) :: d
real(kind=dp_kind), intent(in) :: a(d,d) 485 484 real(kind=dp_kind), intent(in) :: a(d,d)
real(kind=dp_kind), intent(out) :: inva(d,d) 486 485 real(kind=dp_kind), intent(out) :: inva(d,d)
integer(kind=ip_kind), intent(out),optional :: status 487 486 integer(kind=ip_kind), intent(out),optional :: status
488 487
integer(kind=ip_kind), allocatable :: ipiv(:) 489 488 integer(kind=ip_kind), allocatable :: ipiv(:)
real(kind=dp_kind), allocatable :: work(:) 490 489 real(kind=dp_kind), allocatable :: work(:)
real(kind=dp_kind) :: twork(1) 491 490 real(kind=dp_kind) :: twork(1)
integer(kind=ip_kind) :: info 492 491 integer(kind=ip_kind) :: info
integer(kind=ip_kind) :: lwork 493 492 integer(kind=ip_kind) :: lwork
494 493
if (present(status)) status=1 495 494 if (present(status)) status=1
496 495
allocate(ipiv(d)) 497 496 allocate(ipiv(d))
! copy a into inva using BLAS 498 497 ! copy a into inva using BLAS
!call dcopy(d*d,a,1,inva,1) 499 498 !call dcopy(d*d,a,1,inva,1)
inva(:,:)=a(:,:) 500 499 inva(:,:)=a(:,:)
! LU factorization using LAPACK 501 500 ! LU factorization using LAPACK
call dgetrf(d,d,inva,d,ipiv,info) 502 501 call dgetrf(d,d,inva,d,ipiv,info)
! if info is not equal to 0, something went wrong we exit setting status to 0 503 502 ! if info is not equal to 0, something went wrong we exit setting status to 0
if (info /= 0) then 504 503 if (info /= 0) then
if (present(status)) status=0 505 504 if (present(status)) status=0
deallocate(ipiv) 506 505 deallocate(ipiv)
return 507 506 return
end if 508 507 end if
! we use the query fonction of xxxtri to obtain the optimal workspace size 509 508 ! we use the query fonction of xxxtri to obtain the optimal workspace size
call dgetri(d,inva,d,ipiv,twork,-1,info) 510 509 call dgetri(d,inva,d,ipiv,twork,-1,info)
lwork=int(twork(1)) 511 510 lwork=int(twork(1))
allocate(work(lwork)) 512 511 allocate(work(lwork))
! Matrix inversion using LAPACK 513 512 ! Matrix inversion using LAPACK
call dgetri(d,inva,d,ipiv,work,lwork,info) 514 513 call dgetri(d,inva,d,ipiv,work,lwork,info)
! again if info is not equal to 0, we exit setting status to 0 515 514 ! again if info is not equal to 0, we exit setting status to 0
if (info /= 0) then 516 515 if (info /= 0) then
if (present(status)) status=0 517 516 if (present(status)) status=0
end if 518 517 end if
deallocate(work) 519 518 deallocate(work)
deallocate(ipiv) 520 519 deallocate(ipiv)
end subroutine 521 520 end subroutine
522 521
subroutine fvn_c_matinv(d,a,inva,status) 523 522 subroutine fvn_c_matinv(d,a,inva,status)
! 524 523 !
! Matrix inversion of a complex(kind=sp_kind) matrix using BLAS and LAPACK 525 524 ! Matrix inversion of a complex(kind=sp_kind) matrix using BLAS and LAPACK
! 526 525 !
! d (in) : matrix rank 527 526 ! d (in) : matrix rank
! a (in) : input matrix 528 527 ! a (in) : input matrix
! inva (out) : inversed matrix 529 528 ! inva (out) : inversed matrix
! status (ou) : =0 if something failed 530 529 ! status (ou) : =0 if something failed
! 531 530 !
implicit none 532 531 implicit none
integer(kind=ip_kind), intent(in) :: d 533 532 integer(kind=ip_kind), intent(in) :: d
complex(kind=sp_kind), intent(in) :: a(d,d) 534 533 complex(kind=sp_kind), intent(in) :: a(d,d)
complex(kind=sp_kind), intent(out) :: inva(d,d) 535 534 complex(kind=sp_kind), intent(out) :: inva(d,d)
integer(kind=ip_kind), intent(out),optional :: status 536 535 integer(kind=ip_kind), intent(out),optional :: status
537 536
integer(kind=ip_kind), allocatable :: ipiv(:) 538 537 integer(kind=ip_kind), allocatable :: ipiv(:)
complex(kind=sp_kind), allocatable :: work(:) 539 538 complex(kind=sp_kind), allocatable :: work(:)
complex(kind=sp_kind) :: twork(1) 540 539 complex(kind=sp_kind) :: twork(1)
integer(kind=ip_kind) :: info 541 540 integer(kind=ip_kind) :: info
integer(kind=ip_kind) :: lwork 542 541 integer(kind=ip_kind) :: lwork
543 542
if (present(status)) status=1 544 543 if (present(status)) status=1
545 544
allocate(ipiv(d)) 546 545 allocate(ipiv(d))
! copy a into inva using BLAS 547 546 ! copy a into inva using BLAS
!call ccopy(d*d,a,1,inva,1) 548 547 !call ccopy(d*d,a,1,inva,1)
inva(:,:)=a(:,:) 549 548 inva(:,:)=a(:,:)
550 549
! LU factorization using LAPACK 551 550 ! LU factorization using LAPACK
call cgetrf(d,d,inva,d,ipiv,info) 552 551 call cgetrf(d,d,inva,d,ipiv,info)
! if info is not equal to 0, something went wrong we exit setting status to 0 553 552 ! if info is not equal to 0, something went wrong we exit setting status to 0
if (info /= 0) then 554 553 if (info /= 0) then
if (present(status)) status=0 555 554 if (present(status)) status=0
deallocate(ipiv) 556 555 deallocate(ipiv)
return 557 556 return
end if 558 557 end if
! we use the query fonction of xxxtri to obtain the optimal workspace size 559 558 ! we use the query fonction of xxxtri to obtain the optimal workspace size
call cgetri(d,inva,d,ipiv,twork,-1,info) 560 559 call cgetri(d,inva,d,ipiv,twork,-1,info)
lwork=int(twork(1)) 561 560 lwork=int(twork(1))
allocate(work(lwork)) 562 561 allocate(work(lwork))
! Matrix inversion using LAPACK 563 562 ! Matrix inversion using LAPACK
call cgetri(d,inva,d,ipiv,work,lwork,info) 564 563 call cgetri(d,inva,d,ipiv,work,lwork,info)
! again if info is not equal to 0, we exit setting status to 0 565 564 ! again if info is not equal to 0, we exit setting status to 0
if (info /= 0) then 566 565 if (info /= 0) then
if (present(status)) status=0 567 566 if (present(status)) status=0
end if 568 567 end if
deallocate(work) 569 568 deallocate(work)
deallocate(ipiv) 570 569 deallocate(ipiv)
end subroutine 571 570 end subroutine
572 571
subroutine fvn_z_matinv(d,a,inva,status) 573 572 subroutine fvn_z_matinv(d,a,inva,status)
! 574 573 !
! Matrix inversion of a complex(kind=dp_kind)(kind=sp_kind) matrix using BLAS and LAPACK 575 574 ! Matrix inversion of a complex(kind=dp_kind)(kind=sp_kind) matrix using BLAS and LAPACK
! 576 575 !
! d (in) : matrix rank 577 576 ! d (in) : matrix rank
! a (in) : input matrix 578 577 ! a (in) : input matrix
! inva (out) : inversed matrix 579 578 ! inva (out) : inversed matrix
! status (ou) : =0 if something failed 580 579 ! status (ou) : =0 if something failed
! 581 580 !
implicit none 582 581 implicit none
integer(kind=ip_kind), intent(in) :: d 583 582 integer(kind=ip_kind), intent(in) :: d
complex(kind=dp_kind), intent(in) :: a(d,d) 584 583 complex(kind=dp_kind), intent(in) :: a(d,d)
complex(kind=dp_kind), intent(out) :: inva(d,d) 585 584 complex(kind=dp_kind), intent(out) :: inva(d,d)
integer(kind=ip_kind), intent(out),optional :: status 586 585 integer(kind=ip_kind), intent(out),optional :: status
587 586
integer(kind=ip_kind), allocatable :: ipiv(:) 588 587 integer(kind=ip_kind), allocatable :: ipiv(:)
complex(kind=dp_kind), allocatable :: work(:) 589 588 complex(kind=dp_kind), allocatable :: work(:)
complex(kind=dp_kind) :: twork(1) 590 589 complex(kind=dp_kind) :: twork(1)
integer(kind=ip_kind) :: info 591 590 integer(kind=ip_kind) :: info
integer(kind=ip_kind) :: lwork 592 591 integer(kind=ip_kind) :: lwork
593 592
if (present(status)) status=1 594 593 if (present(status)) status=1
595 594
allocate(ipiv(d)) 596 595 allocate(ipiv(d))
! copy a into inva using BLAS 597 596 ! copy a into inva using BLAS
!call zcopy(d*d,a,1,inva,1) 598 597 !call zcopy(d*d,a,1,inva,1)
inva(:,:)=a(:,:) 599 598 inva(:,:)=a(:,:)
600 599
! LU factorization using LAPACK 601 600 ! LU factorization using LAPACK
call zgetrf(d,d,inva,d,ipiv,info) 602 601 call zgetrf(d,d,inva,d,ipiv,info)
! if info is not equal to 0, something went wrong we exit setting status to 0 603 602 ! if info is not equal to 0, something went wrong we exit setting status to 0
if (info /= 0) then 604 603 if (info /= 0) then
if (present(status)) status=0 605 604 if (present(status)) status=0
deallocate(ipiv) 606 605 deallocate(ipiv)
return 607 606 return
end if 608 607 end if
! we use the query fonction of xxxtri to obtain the optimal workspace size 609 608 ! we use the query fonction of xxxtri to obtain the optimal workspace size
call zgetri(d,inva,d,ipiv,twork,-1,info) 610 609 call zgetri(d,inva,d,ipiv,twork,-1,info)
lwork=int(twork(1)) 611 610 lwork=int(twork(1))
allocate(work(lwork)) 612 611 allocate(work(lwork))
! Matrix inversion using LAPACK 613 612 ! Matrix inversion using LAPACK
call zgetri(d,inva,d,ipiv,work,lwork,info) 614 613 call zgetri(d,inva,d,ipiv,work,lwork,info)
! again if info is not equal to 0, we exit setting status to 0 615 614 ! again if info is not equal to 0, we exit setting status to 0
if (info /= 0) then 616 615 if (info /= 0) then
if (present(status)) status=0 617 616 if (present(status)) status=0
end if 618 617 end if
deallocate(work) 619 618 deallocate(work)
deallocate(ipiv) 620 619 deallocate(ipiv)
end subroutine 621 620 end subroutine
622 621
623 622
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 624 623 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 625 624 !
! Determinants 626 625 ! Determinants
! 627 626 !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 628 627 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
function fvn_s_det(d,a,status) 629 628 function fvn_s_det(d,a,status)
! 630 629 !
! Evaluate the determinant of a square matrix using lapack LU factorization 631 630 ! Evaluate the determinant of a square matrix using lapack LU factorization
! 632 631 !
! d (in) : matrix rank 633 632 ! d (in) : matrix rank
! a (in) : The Matrix 634 633 ! a (in) : The Matrix
! status (out) : =0 if LU factorization failed 635 634 ! status (out) : =0 if LU factorization failed
! 636 635 !
implicit none 637 636 implicit none
integer(kind=ip_kind), intent(in) :: d 638 637 integer(kind=ip_kind), intent(in) :: d
real(kind=sp_kind), intent(in) :: a(d,d) 639 638 real(kind=sp_kind), intent(in) :: a(d,d)
integer(kind=ip_kind), intent(out), optional :: status 640 639 integer(kind=ip_kind), intent(out), optional :: status
real(kind=sp_kind) :: fvn_s_det 641 640 real(kind=sp_kind) :: fvn_s_det
642 641
real(kind=sp_kind), allocatable :: wc_a(:,:) 643 642 real(kind=sp_kind), allocatable :: wc_a(:,:)
integer(kind=ip_kind), allocatable :: ipiv(:) 644 643 integer(kind=ip_kind), allocatable :: ipiv(:)
integer(kind=ip_kind) :: info,i 645 644 integer(kind=ip_kind) :: info,i
646 645
if (present(status)) status=1 647 646 if (present(status)) status=1
allocate(wc_a(d,d)) 648 647 allocate(wc_a(d,d))
allocate(ipiv(d)) 649 648 allocate(ipiv(d))
wc_a(:,:)=a(:,:) 650 649 wc_a(:,:)=a(:,:)
call sgetrf(d,d,wc_a,d,ipiv,info) 651 650 call sgetrf(d,d,wc_a,d,ipiv,info)
if (info/= 0) then 652 651 if (info/= 0) then
if (present(status)) status=0 653 652 if (present(status)) status=0
fvn_s_det=0.e0 654 653 fvn_s_det=0.e0
deallocate(ipiv) 655 654 deallocate(ipiv)
deallocate(wc_a) 656 655 deallocate(wc_a)
return 657 656 return
end if 658 657 end if
fvn_s_det=1.e0 659 658 fvn_s_det=1.e0
do i=1,d 660 659 do i=1,d
if (ipiv(i)==i) then 661 660 if (ipiv(i)==i) then
fvn_s_det=fvn_s_det*wc_a(i,i) 662 661 fvn_s_det=fvn_s_det*wc_a(i,i)
else 663 662 else
fvn_s_det=-fvn_s_det*wc_a(i,i) 664 663 fvn_s_det=-fvn_s_det*wc_a(i,i)
end if 665 664 end if
end do 666 665 end do
deallocate(ipiv) 667 666 deallocate(ipiv)
deallocate(wc_a) 668 667 deallocate(wc_a)
669 668
end function 670 669 end function
671 670
function fvn_d_det(d,a,status) 672 671 function fvn_d_det(d,a,status)
! 673 672 !
! Evaluate the determinant of a square matrix using lapack LU factorization 674 673 ! Evaluate the determinant of a square matrix using lapack LU factorization
! 675 674 !
! d (in) : matrix rank 676 675 ! d (in) : matrix rank
! a (in) : The Matrix 677 676 ! a (in) : The Matrix
! status (out) : =0 if LU factorization failed 678 677 ! status (out) : =0 if LU factorization failed
! 679 678 !
implicit none 680 679 implicit none
integer(kind=ip_kind), intent(in) :: d 681 680 integer(kind=ip_kind), intent(in) :: d
real(kind=dp_kind), intent(in) :: a(d,d) 682 681 real(kind=dp_kind), intent(in) :: a(d,d)
integer(kind=ip_kind), intent(out), optional :: status 683 682 integer(kind=ip_kind), intent(out), optional :: status
real(kind=dp_kind) :: fvn_d_det 684 683 real(kind=dp_kind) :: fvn_d_det
685 684
real(kind=dp_kind), allocatable :: wc_a(:,:) 686 685 real(kind=dp_kind), allocatable :: wc_a(:,:)
integer(kind=ip_kind), allocatable :: ipiv(:) 687 686 integer(kind=ip_kind), allocatable :: ipiv(:)
integer(kind=ip_kind) :: info,i 688 687 integer(kind=ip_kind) :: info,i
689 688
if (present(status)) status=1 690 689 if (present(status)) status=1
allocate(wc_a(d,d)) 691 690 allocate(wc_a(d,d))
allocate(ipiv(d)) 692 691 allocate(ipiv(d))
wc_a(:,:)=a(:,:) 693 692 wc_a(:,:)=a(:,:)
call dgetrf(d,d,wc_a,d,ipiv,info) 694 693 call dgetrf(d,d,wc_a,d,ipiv,info)
if (info/= 0) then 695 694 if (info/= 0) then
if (present(status)) status=0 696 695 if (present(status)) status=0
fvn_d_det=0.d0 697 696 fvn_d_det=0.d0
deallocate(ipiv) 698 697 deallocate(ipiv)
deallocate(wc_a) 699 698 deallocate(wc_a)
return 700 699 return
end if 701 700 end if
fvn_d_det=1.d0 702 701 fvn_d_det=1.d0
do i=1,d 703 702 do i=1,d
if (ipiv(i)==i) then 704 703 if (ipiv(i)==i) then
fvn_d_det=fvn_d_det*wc_a(i,i) 705 704 fvn_d_det=fvn_d_det*wc_a(i,i)
else 706 705 else
fvn_d_det=-fvn_d_det*wc_a(i,i) 707 706 fvn_d_det=-fvn_d_det*wc_a(i,i)
end if 708 707 end if
end do 709 708 end do
deallocate(ipiv) 710 709 deallocate(ipiv)
deallocate(wc_a) 711 710 deallocate(wc_a)
712 711
end function 713 712 end function
714 713
function fvn_c_det(d,a,status) ! 715 714 function fvn_c_det(d,a,status) !
! Evaluate the determinant of a square matrix using lapack LU factorization 716 715 ! Evaluate the determinant of a square matrix using lapack LU factorization
! 717 716 !
! d (in) : matrix rank 718 717 ! d (in) : matrix rank
! a (in) : The Matrix 719 718 ! a (in) : The Matrix
! status (out) : =0 if LU factorization failed 720 719 ! status (out) : =0 if LU factorization failed
! 721 720 !
implicit none 722 721 implicit none
integer(kind=ip_kind), intent(in) :: d 723 722 integer(kind=ip_kind), intent(in) :: d
complex(kind=sp_kind), intent(in) :: a(d,d) 724 723 complex(kind=sp_kind), intent(in) :: a(d,d)
integer(kind=ip_kind), intent(out), optional :: status 725 724 integer(kind=ip_kind), intent(out), optional :: status
complex(kind=sp_kind) :: fvn_c_det 726 725 complex(kind=sp_kind) :: fvn_c_det
727 726
complex(kind=sp_kind), allocatable :: wc_a(:,:) 728 727 complex(kind=sp_kind), allocatable :: wc_a(:,:)
integer(kind=ip_kind), allocatable :: ipiv(:) 729 728 integer(kind=ip_kind), allocatable :: ipiv(:)
integer(kind=ip_kind) :: info,i 730 729 integer(kind=ip_kind) :: info,i
731 730
if (present(status)) status=1 732 731 if (present(status)) status=1
allocate(wc_a(d,d)) 733 732 allocate(wc_a(d,d))
allocate(ipiv(d)) 734 733 allocate(ipiv(d))
wc_a(:,:)=a(:,:) 735 734 wc_a(:,:)=a(:,:)
call cgetrf(d,d,wc_a,d,ipiv,info) 736 735 call cgetrf(d,d,wc_a,d,ipiv,info)
if (info/= 0) then 737 736 if (info/= 0) then
if (present(status)) status=0 738 737 if (present(status)) status=0
fvn_c_det=(0.e0,0.e0) 739 738 fvn_c_det=(0.e0,0.e0)
deallocate(ipiv) 740 739 deallocate(ipiv)
deallocate(wc_a) 741 740 deallocate(wc_a)
return 742 741 return
end if 743 742 end if
fvn_c_det=(1.e0,0.e0) 744 743 fvn_c_det=(1.e0,0.e0)
do i=1,d 745 744 do i=1,d
if (ipiv(i)==i) then 746 745 if (ipiv(i)==i) then
fvn_c_det=fvn_c_det*wc_a(i,i) 747 746 fvn_c_det=fvn_c_det*wc_a(i,i)
else 748 747 else
fvn_c_det=-fvn_c_det*wc_a(i,i) 749 748 fvn_c_det=-fvn_c_det*wc_a(i,i)
end if 750 749 end if
end do 751 750 end do
deallocate(ipiv) 752 751 deallocate(ipiv)
deallocate(wc_a) 753 752 deallocate(wc_a)
754 753
end function 755 754 end function
756 755
function fvn_z_det(d,a,status) 757 756 function fvn_z_det(d,a,status)
! 758 757 !
! Evaluate the determinant of a square matrix using lapack LU factorization 759 758 ! Evaluate the determinant of a square matrix using lapack LU factorization
! 760 759 !
! d (in) : matrix rank 761 760 ! d (in) : matrix rank
! a (in) : The Matrix 762 761 ! a (in) : The Matrix
! det (out) : determinant 763 762 ! det (out) : determinant
! status (out) : =0 if LU factorization failed 764 763 ! status (out) : =0 if LU factorization failed
! 765 764 !
implicit none 766 765 implicit none
integer(kind=ip_kind), intent(in) :: d 767 766 integer(kind=ip_kind), intent(in) :: d
complex(kind=dp_kind), intent(in) :: a(d,d) 768 767 complex(kind=dp_kind), intent(in) :: a(d,d)
integer(kind=ip_kind), intent(out), optional :: status 769 768 integer(kind=ip_kind), intent(out), optional :: status
complex(kind=dp_kind) :: fvn_z_det 770 769 complex(kind=dp_kind) :: fvn_z_det
771 770
complex(kind=dp_kind), allocatable :: wc_a(:,:) 772 771 complex(kind=dp_kind), allocatable :: wc_a(:,:)
integer(kind=ip_kind), allocatable :: ipiv(:) 773 772 integer(kind=ip_kind), allocatable :: ipiv(:)
integer(kind=ip_kind) :: info,i 774 773 integer(kind=ip_kind) :: info,i
775 774
if (present(status)) status=1 776 775 if (present(status)) status=1
allocate(wc_a(d,d)) 777 776 allocate(wc_a(d,d))
allocate(ipiv(d)) 778 777 allocate(ipiv(d))
wc_a(:,:)=a(:,:) 779 778 wc_a(:,:)=a(:,:)
call zgetrf(d,d,wc_a,d,ipiv,info) 780 779 call zgetrf(d,d,wc_a,d,ipiv,info)
if (info/= 0) then 781 780 if (info/= 0) then
if (present(status)) status=0 782 781 if (present(status)) status=0
fvn_z_det=(0.d0,0.d0) 783 782 fvn_z_det=(0.d0,0.d0)
deallocate(ipiv) 784 783 deallocate(ipiv)
deallocate(wc_a) 785 784 deallocate(wc_a)
return 786 785 return
end if 787 786 end if
fvn_z_det=(1.d0,0.d0) 788 787 fvn_z_det=(1.d0,0.d0)
do i=1,d 789 788 do i=1,d
if (ipiv(i)==i) then 790 789 if (ipiv(i)==i) then
fvn_z_det=fvn_z_det*wc_a(i,i) 791 790 fvn_z_det=fvn_z_det*wc_a(i,i)
else 792 791 else
fvn_z_det=-fvn_z_det*wc_a(i,i) 793 792 fvn_z_det=-fvn_z_det*wc_a(i,i)
end if 794 793 end if
end do 795 794 end do
deallocate(ipiv) 796 795 deallocate(ipiv)
deallocate(wc_a) 797 796 deallocate(wc_a)
798 797
end function 799 798 end function
800 799
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 801 800 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 802 801 !
! Condition test 803 802 ! Condition test
! 804 803 !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 805 804 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 1-norm 806 805 ! 1-norm
! fonction lapack slange,dlange,clange,zlange pour obtenir la 1-norm 807 806 ! fonction lapack slange,dlange,clange,zlange pour obtenir la 1-norm
! fonction lapack sgecon,dgecon,cgecon,zgecon pour calculer la rcond 808 807 ! fonction lapack sgecon,dgecon,cgecon,zgecon pour calculer la rcond
! 809 808 !
subroutine fvn_s_matcon(d,a,rcond,status) 810 809 subroutine fvn_s_matcon(d,a,rcond,status)
! Matrix condition (reciprocal of condition number) 811 810 ! Matrix condition (reciprocal of condition number)
! 812 811 !
! d (in) : matrix rank 813 812 ! d (in) : matrix rank
! a (in) : The Matrix 814 813 ! a (in) : The Matrix
! rcond (out) : guess what 815 814 ! rcond (out) : guess what
! status (out) : =0 if something went wrong 816 815 ! status (out) : =0 if something went wrong
! 817 816 !
implicit none 818 817 implicit none
integer(kind=ip_kind), intent(in) :: d 819 818 integer(kind=ip_kind), intent(in) :: d
real(kind=sp_kind), intent(in) :: a(d,d) 820 819 real(kind=sp_kind), intent(in) :: a(d,d)
real(kind=sp_kind), intent(out) :: rcond 821 820 real(kind=sp_kind), intent(out) :: rcond
integer(kind=ip_kind), intent(out), optional :: status 822 821 integer(kind=ip_kind), intent(out), optional :: status
823 822
real(kind=sp_kind), allocatable :: work(:) 824 823 real(kind=sp_kind), allocatable :: work(:)
integer(kind=ip_kind), allocatable :: iwork(:) 825 824 integer(kind=ip_kind), allocatable :: iwork(:)
real(kind=sp_kind) :: anorm 826 825 real(kind=sp_kind) :: anorm
real(kind=sp_kind), allocatable :: wc_a(:,:) ! working copy of a 827 826 real(kind=sp_kind), allocatable :: wc_a(:,:) ! working copy of a
integer(kind=ip_kind) :: info 828 827 integer(kind=ip_kind) :: info
integer(kind=ip_kind), allocatable :: ipiv(:) 829 828 integer(kind=ip_kind), allocatable :: ipiv(:)
830 829
real(kind=sp_kind), external :: slange 831 830 real(kind=sp_kind), external :: slange
832 831
833 832
if (present(status)) status=1 834 833 if (present(status)) status=1
835 834
anorm=slange('1',d,d,a,d,work) ! work is unallocated as it is only used when computing infinity norm 836 835 anorm=slange('1',d,d,a,d,work) ! work is unallocated as it is only used when computing infinity norm
837 836
allocate(wc_a(d,d)) 838 837 allocate(wc_a(d,d))
!call scopy(d*d,a,1,wc_a,1) 839 838 !call scopy(d*d,a,1,wc_a,1)
wc_a(:,:)=a(:,:) 840 839 wc_a(:,:)=a(:,:)
841 840
allocate(ipiv(d)) 842 841 allocate(ipiv(d))
call sgetrf(d,d,wc_a,d,ipiv,info) 843 842 call sgetrf(d,d,wc_a,d,ipiv,info)
if (info /= 0) then 844 843 if (info /= 0) then
if (present(status)) status=0 845 844 if (present(status)) status=0
deallocate(ipiv) 846 845 deallocate(ipiv)
deallocate(wc_a) 847 846 deallocate(wc_a)
return 848 847 return
end if 849 848 end if
allocate(work(4*d)) 850 849 allocate(work(4*d))
allocate(iwork(d)) 851 850 allocate(iwork(d))
call sgecon('1',d,wc_a,d,anorm,rcond,work,iwork,info) 852 851 call sgecon('1',d,wc_a,d,anorm,rcond,work,iwork,info)
if (info /= 0) then 853 852 if (info /= 0) then
if (present(status)) status=0 854 853 if (present(status)) status=0
end if 855 854 end if
deallocate(iwork) 856 855 deallocate(iwork)
deallocate(work) 857 856 deallocate(work)
deallocate(ipiv) 858 857 deallocate(ipiv)
deallocate(wc_a) 859 858 deallocate(wc_a)
860 859
end subroutine 861 860 end subroutine
862 861
subroutine fvn_d_matcon(d,a,rcond,status) 863 862 subroutine fvn_d_matcon(d,a,rcond,status)
! Matrix condition (reciprocal of condition number) 864 863 ! Matrix condition (reciprocal of condition number)
! 865 864 !
! d (in) : matrix rank 866 865 ! d (in) : matrix rank
! a (in) : The Matrix 867 866 ! a (in) : The Matrix
! rcond (out) : guess what 868 867 ! rcond (out) : guess what
! status (out) : =0 if something went wrong 869 868 ! status (out) : =0 if something went wrong
! 870 869 !
implicit none 871 870 implicit none
integer(kind=ip_kind), intent(in) :: d 872 871 integer(kind=ip_kind), intent(in) :: d
real(kind=dp_kind), intent(in) :: a(d,d) 873 872 real(kind=dp_kind), intent(in) :: a(d,d)
real(kind=dp_kind), intent(out) :: rcond 874 873 real(kind=dp_kind), intent(out) :: rcond
integer(kind=ip_kind), intent(out), optional :: status 875 874 integer(kind=ip_kind), intent(out), optional :: status
876 875
real(kind=dp_kind), allocatable :: work(:) 877 876 real(kind=dp_kind), allocatable :: work(:)
integer(kind=ip_kind), allocatable :: iwork(:) 878 877 integer(kind=ip_kind), allocatable :: iwork(:)
real(kind=dp_kind) :: anorm 879 878 real(kind=dp_kind) :: anorm
real(kind=dp_kind), allocatable :: wc_a(:,:) ! working copy of a 880 879 real(kind=dp_kind), allocatable :: wc_a(:,:) ! working copy of a
integer(kind=ip_kind) :: info 881 880 integer(kind=ip_kind) :: info
integer(kind=ip_kind), allocatable :: ipiv(:) 882 881 integer(kind=ip_kind), allocatable :: ipiv(:)
883 882
real(kind=dp_kind), external :: dlange 884 883 real(kind=dp_kind), external :: dlange
885 884
886 885
if (present(status)) status=1 887 886 if (present(status)) status=1
888 887
anorm=dlange('1',d,d,a,d,work) ! work is unallocated as it is only used when computing infinity norm 889 888 anorm=dlange('1',d,d,a,d,work) ! work is unallocated as it is only used when computing infinity norm
890 889
allocate(wc_a(d,d)) 891 890 allocate(wc_a(d,d))
!call dcopy(d*d,a,1,wc_a,1) 892 891 !call dcopy(d*d,a,1,wc_a,1)
wc_a(:,:)=a(:,:) 893 892 wc_a(:,:)=a(:,:)
894 893
allocate(ipiv(d)) 895 894 allocate(ipiv(d))
call dgetrf(d,d,wc_a,d,ipiv,info) 896 895 call dgetrf(d,d,wc_a,d,ipiv,info)
if (info /= 0) then 897 896 if (info /= 0) then
if (present(status)) status=0 898 897 if (present(status)) status=0
deallocate(ipiv) 899 898 deallocate(ipiv)
deallocate(wc_a) 900 899 deallocate(wc_a)
return 901 900 return
end if 902 901 end if
903 902
allocate(work(4*d)) 904 903 allocate(work(4*d))
allocate(iwork(d)) 905 904 allocate(iwork(d))
call dgecon('1',d,wc_a,d,anorm,rcond,work,iwork,info) 906 905 call dgecon('1',d,wc_a,d,anorm,rcond,work,iwork,info)
if (info /= 0) then 907 906 if (info /= 0) then
if (present(status)) status=0 908 907 if (present(status)) status=0
end if 909 908 end if
deallocate(iwork) 910 909 deallocate(iwork)
deallocate(work) 911 910 deallocate(work)
deallocate(ipiv) 912 911 deallocate(ipiv)
deallocate(wc_a) 913 912 deallocate(wc_a)
914 913
end subroutine 915 914 end subroutine
916 915
subroutine fvn_c_matcon(d,a,rcond,status) 917 916 subroutine fvn_c_matcon(d,a,rcond,status)
! Matrix condition (reciprocal of condition number) 918 917 ! Matrix condition (reciprocal of condition number)
! 919 918 !
! d (in) : matrix rank 920 919 ! d (in) : matrix rank
! a (in) : The Matrix 921 920 ! a (in) : The Matrix
! rcond (out) : guess what 922 921 ! rcond (out) : guess what
! status (out) : =0 if something went wrong 923 922 ! status (out) : =0 if something went wrong
! 924 923 !
implicit none 925 924 implicit none
integer(kind=ip_kind), intent(in) :: d 926 925 integer(kind=ip_kind), intent(in) :: d
complex(kind=sp_kind), intent(in) :: a(d,d) 927 926 complex(kind=sp_kind), intent(in) :: a(d,d)
real(kind=sp_kind), intent(out) :: rcond 928 927 real(kind=sp_kind), intent(out) :: rcond
integer(kind=ip_kind), intent(out), optional :: status 929 928 integer(kind=ip_kind), intent(out), optional :: status
930 929
real(kind=sp_kind), allocatable :: rwork(:) 931 930 real(kind=sp_kind), allocatable :: rwork(:)
complex(kind=sp_kind), allocatable :: work(:) 932 931 complex(kind=sp_kind), allocatable :: work(:)
integer(kind=ip_kind), allocatable :: iwork(:) 933 932 integer(kind=ip_kind), allocatable :: iwork(:)
real(kind=sp_kind) :: anorm 934 933 real(kind=sp_kind) :: anorm
complex(kind=sp_kind), allocatable :: wc_a(:,:) ! working copy of a 935 934 complex(kind=sp_kind), allocatable :: wc_a(:,:) ! working copy of a
integer(kind=ip_kind) :: info 936 935 integer(kind=ip_kind) :: info
integer(kind=ip_kind), allocatable :: ipiv(:) 937 936 integer(kind=ip_kind), allocatable :: ipiv(:)
938 937
real(kind=sp_kind), external :: clange 939 938 real(kind=sp_kind), external :: clange
940 939
941 940
if (present(status)) status=1 942 941 if (present(status)) status=1
943 942
anorm=clange('1',d,d,a,d,rwork) ! rwork is unallocated as it is only used when computing infinity norm 944 943 anorm=clange('1',d,d,a,d,rwork) ! rwork is unallocated as it is only used when computing infinity norm
945 944
allocate(wc_a(d,d)) 946 945 allocate(wc_a(d,d))
!call ccopy(d*d,a,1,wc_a,1) 947 946 !call ccopy(d*d,a,1,wc_a,1)
wc_a(:,:)=a(:,:) 948 947 wc_a(:,:)=a(:,:)
949 948
allocate(ipiv(d)) 950 949 allocate(ipiv(d))
call cgetrf(d,d,wc_a,d,ipiv,info) 951 950 call cgetrf(d,d,wc_a,d,ipiv,info)
if (info /= 0) then 952 951 if (info /= 0) then
if (present(status)) status=0 953 952 if (present(status)) status=0
deallocate(ipiv) 954 953 deallocate(ipiv)
deallocate(wc_a) 955 954 deallocate(wc_a)
return 956 955 return
end if 957 956 end if
allocate(work(2*d)) 958 957 allocate(work(2*d))
allocate(rwork(2*d)) 959 958 allocate(rwork(2*d))
call cgecon('1',d,wc_a,d,anorm,rcond,work,rwork,info) 960 959 call cgecon('1',d,wc_a,d,anorm,rcond,work,rwork,info)
if (info /= 0) then 961 960 if (info /= 0) then
if (present(status)) status=0 962 961 if (present(status)) status=0
end if 963 962 end if
deallocate(rwork) 964 963 deallocate(rwork)
deallocate(work) 965 964 deallocate(work)
deallocate(ipiv) 966 965 deallocate(ipiv)
deallocate(wc_a) 967 966 deallocate(wc_a)
end subroutine 968 967 end subroutine
969 968
subroutine fvn_z_matcon(d,a,rcond,status) 970 969 subroutine fvn_z_matcon(d,a,rcond,status)
! Matrix condition (reciprocal of condition number) 971 970 ! Matrix condition (reciprocal of condition number)
! 972 971 !
! d (in) : matrix rank 973 972 ! d (in) : matrix rank
! a (in) : The Matrix 974 973 ! a (in) : The Matrix
! rcond (out) : guess what 975 974 ! rcond (out) : guess what
! status (out) : =0 if something went wrong 976 975 ! status (out) : =0 if something went wrong
! 977 976 !
implicit none 978 977 implicit none
integer(kind=ip_kind), intent(in) :: d 979 978 integer(kind=ip_kind), intent(in) :: d
complex(kind=dp_kind), intent(in) :: a(d,d) 980 979 complex(kind=dp_kind), intent(in) :: a(d,d)
real(kind=dp_kind), intent(out) :: rcond 981 980 real(kind=dp_kind), intent(out) :: rcond
integer(kind=ip_kind), intent(out), optional :: status 982 981 integer(kind=ip_kind), intent(out), optional :: status
983 982
complex(kind=dp_kind), allocatable :: work(:) 984 983 complex(kind=dp_kind), allocatable :: work(:)
real(kind=dp_kind), allocatable :: rwork(:) 985 984 real(kind=dp_kind), allocatable :: rwork(:)
real(kind=dp_kind) :: anorm 986 985 real(kind=dp_kind) :: anorm
complex(kind=dp_kind), allocatable :: wc_a(:,:) ! working copy of a 987 986 complex(kind=dp_kind), allocatable :: wc_a(:,:) ! working copy of a
integer(kind=ip_kind) :: info 988 987 integer(kind=ip_kind) :: info
integer(kind=ip_kind), allocatable :: ipiv(:) 989 988 integer(kind=ip_kind), allocatable :: ipiv(:)
990 989
real(kind=dp_kind), external :: zlange 991 990 real(kind=dp_kind), external :: zlange
992 991
993 992
if (present(status)) status=1 994 993 if (present(status)) status=1
995 994
anorm=zlange('1',d,d,a,d,rwork) ! rwork is unallocated as it is only used when computing infinity norm 996 995 anorm=zlange('1',d,d,a,d,rwork) ! rwork is unallocated as it is only used when computing infinity norm
997 996
allocate(wc_a(d,d)) 998 997 allocate(wc_a(d,d))
!call zcopy(d*d,a,1,wc_a,1) 999 998 !call zcopy(d*d,a,1,wc_a,1)
wc_a(:,:)=a(:,:) 1000 999 wc_a(:,:)=a(:,:)
1001 1000
allocate(ipiv(d)) 1002 1001 allocate(ipiv(d))
call zgetrf(d,d,wc_a,d,ipiv,info) 1003 1002 call zgetrf(d,d,wc_a,d,ipiv,info)
if (info /= 0) then 1004 1003 if (info /= 0) then
if (present(status)) status=0 1005 1004 if (present(status)) status=0
deallocate(ipiv) 1006 1005 deallocate(ipiv)
deallocate(wc_a) 1007 1006 deallocate(wc_a)
return 1008 1007 return
end if 1009 1008 end if
1010 1009
allocate(work(2*d)) 1011 1010 allocate(work(2*d))
allocate(rwork(2*d)) 1012 1011 allocate(rwork(2*d))
call zgecon('1',d,wc_a,d,anorm,rcond,work,rwork,info) 1013 1012 call zgecon('1',d,wc_a,d,anorm,rcond,work,rwork,info)
if (info /= 0) then 1014 1013 if (info /= 0) then
if (present(status)) status=0 1015 1014 if (present(status)) status=0
end if 1016 1015 end if
deallocate(rwork) 1017 1016 deallocate(rwork)
deallocate(work) 1018 1017 deallocate(work)
deallocate(ipiv) 1019 1018 deallocate(ipiv)
deallocate(wc_a) 1020 1019 deallocate(wc_a)
end subroutine 1021 1020 end subroutine
1022 1021
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1023 1022 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 1024 1023 !
! Valeurs propres/ Vecteurs propre 1025 1024 ! Valeurs propres/ Vecteurs propre
! 1026 1025 !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1027 1026 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1028 1027
! August 2009 1029 1028 ! August 2009
! William Daniau 1030 1029 ! William Daniau
! Adding sorting of eigenvalues and vectors 1031 1030 ! Adding sorting of eigenvalues and vectors
subroutine fvn_z_sort_eigen(d,v,vec) 1032 1031 subroutine fvn_z_sort_eigen(d,v,vec)
! this routine takes in input : 1033 1032 ! this routine takes in input :
! v : a vector containing unsorted eigenvalues 1034 1033 ! v : a vector containing unsorted eigenvalues
! vec : a matrix where vec(:,j) is the eigenvector corresponding to v(j) 1035 1034 ! vec : a matrix where vec(:,j) is the eigenvector corresponding to v(j)
! 1036 1035 !
! At the end of subroutine the eigenvalues are sorted by decreasing order of 1037 1036 ! At the end of subroutine the eigenvalues are sorted by decreasing order of
! modulus so as the vectors. 1038 1037 ! modulus so as the vectors.
implicit none 1039 1038 implicit none
integer(kind=ip_kind) :: d,i,j 1040 1039 integer(kind=ip_kind) :: d,i,j
complex(kind=dp_kind),dimension(d) :: v 1041 1040 complex(kind=dp_kind),dimension(d) :: v
complex(kind=dp_kind),dimension(d,d) :: vec 1042 1041 complex(kind=dp_kind),dimension(d,d) :: vec
complex(kind=dp_kind) :: cur_v 1043 1042 complex(kind=dp_kind) :: cur_v
complex(kind=dp_kind), dimension(d) :: cur_vec 1044 1043 complex(kind=dp_kind), dimension(d) :: cur_vec
1045 1044
do i=2,d 1046 1045 do i=2,d
cur_v=v(i) 1047 1046 cur_v=v(i)
cur_vec=vec(:,i) 1048 1047 cur_vec=vec(:,i)
j=i-1 1049 1048 j=i-1
do while( (j>=1) .and. (abs(v(j)) < abs(cur_v)) ) 1050 1049 do while( (j>=1) .and. (abs(v(j)) < abs(cur_v)) )
v(j+1)=v(j) 1051 1050 v(j+1)=v(j)
vec(:,j+1)=vec(:,j) 1052 1051 vec(:,j+1)=vec(:,j)
j=j-1 1053 1052 j=j-1
end do 1054 1053 end do
v(j+1)=cur_v 1055 1054 v(j+1)=cur_v
vec(:,j+1)=cur_vec 1056 1055 vec(:,j+1)=cur_vec
end do 1057 1056 end do
1058 1057
end subroutine 1059 1058 end subroutine
1060 1059
subroutine fvn_c_sort_eigen(d,v,vec) 1061 1060 subroutine fvn_c_sort_eigen(d,v,vec)
! this routine takes in input : 1062 1061 ! this routine takes in input :
! v : a vector containing unsorted eigenvalues 1063 1062 ! v : a vector containing unsorted eigenvalues
! vec : a matrix where vec(:,j) is the eigenvector corresponding to v(j) 1064 1063 ! vec : a matrix where vec(:,j) is the eigenvector corresponding to v(j)
! 1065 1064 !
! At the end of subroutine the eigenvalues are sorted by decreasing order of 1066 1065 ! At the end of subroutine the eigenvalues are sorted by decreasing order of
! modulus so as the vectors. 1067 1066 ! modulus so as the vectors.
implicit none 1068 1067 implicit none
integer(kind=ip_kind) :: d,i,j 1069 1068 integer(kind=ip_kind) :: d,i,j
complex(kind=sp_kind),dimension(d) :: v 1070 1069 complex(kind=sp_kind),dimension(d) :: v
complex(kind=sp_kind),dimension(d,d) :: vec 1071 1070 complex(kind=sp_kind),dimension(d,d) :: vec
complex(kind=sp_kind) :: cur_v 1072 1071 complex(kind=sp_kind) :: cur_v
complex(kind=sp_kind), dimension(d) :: cur_vec 1073 1072 complex(kind=sp_kind), dimension(d) :: cur_vec
1074 1073
do i=2,d 1075 1074 do i=2,d
cur_v=v(i) 1076 1075 cur_v=v(i)
cur_vec=vec(:,i) 1077 1076 cur_vec=vec(:,i)
j=i-1 1078 1077 j=i-1
do while( (j>=1) .and. (abs(v(j)) < abs(cur_v)) ) 1079 1078 do while( (j>=1) .and. (abs(v(j)) < abs(cur_v)) )
v(j+1)=v(j) 1080 1079 v(j+1)=v(j)
vec(:,j+1)=vec(:,j) 1081 1080 vec(:,j+1)=vec(:,j)
j=j-1 1082 1081 j=j-1
end do 1083 1082 end do
v(j+1)=cur_v 1084 1083 v(j+1)=cur_v
vec(:,j+1)=cur_vec 1085 1084 vec(:,j+1)=cur_vec
end do 1086 1085 end do
1087 1086
end subroutine 1088 1087 end subroutine
1089 1088
subroutine fvn_s_matev(d,a,evala,eveca,status,sortval) 1090 1089 subroutine fvn_s_matev(d,a,evala,eveca,status,sortval)
! 1091 1090 !
! integer(kind=ip_kind) d (in) : matrice rank 1092 1091 ! integer(kind=ip_kind) d (in) : matrice rank
! real(kind=sp_kind) a(d,d) (in) : The Matrix 1093 1092 ! real(kind=sp_kind) a(d,d) (in) : The Matrix
! complex(kind=sp_kind) evala(d) (out) : eigenvalues 1094 1093 ! complex(kind=sp_kind) evala(d) (out) : eigenvalues
! complex(kind=sp_kind) eveca(d,d) (out) : eveca(:,j) = jth eigenvector 1095 1094 ! complex(kind=sp_kind) eveca(d,d) (out) : eveca(:,j) = jth eigenvector
! integer(kind=ip_kind) (out) : status =0 if something went wrong 1096 1095 ! integer(kind=ip_kind) (out) : status =0 if something went wrong
! 1097 1096 !
! interfacing Lapack routine SGEEV 1098 1097 ! interfacing Lapack routine SGEEV
implicit none 1099 1098 implicit none
integer(kind=ip_kind), intent(in) :: d 1100 1099 integer(kind=ip_kind), intent(in) :: d
real(kind=sp_kind), intent(in) :: a(d,d) 1101 1100 real(kind=sp_kind), intent(in) :: a(d,d)
complex(kind=sp_kind), intent(out) :: evala(d) 1102 1101 complex(kind=sp_kind), intent(out) :: evala(d)
complex(kind=sp_kind), intent(out) :: eveca(d,d) 1103 1102 complex(kind=sp_kind), intent(out) :: eveca(d,d)
integer(kind=ip_kind), intent(out), optional :: status 1104 1103 integer(kind=ip_kind), intent(out), optional :: status
logical(kind=ip_kind), intent(in), optional :: sortval 1105 1104 logical(kind=ip_kind), intent(in), optional :: sortval
1106 1105
real(kind=sp_kind), allocatable :: wc_a(:,:) ! a working copy of a 1107 1106 real(kind=sp_kind), allocatable :: wc_a(:,:) ! a working copy of a
integer(kind=ip_kind) :: info 1108 1107 integer(kind=ip_kind) :: info
integer(kind=ip_kind) :: lwork 1109 1108 integer(kind=ip_kind) :: lwork
real(kind=sp_kind), allocatable :: wr(:),wi(:) 1110 1109 real(kind=sp_kind), allocatable :: wr(:),wi(:)
real(kind=sp_kind) :: vl ! unused but necessary for the call 1111 1110 real(kind=sp_kind) :: vl ! unused but necessary for the call
real(kind=sp_kind), allocatable :: vr(:,:) 1112 1111 real(kind=sp_kind), allocatable :: vr(:,:)
real(kind=sp_kind), allocatable :: work(:) 1113 1112 real(kind=sp_kind), allocatable :: work(:)
real(kind=sp_kind) :: twork(1) 1114 1113 real(kind=sp_kind) :: twork(1)
integer(kind=ip_kind) i 1115 1114 integer(kind=ip_kind) i
integer(kind=ip_kind) j 1116 1115 integer(kind=ip_kind) j
1117 1116
if (present(status)) status=1 1118 1117 if (present(status)) status=1
1119 1118
! making a working copy of a 1120 1119 ! making a working copy of a
allocate(wc_a(d,d)) 1121 1120 allocate(wc_a(d,d))
!call scopy(d*d,a,1,wc_a,1) 1122 1121 !call scopy(d*d,a,1,wc_a,1)
wc_a(:,:)=a(:,:) 1123 1122 wc_a(:,:)=a(:,:)
1124 1123
allocate(wr(d)) 1125 1124 allocate(wr(d))
allocate(wi(d)) 1126 1125 allocate(wi(d))
allocate(vr(d,d)) 1127 1126 allocate(vr(d,d))
! query optimal work size 1128 1127 ! query optimal work size
call sgeev('N','V',d,wc_a,d,wr,wi,vl,1,vr,d,twork,-1,info) 1129 1128 call sgeev('N','V',d,wc_a,d,wr,wi,vl,1,vr,d,twork,-1,info)
lwork=int(twork(1)) 1130 1129 lwork=int(twork(1))
allocate(work(lwork)) 1131 1130 allocate(work(lwork))
call sgeev('N','V',d,wc_a,d,wr,wi,vl,1,vr,d,work,lwork,info) 1132 1131 call sgeev('N','V',d,wc_a,d,wr,wi,vl,1,vr,d,work,lwork,info)
1133 1132
if (info /= 0) then 1134 1133 if (info /= 0) then
if (present(status)) status=0 1135 1134 if (present(status)) status=0
deallocate(work) 1136 1135 deallocate(work)
deallocate(vr) 1137 1136 deallocate(vr)
deallocate(wi) 1138 1137 deallocate(wi)
deallocate(wr) 1139 1138 deallocate(wr)
deallocate(wc_a) 1140 1139 deallocate(wc_a)
return 1141 1140 return
end if 1142 1141 end if
1143 1142
! now fill in the results 1144 1143 ! now fill in the results
i=1 1145 1144 i=1
do while(i<=d) 1146 1145 do while(i<=d)
evala(i)=cmplx(wr(i),wi(i)) 1147 1146 evala(i)=cmplx(wr(i),wi(i))
if (wi(i) == 0.) then ! eigenvalue is real 1148 1147 if (wi(i) == 0.) then ! eigenvalue is real
eveca(:,i)=cmplx(vr(:,i),0.) 1149 1148 eveca(:,i)=cmplx(vr(:,i),0.)
else ! eigenvalue is complex 1150 1149 else ! eigenvalue is complex
evala(i+1)=cmplx(wr(i+1),wi(i+1)) 1151 1150 evala(i+1)=cmplx(wr(i+1),wi(i+1))
eveca(:,i)=cmplx(vr(:,i),vr(:,i+1)) 1152 1151 eveca(:,i)=cmplx(vr(:,i),vr(:,i+1))
eveca(:,i+1)=cmplx(vr(:,i),-vr(:,i+1)) 1153 1152 eveca(:,i+1)=cmplx(vr(:,i),-vr(:,i+1))
i=i+1 1154 1153 i=i+1
end if 1155 1154 end if
i=i+1 1156 1155 i=i+1
enddo 1157 1156 enddo
deallocate(work) 1158 1157 deallocate(work)
deallocate(vr) 1159 1158 deallocate(vr)
deallocate(wi) 1160 1159 deallocate(wi)
deallocate(wr) 1161 1160 deallocate(wr)
deallocate(wc_a) 1162 1161 deallocate(wc_a)
1163 1162
! sorting 1164 1163 ! sorting
if (present(sortval) .and. sortval) then 1165 1164 if (present(sortval) .and. sortval) then
call fvn_c_sort_eigen(d,evala,eveca) 1166 1165 call fvn_c_sort_eigen(d,evala,eveca)
end if 1167 1166 end if
1168 1167
end subroutine 1169 1168 end subroutine
1170 1169
subroutine fvn_d_matev(d,a,evala,eveca,status,sortval) 1171 1170 subroutine fvn_d_matev(d,a,evala,eveca,status,sortval)
! 1172 1171 !
! integer(kind=ip_kind) d (in) : matrice rank 1173 1172 ! integer(kind=ip_kind) d (in) : matrice rank
! real(kind=dp_kind) a(d,d) (in) : The Matrix 1174 1173 ! real(kind=dp_kind) a(d,d) (in) : The Matrix
! complex(kind=dp_kind)(kind=sp_kind) evala(d) (out) : eigenvalues 1175 1174 ! complex(kind=dp_kind)(kind=sp_kind) evala(d) (out) : eigenvalues
! complex(kind=dp_kind)(kind=sp_kind) eveca(d,d) (out) : eveca(:,j) = jth eigenvector 1176 1175 ! complex(kind=dp_kind)(kind=sp_kind) eveca(d,d) (out) : eveca(:,j) = jth eigenvector
! integer(kind=ip_kind) (out) : status =0 if something went wrong 1177 1176 ! integer(kind=ip_kind) (out) : status =0 if something went wrong
! 1178 1177 !
! interfacing Lapack routine DGEEV 1179 1178 ! interfacing Lapack routine DGEEV
implicit none 1180 1179 implicit none
integer(kind=ip_kind), intent(in) :: d 1181 1180 integer(kind=ip_kind), intent(in) :: d
real(kind=dp_kind), intent(in) :: a(d,d) 1182 1181 real(kind=dp_kind), intent(in) :: a(d,d)
complex(kind=dp_kind), intent(out) :: evala(d) 1183 1182 complex(kind=dp_kind), intent(out) :: evala(d)
complex(kind=dp_kind), intent(out) :: eveca(d,d) 1184 1183 complex(kind=dp_kind), intent(out) :: eveca(d,d)
integer(kind=ip_kind), intent(out), optional :: status 1185 1184 integer(kind=ip_kind), intent(out), optional :: status
logical(kind=ip_kind), intent(in), optional :: sortval 1186 1185 logical(kind=ip_kind), intent(in), optional :: sortval
1187 1186
real(kind=dp_kind), allocatable :: wc_a(:,:) ! a working copy of a 1188 1187 real(kind=dp_kind), allocatable :: wc_a(:,:) ! a working copy of a
integer(kind=ip_kind) :: info 1189 1188 integer(kind=ip_kind) :: info
integer(kind=ip_kind) :: lwork 1190 1189 integer(kind=ip_kind) :: lwork
real(kind=dp_kind), allocatable :: wr(:),wi(:) 1191 1190 real(kind=dp_kind), allocatable :: wr(:),wi(:)
real(kind=dp_kind) :: vl ! unused but necessary for the call 1192 1191 real(kind=dp_kind) :: vl ! unused but necessary for the call
real(kind=dp_kind), allocatable :: vr(:,:) 1193 1192 real(kind=dp_kind), allocatable :: vr(:,:)
real(kind=dp_kind), allocatable :: work(:) 1194 1193 real(kind=dp_kind), allocatable :: work(:)
real(kind=dp_kind) :: twork(1) 1195 1194 real(kind=dp_kind) :: twork(1)
integer(kind=ip_kind) i 1196 1195 integer(kind=ip_kind) i
integer(kind=ip_kind) j 1197 1196 integer(kind=ip_kind) j
1198 1197
if (present(status)) status=1 1199 1198 if (present(status)) status=1
1200 1199
! making a working copy of a 1201 1200 ! making a working copy of a
allocate(wc_a(d,d)) 1202 1201 allocate(wc_a(d,d))
!call dcopy(d*d,a,1,wc_a,1) 1203 1202 !call dcopy(d*d,a,1,wc_a,1)
wc_a(:,:)=a(:,:) 1204 1203 wc_a(:,:)=a(:,:)
1205 1204
allocate(wr(d)) 1206 1205 allocate(wr(d))
allocate(wi(d)) 1207 1206 allocate(wi(d))
allocate(vr(d,d)) 1208 1207 allocate(vr(d,d))
! query optimal work size 1209 1208 ! query optimal work size
call dgeev('N','V',d,wc_a,d,wr,wi,vl,1,vr,d,twork,-1,info) 1210 1209 call dgeev('N','V',d,wc_a,d,wr,wi,vl,1,vr,d,twork,-1,info)
lwork=int(twork(1)) 1211 1210 lwork=int(twork(1))
allocate(work(lwork)) 1212 1211 allocate(work(lwork))
call dgeev('N','V',d,wc_a,d,wr,wi,vl,1,vr,d,work,lwork,info) 1213 1212 call dgeev('N','V',d,wc_a,d,wr,wi,vl,1,vr,d,work,lwork,info)
1214 1213
if (info /= 0) then 1215 1214 if (info /= 0) then
if (present(status)) status=0 1216 1215 if (present(status)) status=0
deallocate(work) 1217 1216 deallocate(work)
deallocate(vr) 1218 1217 deallocate(vr)
deallocate(wi) 1219 1218 deallocate(wi)
deallocate(wr) 1220 1219 deallocate(wr)
deallocate(wc_a) 1221 1220 deallocate(wc_a)
return 1222 1221 return
end if 1223 1222 end if
1224 1223
! now fill in the results 1225 1224 ! now fill in the results
i=1 1226 1225 i=1
do while(i<=d) 1227 1226 do while(i<=d)
evala(i)=cmplx(wr(i),wi(i),dp_kind) 1228 1227 evala(i)=cmplx(wr(i),wi(i),dp_kind)
if (wi(i) == 0.) then ! eigenvalue is real 1229 1228 if (wi(i) == 0.) then ! eigenvalue is real
eveca(:,i)=cmplx(vr(:,i),0._dp_kind,dp_kind) 1230 1229 eveca(:,i)=cmplx(vr(:,i),0._dp_kind,dp_kind)
else ! eigenvalue is complex 1231 1230 else ! eigenvalue is complex
evala(i+1)=cmplx(wr(i+1),wi(i+1),dp_kind) 1232 1231 evala(i+1)=cmplx(wr(i+1),wi(i+1),dp_kind)
eveca(:,i)=cmplx(vr(:,i),vr(:,i+1),dp_kind) 1233 1232 eveca(:,i)=cmplx(vr(:,i),vr(:,i+1),dp_kind)
eveca(:,i+1)=cmplx(vr(:,i),-vr(:,i+1),dp_kind) 1234 1233 eveca(:,i+1)=cmplx(vr(:,i),-vr(:,i+1),dp_kind)
i=i+1 1235 1234 i=i+1
end if 1236 1235 end if
i=i+1 1237 1236 i=i+1
enddo 1238 1237 enddo
1239 1238
deallocate(work) 1240 1239 deallocate(work)
deallocate(vr) 1241 1240 deallocate(vr)
deallocate(wi) 1242 1241 deallocate(wi)
deallocate(wr) 1243 1242 deallocate(wr)
deallocate(wc_a) 1244 1243 deallocate(wc_a)
1245 1244
! sorting 1246 1245 ! sorting
if (present(sortval) .and. sortval) then 1247 1246 if (present(sortval) .and. sortval) then
call fvn_z_sort_eigen(d,evala,eveca) 1248 1247 call fvn_z_sort_eigen(d,evala,eveca)
end if 1249 1248 end if
1250 1249
end subroutine 1251 1250 end subroutine
1252 1251
subroutine fvn_c_matev(d,a,evala,eveca,status,sortval) 1253 1252 subroutine fvn_c_matev(d,a,evala,eveca,status,sortval)
! 1254 1253 !
! integer(kind=ip_kind) d (in) : matrice rank 1255 1254 ! integer(kind=ip_kind) d (in) : matrice rank
! complex(kind=sp_kind) a(d,d) (in) : The Matrix 1256 1255 ! complex(kind=sp_kind) a(d,d) (in) : The Matrix
! complex(kind=sp_kind) evala(d) (out) : eigenvalues 1257 1256 ! complex(kind=sp_kind) evala(d) (out) : eigenvalues
! complex(kind=sp_kind) eveca(d,d) (out) : eveca(:,j) = jth eigenvector 1258 1257 ! complex(kind=sp_kind) eveca(d,d) (out) : eveca(:,j) = jth eigenvector
! integer(kind=ip_kind) (out) : status =0 if something went wrong 1259 1258 ! integer(kind=ip_kind) (out) : status =0 if something went wrong
! 1260 1259 !
! interfacing Lapack routine CGEEV 1261 1260 ! interfacing Lapack routine CGEEV
implicit none 1262 1261 implicit none
integer(kind=ip_kind), intent(in) :: d 1263 1262 integer(kind=ip_kind), intent(in) :: d
complex(kind=sp_kind), intent(in) :: a(d,d) 1264 1263 complex(kind=sp_kind), intent(in) :: a(d,d)
complex(kind=sp_kind), intent(out) :: evala(d) 1265 1264 complex(kind=sp_kind), intent(out) :: evala(d)
complex(kind=sp_kind), intent(out) :: eveca(d,d) 1266 1265 complex(kind=sp_kind), intent(out) :: eveca(d,d)
integer(kind=ip_kind), intent(out), optional :: status 1267 1266 integer(kind=ip_kind), intent(out), optional :: status
logical(kind=ip_kind), intent(in), optional :: sortval 1268 1267 logical(kind=ip_kind), intent(in), optional :: sortval
1269 1268
complex(kind=sp_kind), allocatable :: wc_a(:,:) ! a working copy of a 1270 1269 complex(kind=sp_kind), allocatable :: wc_a(:,:) ! a working copy of a
integer(kind=ip_kind) :: info 1271 1270 integer(kind=ip_kind) :: info
integer(kind=ip_kind) :: lwork 1272 1271 integer(kind=ip_kind) :: lwork
complex(kind=sp_kind), allocatable :: work(:) 1273 1272 complex(kind=sp_kind), allocatable :: work(:)
complex(kind=sp_kind) :: twork(1) 1274 1273 complex(kind=sp_kind) :: twork(1)
real(kind=sp_kind), allocatable :: rwork(:) 1275 1274 real(kind=sp_kind), allocatable :: rwork(:)
complex(kind=sp_kind) :: vl ! unused but necessary for the call 1276 1275 complex(kind=sp_kind) :: vl ! unused but necessary for the call
1277 1276
if (present(status)) status=1 1278 1277 if (present(status)) status=1
1279 1278
! making a working copy of a 1280 1279 ! making a working copy of a
allocate(wc_a(d,d)) 1281 1280 allocate(wc_a(d,d))
!call ccopy(d*d,a,1,wc_a,1) 1282 1281 !call ccopy(d*d,a,1,wc_a,1)
wc_a(:,:)=a(:,:) 1283 1282 wc_a(:,:)=a(:,:)
1284 1283
1285 1284
! query optimal work size 1286 1285 ! query optimal work size
call cgeev('N','V',d,wc_a,d,evala,vl,1,eveca,d,twork,-1,rwork,info) 1287 1286 call cgeev('N','V',d,wc_a,d,evala,vl,1,eveca,d,twork,-1,rwork,info)
lwork=int(twork(1)) 1288 1287 lwork=int(twork(1))
allocate(work(lwork)) 1289 1288 allocate(work(lwork))
allocate(rwork(2*d)) 1290 1289 allocate(rwork(2*d))
call cgeev('N','V',d,wc_a,d,evala,vl,1,eveca,d,work,lwork,rwork,info) 1291 1290 call cgeev('N','V',d,wc_a,d,evala,vl,1,eveca,d,work,lwork,rwork,info)
1292 1291
if (info /= 0) then 1293 1292 if (info /= 0) then
if (present(status)) status=0 1294 1293 if (present(status)) status=0
end if 1295 1294 end if
deallocate(rwork) 1296 1295 deallocate(rwork)
deallocate(work) 1297 1296 deallocate(work)
deallocate(wc_a) 1298 1297 deallocate(wc_a)
1299 1298
! sorting 1300 1299 ! sorting
if (present(sortval) .and. sortval) then 1301 1300 if (present(sortval) .and. sortval) then
call fvn_c_sort_eigen(d,evala,eveca) 1302 1301 call fvn_c_sort_eigen(d,evala,eveca)
end if 1303 1302 end if
1304 1303
end subroutine 1305 1304 end subroutine
1306 1305
subroutine fvn_z_matev(d,a,evala,eveca,status,sortval) 1307 1306 subroutine fvn_z_matev(d,a,evala,eveca,status,sortval)
! 1308 1307 !
! integer(kind=ip_kind) d (in) : matrice rank 1309 1308 ! integer(kind=ip_kind) d (in) : matrice rank
! complex(kind=dp_kind)(kind=sp_kind) a(d,d) (in) : The Matrix 1310 1309 ! complex(kind=dp_kind)(kind=sp_kind) a(d,d) (in) : The Matrix
! complex(kind=dp_kind)(kind=sp_kind) evala(d) (out) : eigenvalues 1311 1310 ! complex(kind=dp_kind)(kind=sp_kind) evala(d) (out) : eigenvalues
! complex(kind=dp_kind)(kind=sp_kind) eveca(d,d) (out) : eveca(:,j) = jth eigenvector 1312 1311 ! complex(kind=dp_kind)(kind=sp_kind) eveca(d,d) (out) : eveca(:,j) = jth eigenvector
! integer(kind=ip_kind) (out) : status =0 if something went wrong 1313 1312 ! integer(kind=ip_kind) (out) : status =0 if something went wrong
! 1314 1313 !
! interfacing Lapack routine ZGEEV 1315 1314 ! interfacing Lapack routine ZGEEV
implicit none 1316 1315 implicit none
integer(kind=ip_kind), intent(in) :: d 1317 1316 integer(kind=ip_kind), intent(in) :: d
complex(kind=dp_kind), intent(in) :: a(d,d) 1318 1317 complex(kind=dp_kind), intent(in) :: a(d,d)
complex(kind=dp_kind), intent(out) :: evala(d) 1319 1318 complex(kind=dp_kind), intent(out) :: evala(d)
complex(kind=dp_kind), intent(out) :: eveca(d,d) 1320 1319 complex(kind=dp_kind), intent(out) :: eveca(d,d)
integer(kind=ip_kind), intent(out), optional :: status 1321 1320 integer(kind=ip_kind), intent(out), optional :: status
logical(kind=ip_kind), intent(in), optional :: sortval 1322 1321 logical(kind=ip_kind), intent(in), optional :: sortval
1323 1322
complex(kind=dp_kind), allocatable :: wc_a(:,:) ! a working copy of a 1324 1323 complex(kind=dp_kind), allocatable :: wc_a(:,:) ! a working copy of a
integer(kind=ip_kind) :: info 1325 1324 integer(kind=ip_kind) :: info
integer(kind=ip_kind) :: lwork 1326 1325 integer(kind=ip_kind) :: lwork
complex(kind=dp_kind), allocatable :: work(:) 1327 1326 complex(kind=dp_kind), allocatable :: work(:)
complex(kind=dp_kind) :: twork(1) 1328 1327 complex(kind=dp_kind) :: twork(1)
real(kind=dp_kind), allocatable :: rwork(:) 1329 1328 real(kind=dp_kind), allocatable :: rwork(:)
complex(kind=dp_kind) :: vl ! unused but necessary for the call 1330 1329 complex(kind=dp_kind) :: vl ! unused but necessary for the call
1331 1330
if (present(status)) status=1 1332 1331 if (present(status)) status=1
1333 1332
! making a working copy of a 1334 1333 ! making a working copy of a
allocate(wc_a(d,d)) 1335 1334 allocate(wc_a(d,d))
!call zcopy(d*d,a,1,wc_a,1) 1336 1335 !call zcopy(d*d,a,1,wc_a,1)
wc_a(:,:)=a(:,:) 1337 1336 wc_a(:,:)=a(:,:)
1338 1337
! query optimal work size 1339 1338 ! query optimal work size
call zgeev('N','V',d,wc_a,d,evala,vl,1,eveca,d,twork,-1,rwork,info) 1340 1339 call zgeev('N','V',d,wc_a,d,evala,vl,1,eveca,d,twork,-1,rwork,info)
lwork=int(twork(1)) 1341 1340 lwork=int(twork(1))
allocate(work(lwork)) 1342 1341 allocate(work(lwork))
allocate(rwork(2*d)) 1343 1342 allocate(rwork(2*d))
call zgeev('N','V',d,wc_a,d,evala,vl,1,eveca,d,work,lwork,rwork,info) 1344 1343 call zgeev('N','V',d,wc_a,d,evala,vl,1,eveca,d,work,lwork,rwork,info)
1345 1344
if (info /= 0) then 1346 1345 if (info /= 0) then
if (present(status)) status=0 1347 1346 if (present(status)) status=0
end if 1348 1347 end if
deallocate(rwork) 1349 1348 deallocate(rwork)
deallocate(work) 1350 1349 deallocate(work)
deallocate(wc_a) 1351 1350 deallocate(wc_a)
1352 1351
! sorting 1353 1352 ! sorting
if (present(sortval) .and. sortval) then 1354 1353 if (present(sortval) .and. sortval) then
call fvn_z_sort_eigen(d,evala,eveca) 1355 1354 call fvn_z_sort_eigen(d,evala,eveca)
end if 1356 1355 end if
end subroutine 1357 1356 end subroutine
1358 1357
1359 1358
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1360 1359 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 1361 1360 !
! Least square problem 1362 1361 ! Least square problem
! 1363 1362 !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1364 1363 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 1365 1364 !
! 1366 1365 !
1367 1366
1368 1367
1369 1368
1370 1369
subroutine fvn_d_lspoly(np,x,y,deg,coeff,status) 1371 1370 subroutine fvn_d_lspoly(np,x,y,deg,coeff,status)
! 1372 1371 !
! Least square polynomial fitting 1373 1372 ! Least square polynomial fitting
! 1374 1373 !
! Find the coefficients of the least square polynomial of a given degree 1375 1374 ! Find the coefficients of the least square polynomial of a given degree
! for a set of coordinates. 1376 1375 ! for a set of coordinates.
! 1377 1376 !
! The degree must be lower than the number of points 1378 1377 ! The degree must be lower than the number of points
fvn_sparse/fvn_sparse.f90
Diff comments   View file @ 8d883e8
module fvn_sparse 1 1 module fvn_sparse
use kind_definition 2
use fvn_common 3 2 use fvn_common
implicit none 4 3 implicit none
5 4
! Sparse solving 6 5 ! Sparse solving
interface fvn_sparse_solve 7 6 interface fvn_sparse_solve
module procedure fvn_zl_sparse_solve,fvn_zi_sparse_solve,fvn_dl_sparse_solve,fvn_di_sparse_solve 8 7 module procedure fvn_zl_sparse_solve,fvn_zi_sparse_solve,fvn_dl_sparse_solve,fvn_di_sparse_solve
end interface fvn_sparse_solve 9 8 end interface fvn_sparse_solve
10 9
contains 11 10 contains
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 12 11 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 13 12 !
! SPARSE RESOLUTION 14 13 ! SPARSE RESOLUTION
! 15 14 !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 16 15 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 17 16 !
! Sparse resolution is done by interfaรงing Tim Davi's UMFPACK 18 17 ! Sparse resolution is done by interfaรงing Tim Davi's UMFPACK
! http://www.cise.ufl.edu/research/sparse/SuiteSparse/ 19 18 ! http://www.cise.ufl.edu/research/sparse/SuiteSparse/
! Used packages from SuiteSparse : AMD,UMFPACK,UFconfig 20 19 ! Used packages from SuiteSparse : AMD,UMFPACK,UFconfig
! 21 20 !
! Solve Ax=B using UMFPACK 22 21 ! Solve Ax=B using UMFPACK
! 23 22 !
! Where A is a sparse matrix given in its triplet form 24 23 ! Where A is a sparse matrix given in its triplet form
! T -> non zero elements 25 24 ! T -> non zero elements
! Ti,Tj -> row and column index (1-based) of the given elt 26 25 ! Ti,Tj -> row and column index (1-based) of the given elt
! n : rank of matrix A 27 26 ! n : rank of matrix A
! nz : number of non zero elts 28 27 ! nz : number of non zero elts
! 29 28 !
! fvn_*_sparse_solve 30 29 ! fvn_*_sparse_solve
! * = zl : double complex + integer(kind=dp_kind) 31 30 ! * = zl : double complex + integer(kind=dp_kind)
! * = zi : double complex + integer(kind=sp_kind) 32 31 ! * = zi : double complex + integer(kind=sp_kind)
! 33 32 !
subroutine fvn_zl_sparse_solve(n,nz,T,Ti,Tj,B,x,status) 34 33 subroutine fvn_zl_sparse_solve(n,nz,T,Ti,Tj,B,x,status)
implicit none 35 34 implicit none
integer(kind=dp_kind), intent(in) :: n,nz 36 35 integer(kind=dp_kind), intent(in) :: n,nz
complex(kind=dp_kind),dimension(nz),intent(in) :: T 37 36 complex(kind=dp_kind),dimension(nz),intent(in) :: T
integer(kind=dp_kind),dimension(nz),intent(in) :: Ti,Tj 38 37 integer(kind=dp_kind),dimension(nz),intent(in) :: Ti,Tj
complex(kind=dp_kind),dimension(n),intent(in) :: B 39 38 complex(kind=dp_kind),dimension(n),intent(in) :: B
complex(kind=dp_kind),dimension(n),intent(out) :: x 40 39 complex(kind=dp_kind),dimension(n),intent(out) :: x
integer(kind=dp_kind), intent(out) :: status 41 40 integer(kind=dp_kind), intent(out) :: status
42 41
integer(kind=dp_kind),dimension(:),allocatable :: wTi,wTj 43 42 integer(kind=dp_kind),dimension(:),allocatable :: wTi,wTj
real(kind=dp_kind),dimension(:),allocatable :: Tx,Tz 44 43 real(kind=dp_kind),dimension(:),allocatable :: Tx,Tz
real(kind=dp_kind),dimension(:),allocatable :: Ax,Az 45 44 real(kind=dp_kind),dimension(:),allocatable :: Ax,Az
integer(kind=dp_kind),dimension(:),allocatable :: Ap,Ai 46 45 integer(kind=dp_kind),dimension(:),allocatable :: Ap,Ai
integer(kind=dp_kind) :: symbolic,numeric 47 46 integer(kind=dp_kind) :: symbolic,numeric
real(kind=dp_kind),dimension(:),allocatable :: xx,xz,bx,bz 48 47 real(kind=dp_kind),dimension(:),allocatable :: xx,xz,bx,bz
real(kind=dp_kind),dimension(90) :: info 49 48 real(kind=dp_kind),dimension(90) :: info
real(kind=dp_kind),dimension(20) :: control 50 49 real(kind=dp_kind),dimension(20) :: control
integer(kind=dp_kind) :: sys 51 50 integer(kind=dp_kind) :: sys
52 51
53 52
status=0 54 53 status=0
55 54
! we use a working copy of Ti and Tj to perform 1-based to 0-based translation 56 55 ! we use a working copy of Ti and Tj to perform 1-based to 0-based translation
! Tx and Tz are the real and imaginary parts of T 57 56 ! Tx and Tz are the real and imaginary parts of T
allocate(wTi(nz),wTj(nz)) 58 57 allocate(wTi(nz),wTj(nz))
allocate(Tx(nz),Tz(nz)) 59 58 allocate(Tx(nz),Tz(nz))
Tx=dble(T) 60 59 Tx=dble(T)
Tz=aimag(T) 61 60 Tz=aimag(T)
wTi=Ti-1 62 61 wTi=Ti-1
wTj=Tj-1 63 62 wTj=Tj-1
allocate(Ax(nz),Az(nz)) 64 63 allocate(Ax(nz),Az(nz))
allocate(Ap(n+1),Ai(nz)) 65 64 allocate(Ap(n+1),Ai(nz))
66 65
! perform the triplet to compressed column form -> Ap,Ai,Ax,Az 67 66 ! perform the triplet to compressed column form -> Ap,Ai,Ax,Az
call umfpack_zl_triplet_to_col(n,n,nz,wTi,wTj,Tx,Tz,Ap,Ai,Ax,Az,status) 68 67 call umfpack_zl_triplet_to_col(n,n,nz,wTi,wTj,Tx,Tz,Ap,Ai,Ax,Az,status)
! if status is not zero a problem has occured 69 68 ! if status is not zero a problem has occured
if (status /= 0) then 70 69 if (status /= 0) then
write(*,*) "Problem during umfpack_zl_triplet_to_col" 71 70 write(*,*) "Problem during umfpack_zl_triplet_to_col"
endif 72 71 endif
73 72
! Define defaults control values 74 73 ! Define defaults control values
call umfpack_zl_defaults(control) 75 74 call umfpack_zl_defaults(control)
76 75
! Symbolic analysis 77 76 ! Symbolic analysis
call umfpack_zl_symbolic(n,n,Ap,Ai,Ax,Az,symbolic, control, info) 78 77 call umfpack_zl_symbolic(n,n,Ap,Ai,Ax,Az,symbolic, control, info)
! info(1) should be zero 79 78 ! info(1) should be zero
if (info(1) /= 0) then 80 79 if (info(1) /= 0) then
write(*,*) "Problem during symbolic analysis" 81 80 write(*,*) "Problem during symbolic analysis"
status=info(1) 82 81 status=info(1)
endif 83 82 endif
84 83
! Numerical factorization 85 84 ! Numerical factorization
call umfpack_zl_numeric (Ap, Ai, Ax, Az, symbolic, numeric, control, info) 86 85 call umfpack_zl_numeric (Ap, Ai, Ax, Az, symbolic, numeric, control, info)
! info(1) should be zero 87 86 ! info(1) should be zero
if (info(1) /= 0) then 88 87 if (info(1) /= 0) then
write(*,*) "Problem during numerical factorization" 89 88 write(*,*) "Problem during numerical factorization"
status=info(1) 90 89 status=info(1)
endif 91 90 endif
92 91
! free the C symbolic pointer 93 92 ! free the C symbolic pointer
call umfpack_zl_free_symbolic (symbolic) 94 93 call umfpack_zl_free_symbolic (symbolic)
95 94
allocate(bx(n),bz(n),xx(n),xz(n)) 96 95 allocate(bx(n),bz(n),xx(n),xz(n))
bx=dble(B) 97 96 bx=dble(B)
bz=aimag(B) 98 97 bz=aimag(B)
sys=0 99 98 sys=0
! sys may be used to define type of solving -> see umfpack.h 100 99 ! sys may be used to define type of solving -> see umfpack.h
101 100
! Solving 102 101 ! Solving
call umfpack_zl_solve (sys, Ap, Ai, Ax,Az, xx,xz, bx,bz, numeric, control, info) 103 102 call umfpack_zl_solve (sys, Ap, Ai, Ax,Az, xx,xz, bx,bz, numeric, control, info)
! info(1) should be zero 104 103 ! info(1) should be zero
if (info(1) /= 0) then 105 104 if (info(1) /= 0) then
write(*,*) "Problem during solving" 106 105 write(*,*) "Problem during solving"
status=info(1) 107 106 status=info(1)
endif 108 107 endif
109 108
110 109
! free the C numeric pointer 111 110 ! free the C numeric pointer
call umfpack_zl_free_numeric (numeric) 112 111 call umfpack_zl_free_numeric (numeric)
113 112
x=cmplx(xx,xz,dp_kind) 114 113 x=cmplx(xx,xz,dp_kind)
115 114
deallocate(bx,bz,xx,xz) 116 115 deallocate(bx,bz,xx,xz)
deallocate(Ax,Az) 117 116 deallocate(Ax,Az)
deallocate(Tx,Tz) 118 117 deallocate(Tx,Tz)
deallocate(wTi,wTj) 119 118 deallocate(wTi,wTj)
end subroutine 120 119 end subroutine
121 120
122 121
123 122
124 123
125 124
subroutine fvn_zi_sparse_solve(n,nz,T,Ti,Tj,B,x,status) 126 125 subroutine fvn_zi_sparse_solve(n,nz,T,Ti,Tj,B,x,status)
implicit none 127 126 implicit none
integer(kind=sp_kind), intent(in) :: n,nz 128 127 integer(kind=sp_kind), intent(in) :: n,nz
complex(kind=dp_kind),dimension(nz),intent(in) :: T 129 128 complex(kind=dp_kind),dimension(nz),intent(in) :: T
integer(kind=sp_kind),dimension(nz),intent(in) :: Ti,Tj 130 129 integer(kind=sp_kind),dimension(nz),intent(in) :: Ti,Tj
complex(kind=dp_kind),dimension(n),intent(in) :: B 131 130 complex(kind=dp_kind),dimension(n),intent(in) :: B
complex(kind=dp_kind),dimension(n),intent(out) :: x 132 131 complex(kind=dp_kind),dimension(n),intent(out) :: x
integer(kind=sp_kind), intent(out) :: status 133 132 integer(kind=sp_kind), intent(out) :: status
134 133
integer(kind=sp_kind),dimension(:),allocatable :: wTi,wTj 135 134 integer(kind=sp_kind),dimension(:),allocatable :: wTi,wTj
real(kind=dp_kind),dimension(:),allocatable :: Tx,Tz 136 135 real(kind=dp_kind),dimension(:),allocatable :: Tx,Tz
real(kind=dp_kind),dimension(:),allocatable :: Ax,Az 137 136 real(kind=dp_kind),dimension(:),allocatable :: Ax,Az
integer(kind=sp_kind),dimension(:),allocatable :: Ap,Ai 138 137 integer(kind=sp_kind),dimension(:),allocatable :: Ap,Ai
!integer(kind=dp_kind) :: symbolic,numeric 139 138 !integer(kind=dp_kind) :: symbolic,numeric
integer(kind=sp_kind),dimension(2) :: symbolic,numeric 140 139 integer(kind=sp_kind),dimension(2) :: symbolic,numeric
! As symbolic and numeric are used to store a C pointer, it is necessary to 141 140 ! As symbolic and numeric are used to store a C pointer, it is necessary to
! still use an integer(kind=dp_kind) for 64bits machines 142 141 ! still use an integer(kind=dp_kind) for 64bits machines
! An other possibility : integer(kind=sp_kind),dimension(2) :: symbolic,numeric 143 142 ! An other possibility : integer(kind=sp_kind),dimension(2) :: symbolic,numeric
real(kind=dp_kind),dimension(:),allocatable :: xx,xz,bx,bz 144 143 real(kind=dp_kind),dimension(:),allocatable :: xx,xz,bx,bz
real(kind=dp_kind),dimension(90) :: info 145 144 real(kind=dp_kind),dimension(90) :: info
real(kind=dp_kind),dimension(20) :: control 146 145 real(kind=dp_kind),dimension(20) :: control
integer(kind=sp_kind) :: sys 147 146 integer(kind=sp_kind) :: sys
148 147
status=0 149 148 status=0
! we use a working copy of Ti and Tj to perform 1-based to 0-based translation 150 149 ! we use a working copy of Ti and Tj to perform 1-based to 0-based translation
! Tx and Tz are the real and imaginary parts of T 151 150 ! Tx and Tz are the real and imaginary parts of T
allocate(wTi(nz),wTj(nz)) 152 151 allocate(wTi(nz),wTj(nz))
allocate(Tx(nz),Tz(nz)) 153 152 allocate(Tx(nz),Tz(nz))
Tx=dble(T) 154 153 Tx=dble(T)
Tz=aimag(T) 155 154 Tz=aimag(T)
wTi=Ti-1 156 155 wTi=Ti-1
wTj=Tj-1 157 156 wTj=Tj-1
allocate(Ax(nz),Az(nz)) 158 157 allocate(Ax(nz),Az(nz))
allocate(Ap(n+1),Ai(nz)) 159 158 allocate(Ap(n+1),Ai(nz))
160 159
! perform the triplet to compressed column form -> Ap,Ai,Ax,Az 161 160 ! perform the triplet to compressed column form -> Ap,Ai,Ax,Az
call umfpack_zi_triplet_to_col(n,n,nz,wTi,wTj,Tx,Tz,Ap,Ai,Ax,Az,status) 162 161 call umfpack_zi_triplet_to_col(n,n,nz,wTi,wTj,Tx,Tz,Ap,Ai,Ax,Az,status)
! if status is not zero a problem has occured 163 162 ! if status is not zero a problem has occured
if (status /= 0) then 164 163 if (status /= 0) then
write(*,*) "Problem during umfpack_zl_triplet_to_col" 165 164 write(*,*) "Problem during umfpack_zl_triplet_to_col"
endif 166 165 endif
167 166
! Define defaults control values 168 167 ! Define defaults control values
call umfpack_zi_defaults(control) 169 168 call umfpack_zi_defaults(control)
170 169
! Symbolic analysis 171 170 ! Symbolic analysis
call umfpack_zi_symbolic(n,n,Ap,Ai,Ax,Az,symbolic, control, info) 172 171 call umfpack_zi_symbolic(n,n,Ap,Ai,Ax,Az,symbolic, control, info)
! info(1) should be zero 173 172 ! info(1) should be zero
if (info(1) /= 0) then 174 173 if (info(1) /= 0) then
write(*,*) "Problem during symbolic analysis" 175 174 write(*,*) "Problem during symbolic analysis"
status=info(1) 176 175 status=info(1)
endif 177 176 endif
178 177
! Numerical factorization 179 178 ! Numerical factorization
call umfpack_zi_numeric (Ap, Ai, Ax, Az, symbolic, numeric, control, info) 180 179 call umfpack_zi_numeric (Ap, Ai, Ax, Az, symbolic, numeric, control, info)
! info(1) should be zero 181 180 ! info(1) should be zero
if (info(1) /= 0) then 182 181 if (info(1) /= 0) then
write(*,*) "Problem during numerical factorization" 183 182 write(*,*) "Problem during numerical factorization"
status=info(1) 184 183 status=info(1)
endif 185 184 endif
186 185
! free the C symbolic pointer 187 186 ! free the C symbolic pointer
call umfpack_zi_free_symbolic (symbolic) 188 187 call umfpack_zi_free_symbolic (symbolic)
189 188
allocate(bx(n),bz(n),xx(n),xz(n)) 190 189 allocate(bx(n),bz(n),xx(n),xz(n))
bx=dble(B) 191 190 bx=dble(B)
bz=aimag(B) 192 191 bz=aimag(B)
sys=0 193 192 sys=0
! sys may be used to define type of solving -> see umfpack.h 194 193 ! sys may be used to define type of solving -> see umfpack.h
195 194
! Solving 196 195 ! Solving
call umfpack_zi_solve (sys, Ap, Ai, Ax,Az, xx,xz, bx,bz, numeric, control, info) 197 196 call umfpack_zi_solve (sys, Ap, Ai, Ax,Az, xx,xz, bx,bz, numeric, control, info)
! info(1) should be zero 198 197 ! info(1) should be zero
if (info(1) /= 0) then 199 198 if (info(1) /= 0) then
write(*,*) "Problem during solving" 200 199 write(*,*) "Problem during solving"
status=info(1) 201 200 status=info(1)
endif 202 201 endif
203 202
! free the C numeric pointer 204 203 ! free the C numeric pointer
call umfpack_zi_free_numeric (numeric) 205 204 call umfpack_zi_free_numeric (numeric)
206 205
x=cmplx(xx,xz,dp_kind) 207 206 x=cmplx(xx,xz,dp_kind)
208 207
deallocate(bx,bz,xx,xz) 209 208 deallocate(bx,bz,xx,xz)
deallocate(Ax,Az) 210 209 deallocate(Ax,Az)
deallocate(Tx,Tz) 211 210 deallocate(Tx,Tz)
deallocate(wTi,wTj) 212 211 deallocate(wTi,wTj)
end subroutine 213 212 end subroutine
214 213
215 214
216 215
217 216
218 217
219 218
subroutine fvn_dl_sparse_solve(n,nz,T,Ti,Tj,B,x,status) 220 219 subroutine fvn_dl_sparse_solve(n,nz,T,Ti,Tj,B,x,status)
implicit none 221 220 implicit none
integer(kind=dp_kind), intent(in) :: n,nz 222 221 integer(kind=dp_kind), intent(in) :: n,nz
real(kind=dp_kind),dimension(nz),intent(in) :: T 223 222 real(kind=dp_kind),dimension(nz),intent(in) :: T
integer(kind=dp_kind),dimension(nz),intent(in) :: Ti,Tj 224 223 integer(kind=dp_kind),dimension(nz),intent(in) :: Ti,Tj
real(kind=dp_kind),dimension(n),intent(in) :: B 225 224 real(kind=dp_kind),dimension(n),intent(in) :: B
real(kind=dp_kind),dimension(n),intent(out) :: x 226 225 real(kind=dp_kind),dimension(n),intent(out) :: x
integer(kind=dp_kind), intent(out) :: status 227 226 integer(kind=dp_kind), intent(out) :: status
228 227
integer(kind=dp_kind),dimension(:),allocatable :: wTi,wTj 229 228 integer(kind=dp_kind),dimension(:),allocatable :: wTi,wTj
real(kind=dp_kind),dimension(:),allocatable :: A 230 229 real(kind=dp_kind),dimension(:),allocatable :: A
integer(kind=dp_kind),dimension(:),allocatable :: Ap,Ai 231 230 integer(kind=dp_kind),dimension(:),allocatable :: Ap,Ai
!integer(kind=dp_kind) :: symbolic,numeric 232 231 !integer(kind=dp_kind) :: symbolic,numeric
integer(kind=dp_kind) :: symbolic,numeric 233 232 integer(kind=dp_kind) :: symbolic,numeric
real(kind=dp_kind),dimension(90) :: info 234 233 real(kind=dp_kind),dimension(90) :: info
real(kind=dp_kind),dimension(20) :: control 235 234 real(kind=dp_kind),dimension(20) :: control
integer(kind=dp_kind) :: sys 236 235 integer(kind=dp_kind) :: sys
237 236
status=0 238 237 status=0
! we use a working copy of Ti and Tj to perform 1-based to 0-based translation 239 238 ! we use a working copy of Ti and Tj to perform 1-based to 0-based translation
allocate(wTi(nz),wTj(nz)) 240 239 allocate(wTi(nz),wTj(nz))
wTi=Ti-1 241 240 wTi=Ti-1
wTj=Tj-1 242 241 wTj=Tj-1
allocate(A(nz)) 243 242 allocate(A(nz))
allocate(Ap(n+1),Ai(nz)) 244 243 allocate(Ap(n+1),Ai(nz))
245 244
! perform the triplet to compressed column form -> Ap,Ai,Ax,Az 246 245 ! perform the triplet to compressed column form -> Ap,Ai,Ax,Az
call umfpack_dl_triplet_to_col(n,n,nz,wTi,wTj,T,Ap,Ai,A,status) 247 246 call umfpack_dl_triplet_to_col(n,n,nz,wTi,wTj,T,Ap,Ai,A,status)
! if status is not zero a problem has occured 248 247 ! if status is not zero a problem has occured
if (status /= 0) then 249 248 if (status /= 0) then
write(*,*) "Problem during umfpack_dl_triplet_to_col" 250 249 write(*,*) "Problem during umfpack_dl_triplet_to_col"
endif 251 250 endif
252 251
! Define defaults control values 253 252 ! Define defaults control values
call umfpack_dl_defaults(control) 254 253 call umfpack_dl_defaults(control)
255 254
! Symbolic analysis 256 255 ! Symbolic analysis
call umfpack_dl_symbolic(n,n,Ap,Ai,A,symbolic, control, info) 257 256 call umfpack_dl_symbolic(n,n,Ap,Ai,A,symbolic, control, info)
! info(1) should be zero 258 257 ! info(1) should be zero
if (info(1) /= 0) then 259 258 if (info(1) /= 0) then
write(*,*) "Problem during symbolic analysis" 260 259 write(*,*) "Problem during symbolic analysis"
status=info(1) 261 260 status=info(1)
endif 262 261 endif
263 262
! Numerical factorization 264 263 ! Numerical factorization
call umfpack_dl_numeric (Ap, Ai, A, symbolic, numeric, control, info) 265 264 call umfpack_dl_numeric (Ap, Ai, A, symbolic, numeric, control, info)
! info(1) should be zero 266 265 ! info(1) should be zero
if (info(1) /= 0) then 267 266 if (info(1) /= 0) then
write(*,*) "Problem during numerical factorization" 268 267 write(*,*) "Problem during numerical factorization"
status=info(1) 269 268 status=info(1)
endif 270 269 endif
271 270
! free the C symbolic pointer 272 271 ! free the C symbolic pointer
call umfpack_dl_free_symbolic (symbolic) 273 272 call umfpack_dl_free_symbolic (symbolic)
274 273
sys=0 275 274 sys=0
! sys may be used to define type of solving -> see umfpack.h 276 275 ! sys may be used to define type of solving -> see umfpack.h
277 276
! Solving 278 277 ! Solving
call umfpack_dl_solve (sys, Ap, Ai, A, x, B, numeric, control, info) 279 278 call umfpack_dl_solve (sys, Ap, Ai, A, x, B, numeric, control, info)
! info(1) should be zero 280 279 ! info(1) should be zero
if (info(1) /= 0) then 281 280 if (info(1) /= 0) then
write(*,*) "Problem during solving" 282 281 write(*,*) "Problem during solving"
status=info(1) 283 282 status=info(1)
endif 284 283 endif
285 284
! free the C numeric pointer 286 285 ! free the C numeric pointer
call umfpack_dl_free_numeric (numeric) 287 286 call umfpack_dl_free_numeric (numeric)
288 287
deallocate(A) 289 288 deallocate(A)
deallocate(wTi,wTj) 290 289 deallocate(wTi,wTj)
end subroutine 291 290 end subroutine
292 291
293 292
294 293
295 294
296 295
297 296
subroutine fvn_di_sparse_solve(n,nz,T,Ti,Tj,B,x,status) 298 297 subroutine fvn_di_sparse_solve(n,nz,T,Ti,Tj,B,x,status)
implicit none 299 298 implicit none
integer(kind=sp_kind), intent(in) :: n,nz 300 299 integer(kind=sp_kind), intent(in) :: n,nz
real(kind=dp_kind),dimension(nz),intent(in) :: T 301 300 real(kind=dp_kind),dimension(nz),intent(in) :: T
integer(kind=sp_kind),dimension(nz),intent(in) :: Ti,Tj 302 301 integer(kind=sp_kind),dimension(nz),intent(in) :: Ti,Tj
real(kind=dp_kind),dimension(n),intent(in) :: B 303 302 real(kind=dp_kind),dimension(n),intent(in) :: B
real(kind=dp_kind),dimension(n),intent(out) :: x 304 303 real(kind=dp_kind),dimension(n),intent(out) :: x
integer(kind=sp_kind), intent(out) :: status 305 304 integer(kind=sp_kind), intent(out) :: status
fvn_test/test_akima.f90
Diff comments   View file @ 8d883e8
program akima 1 1 program akima
use fvn_interpol 2 2 use fvn_interpol
use Kind_Definition 3
implicit none 4 3 implicit none
integer :: nbpoints,nppoints,i 5 4 integer :: nbpoints,nppoints,i
real(kind=dp_kind),dimension(:),allocatable :: x_d,y_d,breakpoints_d 6 5 real(kind=dp_kind),dimension(:),allocatable :: x_d,y_d,breakpoints_d
real(kind=dp_kind),dimension(:,:),allocatable :: coeff_fvn_d 7 6 real(kind=dp_kind),dimension(:,:),allocatable :: coeff_fvn_d
real(kind=dp_kind) :: xstep_d,xp_d,ty_d,fvn_y_d 8 7 real(kind=dp_kind) :: xstep_d,xp_d,ty_d,fvn_y_d
open(2,file='fvn_akima_double.dat') 9 8 open(2,file='fvn_akima_double.dat')
open(3,file='fvn_akima_breakpoints_double.dat') 10 9 open(3,file='fvn_akima_breakpoints_double.dat')
nbpoints=30 11 10 nbpoints=30
allocate(x_d(nbpoints)) 12 11 allocate(x_d(nbpoints))
allocate(y_d(nbpoints)) 13 12 allocate(y_d(nbpoints))
allocate(breakpoints_d(nbpoints)) 14 13 allocate(breakpoints_d(nbpoints))
allocate(coeff_fvn_d(4,nbpoints)) 15 14 allocate(coeff_fvn_d(4,nbpoints))
xstep_d=20./real(nbpoints,dp_kind) 16 15 xstep_d=20./real(nbpoints,dp_kind)
do i=1,nbpoints 17 16 do i=1,nbpoints
x_d(i)=-10.+real(i,dp_kind)*xstep_d 18 17 x_d(i)=-10.+real(i,dp_kind)*xstep_d
y_d(i)=dsin(x_d(i)) 19 18 y_d(i)=dsin(x_d(i))
write(3,44) x_d(i),y_d(i) 20 19 write(3,44) x_d(i),y_d(i)
end do 21 20 end do
close(3) 22 21 close(3)
call fvn_akima(nbpoints,x_d,y_d,breakpoints_d,coeff_fvn_d) 23 22 call fvn_akima(nbpoints,x_d,y_d,breakpoints_d,coeff_fvn_d)
nppoints=1000 24 23 nppoints=1000
xstep_d=22./real(nppoints,dp_kind) 25 24 xstep_d=22./real(nppoints,dp_kind)
do i=1,nppoints 26 25 do i=1,nppoints
xp_d=-11.+real(i,dp_kind)*xstep_d 27 26 xp_d=-11.+real(i,dp_kind)*xstep_d
ty_d=dsin(xp_d) 28 27 ty_d=dsin(xp_d)
fvn_y_d=fvn_spline_eval(xp_d,nbpoints-1,breakpoints_d,coeff_fvn_d) 29 28 fvn_y_d=fvn_spline_eval(xp_d,nbpoints-1,breakpoints_d,coeff_fvn_d)
write(2,44) xp_d,ty_d,fvn_y_d 30 29 write(2,44) xp_d,ty_d,fvn_y_d
end do 31 30 end do
close(2) 32 31 close(2)
deallocate(coeff_fvn_d,breakpoints_d,y_d,x_d) 33 32 deallocate(coeff_fvn_d,breakpoints_d,y_d,x_d)
write(6,*) "All done, plot results with gnuplot using command :" 34 33 write(6,*) "All done, plot results with gnuplot using command :"
write(6,*) "pl 'fvn_akima_double.dat' u 1:2 w l,'fvn_akima_breakpoints_double.dat' w p" 35 34 write(6,*) "pl 'fvn_akima_double.dat' u 1:2 w l,'fvn_akima_breakpoints_double.dat' w p"
36 35
44 FORMAT(4(1X,1PE22.14)) 37 36 44 FORMAT(4(1X,1PE22.14))
fvn_test/test_bsin.f90
Diff comments   View file @ 8d883e8
program test_bsin 1 1 program test_bsin
use fvn_fnlib 2 2 use fvn_fnlib
use Kind_Definition 3
implicit none 4 3 implicit none
integer :: n,npoints,i 5 4 integer :: n,npoints,i
real(kind=sp_kind) :: xmin,xmax,xstep,x,y 6 5 real(kind=sp_kind) :: xmin,xmax,xstep,x,y
real(kind=sp_kind),dimension(200,0:5) :: bes 7 6 real(kind=sp_kind),dimension(200,0:5) :: bes
8 7
open(2,file='bsin.dat') 9 8 open(2,file='bsin.dat')
10 9
xmin=-5. 11 10 xmin=-5.
xmax=5. 12 11 xmax=5.
npoints=200 13 12 npoints=200
xstep=(xmax-xmin)/dble(npoints) 14 13 xstep=(xmax-xmin)/dble(npoints)
do i=1,npoints 15 14 do i=1,npoints
x=xmin+i*xstep 16 15 x=xmin+i*xstep
do n=0,5 17 16 do n=0,5
bes(i,n)=bsin(n,x) 18 17 bes(i,n)=bsin(n,x)
end do 19 18 end do
write(2,'(7e22.14)') x,bes(i,0:5) 20 19 write(2,'(7e22.14)') x,bes(i,0:5)
end do 21 20 end do
fvn_test/test_bsjn.f90
Diff comments   View file @ 8d883e8
program test_bsjn 1 1 program test_bsjn
use fvn_fnlib 2 2 use fvn_fnlib
use Kind_Definition 3
implicit none 4 3 implicit none
integer :: n,npoints,i 5 4 integer :: n,npoints,i
real(kind=sp_kind) :: xmin,xmax,xstep,x,y 6 5 real(kind=sp_kind) :: xmin,xmax,xstep,x,y
real(kind=sp_kind),dimension(200,0:5) :: bes 7 6 real(kind=sp_kind),dimension(200,0:5) :: bes
8 7
open(2,file='bsjn.dat') 9 8 open(2,file='bsjn.dat')
10 9
xmin=-20. 11 10 xmin=-20.
xmax=20. 12 11 xmax=20.
npoints=200 13 12 npoints=200
xstep=(xmax-xmin)/dble(npoints) 14 13 xstep=(xmax-xmin)/dble(npoints)
do i=1,npoints 15 14 do i=1,npoints
x=xmin+i*xstep 16 15 x=xmin+i*xstep
do n=0,5 17 16 do n=0,5
bes(i,n)=bsjn(n,x) 18 17 bes(i,n)=bsjn(n,x)
end do 19 18 end do
write(2,'(7e22.14)') x,bes(i,0:5) 20 19 write(2,'(7e22.14)') x,bes(i,0:5)
end do 21 20 end do
fvn_test/test_bskn.f90
Diff comments   View file @ 8d883e8
program test_bskn 1 1 program test_bskn
use fvn_fnlib 2 2 use fvn_fnlib
use Kind_Definition 3
implicit none 4 3 implicit none
integer :: n,npoints,i 5 4 integer :: n,npoints,i
real(kind=sp_kind) :: xmin,xmax,xstep,x,y 6 5 real(kind=sp_kind) :: xmin,xmax,xstep,x,y
real(kind=sp_kind),dimension(200,0:5) :: bes 7 6 real(kind=sp_kind),dimension(200,0:5) :: bes
8 7
open(2,file='bskn.dat') 9 8 open(2,file='bskn.dat')
10 9
xmin=0. 11 10 xmin=0.
xmax=10. 12 11 xmax=10.
npoints=200 13 12 npoints=200
xstep=(xmax-xmin)/dble(npoints) 14 13 xstep=(xmax-xmin)/dble(npoints)
do i=1,npoints 15 14 do i=1,npoints
x=xmin+i*xstep 16 15 x=xmin+i*xstep
do n=0,5 17 16 do n=0,5
bes(i,n)=bskn(n,x) 18 17 bes(i,n)=bskn(n,x)
end do 19 18 end do
write(2,'(7e22.14)') x,bes(i,0:5) 20 19 write(2,'(7e22.14)') x,bes(i,0:5)
end do 21 20 end do
close(2) 22 21 close(2)
fvn_test/test_bsyn.f90
Diff comments   View file @ 8d883e8
program test_bsyn 1 1 program test_bsyn
use fvn_fnlib 2 2 use fvn_fnlib
use Kind_Definition 3
implicit none 4 3 implicit none
integer :: n,npoints,i 5 4 integer :: n,npoints,i
real(kind=sp_kind) :: xmin,xmax,xstep,x,y 6 5 real(kind=sp_kind) :: xmin,xmax,xstep,x,y
real(kind=sp_kind),dimension(200,0:5) :: bes 7 6 real(kind=sp_kind),dimension(200,0:5) :: bes
8 7
open(2,file='bsyn.dat') 9 8 open(2,file='bsyn.dat')
10 9
xmin=0. 11 10 xmin=0.
xmax=20. 12 11 xmax=20.
npoints=200 13 12 npoints=200
xstep=(xmax-xmin)/dble(npoints) 14 13 xstep=(xmax-xmin)/dble(npoints)
do i=1,npoints 15 14 do i=1,npoints
x=xmin+i*xstep 16 15 x=xmin+i*xstep
do n=0,5 17 16 do n=0,5
bes(i,n)=bsyn(n,x) 18 17 bes(i,n)=bsyn(n,x)
end do 19 18 end do
write(2,'(7e22.14)') x,bes(i,0:5) 20 19 write(2,'(7e22.14)') x,bes(i,0:5)
end do 21 20 end do
close(2) 22 21 close(2)
fvn_test/test_dbesri.f90
Diff comments   View file @ 8d883e8
program test_dbesri 1 1 program test_dbesri
use fvn_fnlib 2 2 use fvn_fnlib
use Kind_Definition 3
implicit none 4 3 implicit none
! Variables locales ----------------------------- 5 4 ! Variables locales -----------------------------
integer :: i,n,nstep,norder 6 5 integer :: i,n,nstep,norder
real(kind=dp_kind), dimension(:), allocatable :: bessvec0 7 6 real(kind=dp_kind), dimension(:), allocatable :: bessvec0
real(kind=dp_kind), dimension(:,:), allocatable:: bessvec1,bessvec2 8 7 real(kind=dp_kind), dimension(:,:), allocatable:: bessvec1,bessvec2
real(kind=dp_kind) :: x,xstep,xmax 9 8 real(kind=dp_kind) :: x,xstep,xmax
10 9
11 10
open (unit=1, file='dbesri.dat') 12 11 open (unit=1, file='dbesri.dat')
write (1,*) '# n, x, bsin(n,x), b(n) in dbesri(x,norder+1,b)' 13 12 write (1,*) '# n, x, bsin(n,x), b(n) in dbesri(x,norder+1,b)'
write (1,*) '# arg x from 0 to 20, 201 points' 14 13 write (1,*) '# arg x from 0 to 20, 201 points'
write (1,*) '# order n from 0 to 20' 15 14 write (1,*) '# order n from 0 to 20'
16 15
norder = 20 17 16 norder = 20
nstep = 200 18 17 nstep = 200
xmax=20.d0 19 18 xmax=20.d0
xstep=xmax/nstep 20 19 xstep=xmax/nstep
allocate(bessvec1(0:nstep,0:norder),bessvec2(0:nstep,0:norder)) 21 20 allocate(bessvec1(0:nstep,0:norder),bessvec2(0:nstep,0:norder))
allocate(bessvec0(0:norder)) 22 21 allocate(bessvec0(0:norder))
23 22
do i=0,nstep !loop on x 24 23 do i=0,nstep !loop on x
x=i*xstep 25 24 x=i*xstep
call dbesri(x,norder+1,bessvec0) 26 25 call dbesri(x,norder+1,bessvec0)
bessvec2(i,:)=bessvec0 27 26 bessvec2(i,:)=bessvec0
do n=0,norder !loop on rank, for dbesjn only 28 27 do n=0,norder !loop on rank, for dbesjn only
bessvec1(i,n)=bsin(n,x) 29 28 bessvec1(i,n)=bsin(n,x)
enddo 30 29 enddo
enddo 31 30 enddo
32 31
do n=0,norder 33 32 do n=0,norder
do i=0,nstep 34 33 do i=0,nstep
x=i*xstep 35 34 x=i*xstep
write (1,*) n,x,bessvec1(i,n), bessvec2(i,n) 36 35 write (1,*) n,x,bessvec1(i,n), bessvec2(i,n)
enddo 37 36 enddo
fvn_test/test_dbesrj.f90
Diff comments   View file @ 8d883e8
program test_dbesrj 1 1 program test_dbesrj
use fvn_fnlib 2 2 use fvn_fnlib
use Kind_Definition 3
implicit none 4 3 implicit none
! Variables locales ----------------------------- 5 4 ! Variables locales -----------------------------
integer :: i,n,nstep,norder 6 5 integer :: i,n,nstep,norder
real(kind=dp_kind), dimension(:), allocatable :: bessvec0 7 6 real(kind=dp_kind), dimension(:), allocatable :: bessvec0
real(kind=dp_kind), dimension(:,:), allocatable:: bessvec1,bessvec2 8 7 real(kind=dp_kind), dimension(:,:), allocatable:: bessvec1,bessvec2
real(kind=dp_kind) :: x,xstep,xmax 9 8 real(kind=dp_kind) :: x,xstep,xmax
10 9
11 10
open (unit=1, file='dbesrj.dat') 12 11 open (unit=1, file='dbesrj.dat')
write (1,*) '# n, x, bsjn(n,x), b(n) in dbesrj(x,norder+1,b)' 13 12 write (1,*) '# n, x, bsjn(n,x), b(n) in dbesrj(x,norder+1,b)'
write (1,*) '# arg x from 0 to 50, 501 points' 14 13 write (1,*) '# arg x from 0 to 50, 501 points'
write (1,*) '# order n from 0 to 50' 15 14 write (1,*) '# order n from 0 to 50'
16 15
norder = 50 17 16 norder = 50
nstep = 500 18 17 nstep = 500
xmax=50.d0 19 18 xmax=50.d0
xstep=xmax/nstep 20 19 xstep=xmax/nstep
allocate(bessvec1(0:nstep,0:norder),bessvec2(0:nstep,0:norder)) 21 20 allocate(bessvec1(0:nstep,0:norder),bessvec2(0:nstep,0:norder))
allocate(bessvec0(0:norder)) 22 21 allocate(bessvec0(0:norder))
23 22
do i=0,nstep !loop on x 24 23 do i=0,nstep !loop on x
x=i*xstep 25 24 x=i*xstep
call dbesrj(x,norder+1,bessvec0) 26 25 call dbesrj(x,norder+1,bessvec0)
bessvec2(i,:)=bessvec0 27 26 bessvec2(i,:)=bessvec0
do n=0,norder !loop on rank, for dbesjn only 28 27 do n=0,norder !loop on rank, for dbesjn only
bessvec1(i,n)=bsjn(n,x) 29 28 bessvec1(i,n)=bsjn(n,x)
enddo 30 29 enddo
enddo 31 30 enddo
32 31
do n=0,norder 33 32 do n=0,norder
do i=0,nstep 34 33 do i=0,nstep
x=i*xstep 35 34 x=i*xstep
write (1,*) n,x,bessvec1(i,n), bessvec2(i,n) 36 35 write (1,*) n,x,bessvec1(i,n), bessvec2(i,n)
enddo 37 36 enddo
fvn_test/test_det.f90
Diff comments   View file @ 8d883e8
program test_det 1 1 program test_det
use fvn_linear 2 2 use fvn_linear
use Kind_Definition 3
implicit none 4 3 implicit none
real(kind=dp_kind),dimension(3,3) :: a 5 4 real(kind=dp_kind),dimension(3,3) :: a
real(kind=dp_kind) :: deta 6 5 real(kind=dp_kind) :: deta
integer :: status,i 7 6 integer :: status,i
8 7
call init_random_seed() 9 8 call init_random_seed()
call random_number(a) 10 9 call random_number(a)
a=a*100 11 10 a=a*100
deta=fvn_det(3,a,status) 12 11 deta=fvn_det(3,a,status)
do i=1,3 13 12 do i=1,3
write (*,'(3(f15.5))') a(i,:) 14 13 write (*,'(3(f15.5))') a(i,:)
end do 15 14 end do
write (*,*) 16 15 write (*,*)
write (*,*) "Det = ",deta,"Status = ",status 17 16 write (*,*) "Det = ",deta,"Status = ",status
fvn_test/test_integ.f90
Diff comments   View file @ 8d883e8
program integ 1 1 program integ
use fvn_integ 2 2 use fvn_integ
use Kind_Definition 3
implicit none 4 3 implicit none
real(kind=dp_kind), external :: f1,f2,g,h 5 4 real(kind=dp_kind), external :: f1,f2,g,h
real(kind=dp_kind) :: a,b,epsabs,epsrel,abserr,res 6 5 real(kind=dp_kind) :: a,b,epsabs,epsrel,abserr,res
integer :: key,ier 7 6 integer :: key,ier
a=0. 8 7 a=0.
b=1. 9 8 b=1.
epsabs=1d-8 10 9 epsabs=1d-8
epsrel=1d-8 11 10 epsrel=1d-8
key=2 12 11 key=2
call fvn_integ_1_gk(f1,a,b,epsabs,epsrel,key,res,abserr,ier) 13 12 call fvn_integ_1_gk(f1,a,b,epsabs,epsrel,key,res,abserr,ier)
write(*,*) "Integration of x*x between 0 and 1 : " 14 13 write(*,*) "Integration of x*x between 0 and 1 : "
write(*,*) res 15 14 write(*,*) res
call fvn_integ_2_gk(f2,a,b,g,h,epsabs,epsrel,key,res,abserr,ier) 16 15 call fvn_integ_2_gk(f2,a,b,g,h,epsabs,epsrel,key,res,abserr,ier)
write(*,*) "Integration of x*y between 0 and 1 on both x and y : " 17 16 write(*,*) "Integration of x*y between 0 and 1 on both x and y : "
write(*,*) res 18 17 write(*,*) res
19 18
end program 20 19 end program
function f1(x) 21 20 function f1(x)
use Kind_Definition 22 21 use fvn_common
implicit none 23 22 implicit none
real(kind=dp_kind) :: x,f1 24 23 real(kind=dp_kind) :: x,f1
f1=x*x 25 24 f1=x*x
end function 26 25 end function
function f2(x,y) 27 26 function f2(x,y)
use Kind_Definition 28 27 use fvn_common
implicit none 29 28 implicit none
real(kind=dp_kind) :: x,y,f2 30 29 real(kind=dp_kind) :: x,y,f2
f2=x*y 31 30 f2=x*y
end function 32 31 end function
function g(x) 33 32 function g(x)
use Kind_Definition 34 33 use fvn_common
implicit none 35 34 implicit none
real(kind=dp_kind) :: x,g 36 35 real(kind=dp_kind) :: x,g
g=0. 37 36 g=0.
end function 38 37 end function
function h(x) 39 38 function h(x)
use Kind_Definition 40 39 use fvn_common
implicit none 41 40 implicit none
real(kind=dp_kind) :: x,h 42 41 real(kind=dp_kind) :: x,h
h=1. 43 42 h=1.
end function 44 43 end function
45 44
fvn_test/test_inter1d.f90
Diff comments   View file @ 8d883e8
program inter1d 1 1 program inter1d
use fvn_interpol 2 2 use fvn_interpol
use Kind_Definition 3
implicit none 4 3 implicit none
integer(kind=ip_kind),parameter :: ndata=33 5 4 integer(kind=ip_kind),parameter :: ndata=33
integer(kind=ip_kind) :: i,nout 6 5 integer(kind=ip_kind) :: i,nout
real(kind=dp_kind) :: f,fdata(ndata),h,pi,q,sin,x,xdata(ndata) 7 6 real(kind=dp_kind) :: f,fdata(ndata),h,pi,q,sin,x,xdata(ndata)
real(kind=dp_kind) ::tv 8 7 real(kind=dp_kind) ::tv
intrinsic sin 9 8 intrinsic sin
f(x)=sin(x) 10 9 f(x)=sin(x)
xdata(1)=0. 11 10 xdata(1)=0.
fdata(1)=f(xdata(1)) 12 11 fdata(1)=f(xdata(1))
h=1./32. 13 12 h=1./32.
do i=2,ndata 14 13 do i=2,ndata
xdata(i)=xdata(i-1)+h 15 14 xdata(i)=xdata(i-1)+h
fdata(i)=f(xdata(i)) 16 15 fdata(i)=f(xdata(i))
end do 17 16 end do
call init_random_seed() 18 17 call init_random_seed()
call random_number(x) 19 18 call random_number(x)
q=fvn_quad_interpol(x,ndata,xdata,fdata) 20 19 q=fvn_quad_interpol(x,ndata,xdata,fdata)
tv=f(x) 21 20 tv=f(x)
write(*,'("x y z ",1(f8.5))') x 22 21 write(*,'("x y z ",1(f8.5))') x
write(*,'("Calculated (real) value :",f8.5)') tv 23 22 write(*,'("Calculated (real) value :",f8.5)') tv
write(*,'("fvn interpolation : ",f8.5)') q 24 23 write(*,'("fvn interpolation : ",f8.5)') q
write(*,'("Relative fvn error :",e12.5)') abs((q-tv)/tv) 25 24 write(*,'("Relative fvn error :",e12.5)') abs((q-tv)/tv)
end program 26 25 end program
fvn_test/test_inter2d.f90
Diff comments   View file @ 8d883e8
program inter2d 1 1 program inter2d
use fvn_interpol 2 2 use fvn_interpol
use Kind_Definition 3
implicit none 4 3 implicit none
integer(kind=ip_kind),parameter :: nx=21,ny=42 5 4 integer(kind=ip_kind),parameter :: nx=21,ny=42
integer(kind=ip_kind) :: i,j 6 5 integer(kind=ip_kind) :: i,j
real(kind=dp_kind) :: f,fdata(nx,ny),dble,pi,q,sin,x,xdata(nx),y,ydata(ny) 7 6 real(kind=dp_kind) :: f,fdata(nx,ny),dble,pi,q,sin,x,xdata(nx),y,ydata(ny)
real(kind=dp_kind) :: tv 8 7 real(kind=dp_kind) :: tv
intrinsic dble,sin 9 8 intrinsic dble,sin
f(x,y)=sin(x+2.*y) 10 9 f(x,y)=sin(x+2.*y)
do i=1,nx 11 10 do i=1,nx
xdata(i)=dble(i-1)/dble(nx-1) 12 11 xdata(i)=dble(i-1)/dble(nx-1)
end do 13 12 end do
do i=1,ny 14 13 do i=1,ny
ydata(i)=dble(i-1)/dble(ny-1) 15 14 ydata(i)=dble(i-1)/dble(ny-1)
end do 16 15 end do
do i=1,nx 17 16 do i=1,nx
do j=1,ny 18 17 do j=1,ny
fdata(i,j)=f(xdata(i),ydata(j)) 19 18 fdata(i,j)=f(xdata(i),ydata(j))
end do 20 19 end do
end do 21 20 end do
call init_random_seed() 22 21 call init_random_seed()
call random_number(x) 23 22 call random_number(x)
call random_number(y) 24 23 call random_number(y)
q=fvn_quad_2d_interpol(x,y,nx,xdata,ny,ydata,fdata) 25 24 q=fvn_quad_2d_interpol(x,y,nx,xdata,ny,ydata,fdata)
tv=f(x,y) 26 25 tv=f(x,y)
write(*,'("x y z ",2(f8.5))') x,y 27 26 write(*,'("x y z ",2(f8.5))') x,y
write(*,'("Calculated (real) value :",f8.5)') tv 28 27 write(*,'("Calculated (real) value :",f8.5)') tv
write(*,'("fvn interpolation : ",f8.5)') q 29 28 write(*,'("fvn interpolation : ",f8.5)') q
write(*,'("Relative fvn error :",e12.5)') abs((q-tv)/tv) 30 29 write(*,'("Relative fvn error :",e12.5)') abs((q-tv)/tv)
end program 31 30 end program
fvn_test/test_inter3d.f90
Diff comments   View file @ 8d883e8
program test_inter3d 1 1 program test_inter3d
use fvn_interpol 2 2 use fvn_interpol
use Kind_Definition 3
implicit none 4 3 implicit none
integer(kind=ip_kind),parameter :: nx=21,ny=42,nz=18 5 4 integer(kind=ip_kind),parameter :: nx=21,ny=42,nz=18
integer(kind=ip_kind) :: i,j,k 6 5 integer(kind=ip_kind) :: i,j,k
real(kind=dp_kind) :: f,fdata(nx,ny,nz),dble,pi,q,sin,x,xdata(nx),y,ydata(ny),z,zdata(nz) 7 6 real(kind=dp_kind) :: f,fdata(nx,ny,nz),dble,pi,q,sin,x,xdata(nx),y,ydata(ny),z,zdata(nz)
real(kind=dp_kind) :: tv 8 7 real(kind=dp_kind) :: tv
intrinsic dble,sin 9 8 intrinsic dble,sin
f(x,y,z)=sin(x+2.*y+3.*z) 10 9 f(x,y,z)=sin(x+2.*y+3.*z)
do i=1,nx 11 10 do i=1,nx
xdata(i)=2.*(dble(i-1)/dble(nx-1)) 12 11 xdata(i)=2.*(dble(i-1)/dble(nx-1))
end do 13 12 end do
do i=1,ny 14 13 do i=1,ny
ydata(i)=2.*(dble(i-1)/dble(ny-1)) 15 14 ydata(i)=2.*(dble(i-1)/dble(ny-1))
end do 16 15 end do
do i=1,nz 17 16 do i=1,nz
zdata(i)=2.*(dble(i-1)/dble(nz-1)) 18 17 zdata(i)=2.*(dble(i-1)/dble(nz-1))
end do 19 18 end do
do i=1,nx 20 19 do i=1,nx
do j=1,ny 21 20 do j=1,ny
do k=1,nz 22 21 do k=1,nz
fdata(i,j,k)=f(xdata(i),ydata(j),zdata(k)) 23 22 fdata(i,j,k)=f(xdata(i),ydata(j),zdata(k))
end do 24 23 end do
end do 25 24 end do
end do 26 25 end do
call init_random_seed() 27 26 call init_random_seed()
call random_number(x) 28 27 call random_number(x)
call random_number(y) 29 28 call random_number(y)
call random_number(z) 30 29 call random_number(z)
q=fvn_quad_3d_interpol(x,y,z,nx,xdata,ny,ydata,nz,zdata,fdata) 31 30 q=fvn_quad_3d_interpol(x,y,z,nx,xdata,ny,ydata,nz,zdata,fdata)
tv=f(x,y,z) 32 31 tv=f(x,y,z)
write(*,'("x y z ",3(f8.5))') x,y,z 33 32 write(*,'("x y z ",3(f8.5))') x,y,z
write(*,'("Calculated (real) value :",f8.5)') tv 34 33 write(*,'("Calculated (real) value :",f8.5)') tv
write(*,'("fvn interpolation : ",f8.5)') q 35 34 write(*,'("fvn interpolation : ",f8.5)') q
write(*,'("Relative fvn error :",e12.5)') abs((q-tv)/tv) 36 35 write(*,'("Relative fvn error :",e12.5)') abs((q-tv)/tv)
end program 37 36 end program
fvn_test/test_lsp.f90
Diff comments   View file @ 8d883e8
program lsp 1 1 program lsp
use fvn_linear 2 2 use fvn_linear
use Kind_Definition 3
implicit none 4 3 implicit none
integer,parameter :: npoints=13,deg=3 5 4 integer,parameter :: npoints=13,deg=3
integer :: status,i 6 5 integer :: status,i
real(kind=dp_kind) :: xm(npoints),ym(npoints),xstep,xc,yc 7 6 real(kind=dp_kind) :: xm(npoints),ym(npoints),xstep,xc,yc
real(kind=dp_kind) :: coeff(deg+1) 8 7 real(kind=dp_kind) :: coeff(deg+1)
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. /) 9 8 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 /) 10 9 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 /)
open(2,file='fvn_lsp_double_mesure.dat') 11 10 open(2,file='fvn_lsp_double_mesure.dat')
open(3,file='fvn_lsp_double_poly.dat') 12 11 open(3,file='fvn_lsp_double_poly.dat')
do i=1,npoints 13 12 do i=1,npoints
write(2,44) xm(i),ym(i) 14 13 write(2,44) xm(i),ym(i)
end do 15 14 end do
close(2) 16 15 close(2)
call fvn_lspoly(npoints,xm,ym,deg,coeff,status) 17 16 call fvn_lspoly(npoints,xm,ym,deg,coeff,status)
xstep=(xm(npoints)-xm(1))/1000. 18 17 xstep=(xm(npoints)-xm(1))/1000.
do i=1,1000 19 18 do i=1,1000
xc=xm(1)+(i-1)*xstep 20 19 xc=xm(1)+(i-1)*xstep
yc=poly(xc,coeff) 21 20 yc=poly(xc,coeff)
write(3,44) xc,yc 22 21 write(3,44) xc,yc
end do 23 22 end do
close(3) 24 23 close(3)
write(*,*) "All done, plot results with gnuplot using command :" 25 24 write(*,*) "All done, plot results with gnuplot using command :"
write(*,*) "pl 'fvn_lsp_double_mesure.dat' u 1:2 w p,'fvn_lsp_double_poly.dat' u 1:2 w l" 26 25 write(*,*) "pl 'fvn_lsp_double_mesure.dat' u 1:2 w p,'fvn_lsp_double_poly.dat' u 1:2 w l"
44 FORMAT(4(1X,1PE22.14)) 27 26 44 FORMAT(4(1X,1PE22.14))
contains 28 27 contains
function poly(x,coeff) 29 28 function poly(x,coeff)
use Kind_Definition 30 29 use fvn_common
implicit none 31 30 implicit none
real(kind=dp_kind) :: x 32 31 real(kind=dp_kind) :: x
real(kind=dp_kind) :: coeff(deg+1) 33 32 real(kind=dp_kind) :: coeff(deg+1)
real(kind=dp_kind) :: poly 34 33 real(kind=dp_kind) :: poly
integer :: i 35 34 integer :: i
poly=0. 36 35 poly=0.
do i=1,deg+1 37 36 do i=1,deg+1
poly=poly+coeff(i)*x**(i-1) 38 37 poly=poly+coeff(i)*x**(i-1)
end do 39 38 end do
end function 40 39 end function
end program 41 40 end program
42 41
fvn_test/test_matcon.f90
Diff comments   View file @ 8d883e8
program test_matcon 1 1 program test_matcon
use fvn_linear 2 2 use fvn_linear
use Kind_Definition 3
implicit none 4 3 implicit none
real(kind=dp_kind),dimension(3,3) :: a 5 4 real(kind=dp_kind),dimension(3,3) :: a
real(kind=dp_kind) :: rcond 6 5 real(kind=dp_kind) :: rcond
integer :: status,i 7 6 integer :: status,i
call init_random_seed() 8 7 call init_random_seed()
call random_number(a) 9 8 call random_number(a)
a=a*100 10 9 a=a*100
call fvn_matcon(3,a,rcond,status) 11 10 call fvn_matcon(3,a,rcond,status)
write(*,*) "Reasonnably conditionned matrix" 12 11 write(*,*) "Reasonnably conditionned matrix"
do i=1,3 13 12 do i=1,3
write (*,'(3(e12.5))') a(i,:) 14 13 write (*,'(3(e12.5))') a(i,:)
end do 15 14 end do
write (*,*) 16 15 write (*,*)
write (*,*) "Cond = ",rcond 17 16 write (*,*) "Cond = ",rcond
write (*,*) 18 17 write (*,*)
write (*,*) 19 18 write (*,*)
a(1,1)=a(1,1)*1d9 20 19 a(1,1)=a(1,1)*1d9
write(*,*) "Badly conditionned matrix" 21 20 write(*,*) "Badly conditionned matrix"
do i=1,3 22 21 do i=1,3
write (*,'(3(e12.5))') a(i,:) 23 22 write (*,'(3(e12.5))') a(i,:)
end do 24 23 end do
call fvn_matcon(3,a,rcond,status) 25 24 call fvn_matcon(3,a,rcond,status)
write (*,*) 26 25 write (*,*)
write (*,*) "Cond = ",rcond 27 26 write (*,*) "Cond = ",rcond
28 27
fvn_test/test_matev.f90
Diff comments   View file @ 8d883e8
program test_matev 1 1 program test_matev
use fvn_linear 2 2 use fvn_linear
use Kind_Definition 3
implicit none 4 3 implicit none
complex(kind=dp_kind),dimension(3,3) :: a 5 4 complex(kind=dp_kind),dimension(3,3) :: a
real(kind=dp_kind),dimension(3,3) :: ra,ia 6 5 real(kind=dp_kind),dimension(3,3) :: ra,ia
complex(kind=dp_kind),dimension(3) :: evala 7 6 complex(kind=dp_kind),dimension(3) :: evala
complex(kind=dp_kind),dimension(3,3) :: eveca 8 7 complex(kind=dp_kind),dimension(3,3) :: eveca
integer :: status,i,j 9 8 integer :: status,i,j
10 9
call init_random_seed() 11 10 call init_random_seed()
call random_number(ra) 12 11 call random_number(ra)
call random_number(ia) 13 12 call random_number(ia)
a=ra+fvn_i*ia 14 13 a=ra+fvn_i*ia
a=a*100 15 14 a=a*100
call fvn_matev(3,a,evala,eveca,status) 16 15 call fvn_matev(3,a,evala,eveca,status)
17 16
write(*,*) "The matrix :" 18 17 write(*,*) "The matrix :"
write (*,'(3("(",e12.5,",",e12.5,")"))') a 19 18 write (*,'(3("(",e12.5,",",e12.5,")"))') a
write (*,*) 20 19 write (*,*)
do i=1,3 21 20 do i=1,3
write(*,'("Eigenvalue ",I3," : (",e12.5,",",e12.5,") ")') i,evala(i) 22 21 write(*,'("Eigenvalue ",I3," : (",e12.5,",",e12.5,") ")') i,evala(i)
write(*,'("Modulus : ",e12.5)') abs(evala(i)) 23 22 write(*,'("Modulus : ",e12.5)') abs(evala(i))
write(*,*) "Associated Eigenvector :" 24 23 write(*,*) "Associated Eigenvector :"
do j=1,3 25 24 do j=1,3
write(*,'("(",e12.5,",",e12.5,") ")') eveca(j,i) 26 25 write(*,'("(",e12.5,",",e12.5,") ")') eveca(j,i)
end do 27 26 end do
write(*,*) 28 27 write(*,*)
end do 29 28 end do
30 29
! tri 31 30 ! tri
write(*,*) "With sort option" 32 31 write(*,*) "With sort option"
call fvn_matev(3,a,evala,eveca,status,.true.) 33 32 call fvn_matev(3,a,evala,eveca,status,.true.)
do i=1,3 34 33 do i=1,3
write(*,'("Eigenvalue ",I3," : (",e12.5,",",e12.5,") ")') i,evala(i) 35 34 write(*,'("Eigenvalue ",I3," : (",e12.5,",",e12.5,") ")') i,evala(i)
write(*,'("Modulus : ",e12.5)') abs(evala(i)) 36 35 write(*,'("Modulus : ",e12.5)') abs(evala(i))
write(*,*) "Associated Eigenvector :" 37 36 write(*,*) "Associated Eigenvector :"
do j=1,3 38 37 do j=1,3
write(*,'("(",e12.5,",",e12.5,") ")') eveca(j,i) 39 38 write(*,'("(",e12.5,",",e12.5,") ")') eveca(j,i)
end do 40 39 end do
fvn_test/test_matinv.f90
Diff comments   View file @ 8d883e8
program test_matinv 1 1 program test_matinv
use fvn_linear 2 2 use fvn_linear
use Kind_Definition 3
implicit none 4 3 implicit none
integer(kind=ip_kind), parameter :: n=3 5 4 integer(kind=ip_kind), parameter :: n=3
integer(kind=ip_kind) :: status,i 6 5 integer(kind=ip_kind) :: status,i
complex(kind=dp_kind),dimension(n,n) :: m,im,prod 7 6 complex(kind=dp_kind),dimension(n,n) :: m,im,prod
real(kind=dp_kind),dimension(n,n) :: rtmp,itmp 8 7 real(kind=dp_kind),dimension(n,n) :: rtmp,itmp
character(len=80) :: fmreal,fmcmplx 9 8 character(len=80) :: fmreal,fmcmplx
10 9
fmcmplx='(3("(",f8.5,",",f8.5,") "))' 11 10 fmcmplx='(3("(",f8.5,",",f8.5,") "))'
12 11
! initialize pseudo random generator 13 12 ! initialize pseudo random generator
call init_random_seed() 14 13 call init_random_seed()
! fill real and imaginary part 15 14 ! fill real and imaginary part
call random_number(rtmp) 16 15 call random_number(rtmp)
call random_number(itmp) 17 16 call random_number(itmp)
! create the complex matrix (fvn_i is defined in the fvn module) 18 17 ! create the complex matrix (fvn_i is defined in the fvn module)
m=rtmp+fvn_i*itmp 19 18 m=rtmp+fvn_i*itmp
write(*,*) "Matrix M" 20 19 write(*,*) "Matrix M"
do i=1,n 21 20 do i=1,n
write(*,fmcmplx) m(i,:) 22 21 write(*,fmcmplx) m(i,:)
end do 23 22 end do
24 23
! Invertion 25 24 ! Invertion
call fvn_matinv(n,m,im) 26 25 call fvn_matinv(n,m,im)
write(*,*) "Inverse of M" 27 26 write(*,*) "Inverse of M"
do i=1,n 28 27 do i=1,n
write(*,fmcmplx) im(i,:) 29 28 write(*,fmcmplx) im(i,:)
end do 30 29 end do
31 30
! Result should be identity matrix 32 31 ! Result should be identity matrix
write(*,*) "Product of M and inverse of M :" 33 32 write(*,*) "Product of M and inverse of M :"
prod=matmul(m,im) 34 33 prod=matmul(m,im)
fvn_test/test_muller.f90
Diff comments   View file @ 8d883e8
program muller 1 1 program muller
use fvn_misc 2 2 use fvn_misc
use Kind_Definition 3
implicit none 4 3 implicit none
integer :: i,info 5 4 integer :: i,info
complex(kind=dp_kind),dimension(10) :: roots 6 5 complex(kind=dp_kind),dimension(10) :: roots
integer,dimension(10) :: infer 7 6 integer,dimension(10) :: infer
complex(kind=dp_kind), external :: f 8 7 complex(kind=dp_kind), external :: f
9 8
real(kind=dp_kind) :: eps1 10 9 real(kind=dp_kind) :: eps1
eps1=1.d-10 11 10 eps1=1.d-10
call fvn_muller(f,1.d-12,1.d-10,0,0,10,roots,200,infer,info) 12 11 call fvn_muller(f,1.d-12,1.d-10,0,0,10,roots,200,infer,info)
write(*,*) "Error code :",info 13 12 write(*,*) "Error code :",info
do i=1,10 14 13 do i=1,10
write(*,*) roots(i),infer(i) 15 14 write(*,*) roots(i),infer(i)
enddo 16 15 enddo
end program 17 16 end program
18 17
function f(x) 19 18 function f(x)
use Kind_Definition 20 19 use fvn_common
complex(kind=dp_kind) :: x,f 21 20 complex(kind=dp_kind) :: x,f
f=x**10-1 22 21 f=x**10-1
fvn_test/test_operators.f90
Diff comments   View file @ 8d883e8
program test_matinv 1 1 program test_matinv
use fvn_linear 2 2 use fvn_linear
use Kind_Definition 3
implicit none 4 3 implicit none
5 4
integer, parameter :: n=3 6 5 integer, parameter :: n=3
complex(kind=dp_kind),dimension(n,n) :: m1,m2,res 7 6 complex(kind=dp_kind),dimension(n,n) :: m1,m2,res
real(kind=dp_kind),dimension(n,n) :: rtmp,itmp 8 7 real(kind=dp_kind),dimension(n,n) :: rtmp,itmp
character(len=80) :: fmcmplx 9 8 character(len=80) :: fmcmplx
integer :: i 10 9 integer :: i
11 10
fmcmplx='(3("(",f8.5,",",f8.5,") "))' 12 11 fmcmplx='(3("(",f8.5,",",f8.5,") "))'
! initialize pseudo random generator 13 12 ! initialize pseudo random generator
!call init_random_seed() 14 13 !call init_random_seed()
! fill real and imaginary part 15 14 ! fill real and imaginary part
call random_number(rtmp) 16 15 call random_number(rtmp)
call random_number(itmp) 17 16 call random_number(itmp)
! create the complex matrix (fvn_i is defined in the fvn module) 18 17 ! create the complex matrix (fvn_i is defined in the fvn module)
m1=rtmp+fvn_i*itmp 19 18 m1=rtmp+fvn_i*itmp
write(*,*) "Matrix M1" 20 19 write(*,*) "Matrix M1"
do i=1,n 21 20 do i=1,n
write(*,fmcmplx) m1(i,:) 22 21 write(*,fmcmplx) m1(i,:)
end do 23 22 end do
24 23
call random_number(rtmp) 25 24 call random_number(rtmp)
call random_number(itmp) 26 25 call random_number(itmp)
m2=rtmp+fvn_i*itmp 27 26 m2=rtmp+fvn_i*itmp
write(*,*) 28 27 write(*,*)
write(*,*) "Matrix M2" 29 28 write(*,*) "Matrix M2"
do i=1,n 30 29 do i=1,n
write(*,fmcmplx) m2(i,:) 31 30 write(*,fmcmplx) m2(i,:)
end do 32 31 end do
33 32
34 33
write(*,*) 35 34 write(*,*)
write(*,*) "M1.x.M2" 36 35 write(*,*) "M1.x.M2"
res=m1.x.m2 37 36 res=m1.x.m2
call write_res() 38 37 call write_res()
write(*,*) 39 38 write(*,*)
write(*,*) "M1.x.M2 standard" 40 39 write(*,*) "M1.x.M2 standard"
res=matmul(m1,m2) 41 40 res=matmul(m1,m2)
call write_res() 42 41 call write_res()
43 42
write(*,*) 44 43 write(*,*)
write(*,*) ".i.M1" 45 44 write(*,*) ".i.M1"
res=.i.m1 46 45 res=.i.m1
call write_res() 47 46 call write_res()
write(*,*) 48 47 write(*,*)
write(*,*) ".i.M1 standard" 49 48 write(*,*) ".i.M1 standard"
call fvn_matinv(3,m1,res) 50 49 call fvn_matinv(3,m1,res)
call write_res() 51 50 call write_res()
52 51
write(*,*) 53 52 write(*,*)
write(*,*) "M1.ix.M2" 54 53 write(*,*) "M1.ix.M2"
res=m1.ix.m2 55 54 res=m1.ix.m2
call write_res() 56 55 call write_res()
write(*,*) 57 56 write(*,*)
write(*,*) "M1.ix.M2 standard" 58 57 write(*,*) "M1.ix.M2 standard"
call fvn_matinv(3,m1,res) 59 58 call fvn_matinv(3,m1,res)
res=matmul(res,m2) 60 59 res=matmul(res,m2)
call write_res() 61 60 call write_res()
62 61
write(*,*) 63 62 write(*,*)
write(*,*) "M1.xi.M2" 64 63 write(*,*) "M1.xi.M2"
res=m1.xi.m2 65 64 res=m1.xi.m2
call write_res() 66 65 call write_res()
write(*,*) 67 66 write(*,*)
write(*,*) "M1.xi.M2 standard" 68 67 write(*,*) "M1.xi.M2 standard"
res=m1.xi.m2 69 68 res=m1.xi.m2
call fvn_matinv(3,m2,res) 70 69 call fvn_matinv(3,m2,res)
res=matmul(m1,res) 71 70 res=matmul(m1,res)
call write_res() 72 71 call write_res()
73 72
write(*,*) 74 73 write(*,*)
write(*,*) ".t.M1" 75 74 write(*,*) ".t.M1"
res=.t.m1 76 75 res=.t.m1
call write_res() 77 76 call write_res()
write(*,*) 78 77 write(*,*)
write(*,*) ".t.M1 standard" 79 78 write(*,*) ".t.M1 standard"
res=transpose(m1) 80 79 res=transpose(m1)
call write_res() 81 80 call write_res()
82 81
write(*,*) 83 82 write(*,*)
write(*,*) "M1.tx.M2" 84 83 write(*,*) "M1.tx.M2"
res=m1.tx.m2 85 84 res=m1.tx.m2
call write_res() 86 85 call write_res()
write(*,*) 87 86 write(*,*)
write(*,*) "M1.tx.M2 standard" 88 87 write(*,*) "M1.tx.M2 standard"
res=matmul(transpose(m1),m2) 89 88 res=matmul(transpose(m1),m2)
call write_res() 90 89 call write_res()
91 90
write(*,*) 92 91 write(*,*)
write(*,*) "M1.xt.M2" 93 92 write(*,*) "M1.xt.M2"
res=m1.xt.m2 94 93 res=m1.xt.m2
call write_res() 95 94 call write_res()
write(*,*) 96 95 write(*,*)
write(*,*) "M1.xt.M2 standard" 97 96 write(*,*) "M1.xt.M2 standard"
res=matmul(m1,transpose(m2)) 98 97 res=matmul(m1,transpose(m2))
call write_res() 99 98 call write_res()
100 99
write(*,*) 101 100 write(*,*)
write(*,*) ".h.M1" 102 101 write(*,*) ".h.M1"
res=.h.m1 103 102 res=.h.m1
call write_res() 104 103 call write_res()
write(*,*) 105 104 write(*,*)
write(*,*) ".h.M1 standard" 106 105 write(*,*) ".h.M1 standard"
res=transpose(conjg(m1)) 107 106 res=transpose(conjg(m1))
call write_res() 108 107 call write_res()
109 108
write(*,*) 110 109 write(*,*)
write(*,*) "M1.hx.M2" 111 110 write(*,*) "M1.hx.M2"
res=m1.hx.m2 112 111 res=m1.hx.m2
call write_res() 113 112 call write_res()
write(*,*) 114 113 write(*,*)
write(*,*) "M1.hx.M2 standard" 115 114 write(*,*) "M1.hx.M2 standard"
res=matmul(transpose(conjg(m1)),m2) 116 115 res=matmul(transpose(conjg(m1)),m2)
call write_res() 117 116 call write_res()
118 117
write(*,*) 119 118 write(*,*)
fvn_test/test_sparse.f90
Diff comments   View file @ 8d883e8
program test_sparse 1 1 program test_sparse
use fvn_sparse 2 2 use fvn_sparse
use Kind_Definition 3
implicit none 4 3 implicit none
integer(kind=ip_kind), parameter :: nz=12 5 4 integer(kind=ip_kind), parameter :: nz=12
integer(kind=ip_kind), parameter :: n=5 6 5 integer(kind=ip_kind), parameter :: n=5
real(kind=dp_kind),dimension(nz) :: A 7 6 real(kind=dp_kind),dimension(nz) :: A
real(kind=dp_kind),dimension(n,n) :: As 8 7 real(kind=dp_kind),dimension(n,n) :: As
integer(kind=ip_kind),dimension(nz) :: Ti,Tj 9 8 integer(kind=ip_kind),dimension(nz) :: Ti,Tj
real(kind=dp_kind),dimension(n) :: B,x 10 9 real(kind=dp_kind),dimension(n) :: B,x
integer(kind=ip_kind) :: status,i 11 10 integer(kind=ip_kind) :: status,i
! Description of the matrix in triplet form 12 11 ! Description of the matrix in triplet form
A = (/ 2.,3.,3.,-1.,4.,4.,-3.,1.,2.,2.,6.,1. /) 13 12 A = (/ 2.,3.,3.,-1.,4.,4.,-3.,1.,2.,2.,6.,1. /)
B = (/ 8., 45., -3., 3., 19./) 14 13 B = (/ 8., 45., -3., 3., 19./)
Ti = (/ 1,2,1,3,5,2,3,4,5,3,2,5 /) 15 14 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 /) 16 15 Tj = (/ 1,1,2,2,2,3,3,3,3,4,5,5 /)
17 16
! Reconstruction of the matrix in standard form 18 17 ! Reconstruction of the matrix in standard form
! just needed for printing the matrix here 19 18 ! just needed for printing the matrix here
As=0. 20 19 As=0.
do i=1,nz 21 20 do i=1,nz
As(Ti(i),Tj(i))=A(i) 22 21 As(Ti(i),Tj(i))=A(i)
end do 23 22 end do
write(*,*) "Matrix in standard representation :" 24 23 write(*,*) "Matrix in standard representation :"
do i=1,5 25 24 do i=1,5
write(*,'(5f8.4)') As(i,:) 26 25 write(*,'(5f8.4)') As(i,:)
end do 27 26 end do
write(*,*) 28 27 write(*,*)
write(*,'("Right hand side :",5f8.4)') B 29 28 write(*,'("Right hand side :",5f8.4)') B
30 29
!specific routine that will be used here 31 30 !specific routine that will be used here
!call fvn_di_sparse_solve(n,nz,A,Ti,Tj,B,x,status) 32 31 !call fvn_di_sparse_solve(n,nz,A,Ti,Tj,B,x,status)
call fvn_di_sparse_solve(n,nz,A,Ti,Tj,B,x,status) 33 32 call fvn_di_sparse_solve(n,nz,A,Ti,Tj,B,x,status)
write(*,'("Solution :",5f8.4)') x 34 33 write(*,'("Solution :",5f8.4)') x
fvn_test/test_specfunc.f90
Diff comments   View file @ 8d883e8
program test_specfunc 1 1 program test_specfunc
use fvn_fnlib 2 2 use fvn_fnlib
use Kind_Definition 3
implicit none 4 3 implicit none
integer,parameter :: npoints=200 5 4 integer,parameter :: npoints=200
integer :: i 6 5 integer :: i
real(kind=dp_kind), dimension(npoints) :: j0 7 6 real(kind=dp_kind), dimension(npoints) :: j0
real(kind=dp_kind) :: xmin,xmax,xstep,x,y 8 7 real(kind=dp_kind) :: xmin,xmax,xstep,x,y
9 8
! bsj0 10 9 ! bsj0
xmin=-20. 11 10 xmin=-20.
xmax=20. 12 11 xmax=20.
xstep=(xmax-xmin)/dble(npoints) 13 12 xstep=(xmax-xmin)/dble(npoints)
open(2,file='bsj0.dat') 14 13 open(2,file='bsj0.dat')
do i=1,npoints 15 14 do i=1,npoints
x=xmin+i*xstep 16 15 x=xmin+i*xstep
y=bsj0(x) 17 16 y=bsj0(x)
write(2,'(2e22.14)') x,y 18 17 write(2,'(2e22.14)') x,y
end do 19 18 end do
close(2) 20 19 close(2)
21 20
! bsj1 22 21 ! bsj1
xmin=-20. 23 22 xmin=-20.
xmax=20. 24 23 xmax=20.
xstep=(xmax-xmin)/dble(npoints) 25 24 xstep=(xmax-xmin)/dble(npoints)
open(2,file='bsj1.dat') 26 25 open(2,file='bsj1.dat')
do i=1,npoints 27 26 do i=1,npoints
x=xmin+i*xstep 28 27 x=xmin+i*xstep
y=bsj1(x) 29 28 y=bsj1(x)
write(2,'(2e22.14)') x,y 30 29 write(2,'(2e22.14)') x,y
end do 31 30 end do
close(2) 32 31 close(2)
33 32
!bsi0 34 33 !bsi0
xmin=-4. 35 34 xmin=-4.
xmax=4. 36 35 xmax=4.
xstep=(xmax-xmin)/dble(npoints) 37 36 xstep=(xmax-xmin)/dble(npoints)
open(2,file='bsi0.dat') 38 37 open(2,file='bsi0.dat')
do i=1,npoints 39 38 do i=1,npoints
x=xmin+i*xstep 40 39 x=xmin+i*xstep
y=bsi0(x) 41 40 y=bsi0(x)
write(2,'(2e22.14)') x,y 42 41 write(2,'(2e22.14)') x,y
end do 43 42 end do
close(2) 44 43 close(2)
45 44
!bsi1 46 45 !bsi1
xmin=-4. 47 46 xmin=-4.
xmax=4. 48 47 xmax=4.
xstep=(xmax-xmin)/dble(npoints) 49 48 xstep=(xmax-xmin)/dble(npoints)
open(2,file='bsi1.dat') 50 49 open(2,file='bsi1.dat')
do i=1,npoints 51 50 do i=1,npoints
x=xmin+i*xstep 52 51 x=xmin+i*xstep
y=bsi1(x) 53 52 y=bsi1(x)
write(2,'(2e22.14)') x,y 54 53 write(2,'(2e22.14)') x,y
end do 55 54 end do
close(2) 56 55 close(2)
57 56
!bsy0 58 57 !bsy0
xmin=0. 59 58 xmin=0.
xmax=20. 60 59 xmax=20.
xstep=(xmax-xmin)/dble(npoints) 61 60 xstep=(xmax-xmin)/dble(npoints)
open(2,file='bsy0.dat') 62 61 open(2,file='bsy0.dat')
do i=1,npoints 63 62 do i=1,npoints
x=xmin+i*xstep 64 63 x=xmin+i*xstep
y=bsy0(x) 65 64 y=bsy0(x)
write(2,'(2e22.14)') x,y 66 65 write(2,'(2e22.14)') x,y
end do 67 66 end do
close(2) 68 67 close(2)
69 68
!bsy1 70 69 !bsy1
xmin=0. 71 70 xmin=0.
xmax=20. 72 71 xmax=20.
xstep=(xmax-xmin)/dble(npoints) 73 72 xstep=(xmax-xmin)/dble(npoints)
open(2,file='bsy1.dat') 74 73 open(2,file='bsy1.dat')
do i=1,npoints 75 74 do i=1,npoints
x=xmin+i*xstep 76 75 x=xmin+i*xstep
y=bsy1(x) 77 76 y=bsy1(x)
write(2,'(2e22.14)') x,y 78 77 write(2,'(2e22.14)') x,y
end do 79 78 end do
close(2) 80 79 close(2)
81 80
!bsk0 82 81 !bsk0
xmin=0. 83 82 xmin=0.
xmax=4. 84 83 xmax=4.
xstep=(xmax-xmin)/dble(npoints) 85 84 xstep=(xmax-xmin)/dble(npoints)
open(2,file='bsk0.dat') 86 85 open(2,file='bsk0.dat')
do i=1,npoints 87 86 do i=1,npoints
x=xmin+i*xstep 88 87 x=xmin+i*xstep
y=bsk0(x) 89 88 y=bsk0(x)
write(2,'(2e22.14)') x,y 90 89 write(2,'(2e22.14)') x,y
end do 91 90 end do
close(2) 92 91 close(2)
93 92
!bsk1 94 93 !bsk1
xmin=0. 95 94 xmin=0.
xmax=4. 96 95 xmax=4.
xstep=(xmax-xmin)/dble(npoints) 97 96 xstep=(xmax-xmin)/dble(npoints)
open(2,file='bsk1.dat') 98 97 open(2,file='bsk1.dat')
do i=1,npoints 99 98 do i=1,npoints
x=xmin+i*xstep 100 99 x=xmin+i*xstep
y=bsk1(x) 101 100 y=bsk1(x)
write(2,'(2e22.14)') x,y 102 101 write(2,'(2e22.14)') x,y
end do 103 102 end do
close(2) 104 103 close(2)
105 104
!erf 106 105 !erf
xmin=-4. 107 106 xmin=-4.
xmax=4. 108 107 xmax=4.
xstep=(xmax-xmin)/dble(npoints) 109 108 xstep=(xmax-xmin)/dble(npoints)
open(2,file='erf.dat') 110 109 open(2,file='erf.dat')
do i=1,npoints 111 110 do i=1,npoints
x=xmin+i*xstep 112 111 x=xmin+i*xstep
y=erf(x) 113 112 y=erf(x)
write(2,'(2e22.14)') x,y 114 113 write(2,'(2e22.14)') x,y
end do 115 114 end do
close(2) 116 115 close(2)
117 116
! gamma 118 117 ! gamma
xmin=-3. 119 118 xmin=-3.
xmax=7. 120 119 xmax=7.
xstep=(xmax-xmin)/2000. 121 120 xstep=(xmax-xmin)/2000.
open(2,file='gamma.dat') 122 121 open(2,file='gamma.dat')
do i=1,2000 123 122 do i=1,2000
x=xmin+i*xstep 124 123 x=xmin+i*xstep
if ((abs(x-nint(x)) >= 1d-6) .or. x>0. )then 125 124 if ((abs(x-nint(x)) >= 1d-6) .or. x>0. )then
y=gamma(x) 126 125 y=gamma(x)
write(2,'(2e22.14)') x,y 127 126 write(2,'(2e22.14)') x,y
end if 128 127 end if
end do 129 128 end do
close(2) 130 129 close(2)
131 130
! 1/gamma 132 131 ! 1/gamma
xmin=-3. 133 132 xmin=-3.
xmax=7. 134 133 xmax=7.
xstep=(xmax-xmin)/dble(npoints) 135 134 xstep=(xmax-xmin)/dble(npoints)
open(2,file='gamr.dat') 136 135 open(2,file='gamr.dat')
do i=1,npoints 137 136 do i=1,npoints
x=xmin+i*xstep 138 137 x=xmin+i*xstep
y=gamr(x) 139 138 y=gamr(x)
write(2,'(2e22.14)') x,y 140 139 write(2,'(2e22.14)') x,y
end do 141 140 end do
close(2) 142 141 close(2)
143 142
! ei 144 143 ! ei
xmin=0. 145 144 xmin=0.
xmax=1. 146 145 xmax=1.
xstep=(xmax-xmin)/dble(npoints) 147 146 xstep=(xmax-xmin)/dble(npoints)
open(2,file='ei.dat') 148 147 open(2,file='ei.dat')
do i=1,npoints 149 148 do i=1,npoints
x=xmin+i*xstep 150 149 x=xmin+i*xstep
y=ei(x) 151 150 y=ei(x)
write(2,'(2e22.14)') x,y 152 151 write(2,'(2e22.14)') x,y
end do 153 152 end do
close(2) 154 153 close(2)
155 154
! e1 156 155 ! e1
xmin=0. 157 156 xmin=0.
xmax=1. 158 157 xmax=1.
xstep=(xmax-xmin)/dble(npoints) 159 158 xstep=(xmax-xmin)/dble(npoints)
open(2,file='e1.dat') 160 159 open(2,file='e1.dat')
do i=1,npoints 161 160 do i=1,npoints
x=xmin+i*xstep 162 161 x=xmin+i*xstep
y=e1(x) 163 162 y=e1(x)
write(2,'(2e22.14)') x,y 164 163 write(2,'(2e22.14)') x,y
end do 165 164 end do
fvn_test/test_ze1.f90
Diff comments   View file @ 8d883e8
program test_ze1 1 1 program test_ze1
use fvn_fnlib 2 2 use fvn_fnlib
use Kind_Definition 3
implicit none 4 3 implicit none
5 4
complex(kind=dp_kind) :: z,resz 6 5 complex(kind=dp_kind) :: z,resz
complex(kind=dp_kind), dimension(6) :: abramowitz_x,abramowitz_y 7 6 complex(kind=dp_kind), dimension(6) :: abramowitz_x,abramowitz_y
integer(kind=ip_kind) :: i 8 7 integer(kind=ip_kind) :: i
9 8
abramowitz_x(1)=cmplx(5.d0,5.d0,dp_kind) 10 9 abramowitz_x(1)=cmplx(5.d0,5.d0,dp_kind)
abramowitz_y(1)=cmplx(0.906058d0,0.070209d0,dp_kind) 11 10 abramowitz_y(1)=cmplx(0.906058d0,0.070209d0,dp_kind)
abramowitz_x(2)=cmplx(-5.d0,5.d0,dp_kind) 12 11 abramowitz_x(2)=cmplx(-5.d0,5.d0,dp_kind)
abramowitz_y(2)=cmplx(1.079407d0,0.143879d0,dp_kind) 13 12 abramowitz_y(2)=cmplx(1.079407d0,0.143879d0,dp_kind)
abramowitz_x(3)=cmplx(11.d0,5.d0,dp_kind) 14 13 abramowitz_x(3)=cmplx(11.d0,5.d0,dp_kind)
abramowitz_y(3)=cmplx(0.932672d0,0.026361d0,dp_kind) 15 14 abramowitz_y(3)=cmplx(0.932672d0,0.026361d0,dp_kind)
abramowitz_x(4)=cmplx(-11.d0,5.d0,dp_kind) 16 15 abramowitz_x(4)=cmplx(-11.d0,5.d0,dp_kind)
abramowitz_y(4)=cmplx(1.084526d0,0.049336d0,dp_kind) 17 16 abramowitz_y(4)=cmplx(1.084526d0,0.049336d0,dp_kind)
abramowitz_x(5)=cmplx(15.d0,18.d0,dp_kind) 18 17 abramowitz_x(5)=cmplx(15.d0,18.d0,dp_kind)
abramowitz_y(5)=cmplx(0.972359d0,0.029448d0,dp_kind) 19 18 abramowitz_y(5)=cmplx(0.972359d0,0.029448d0,dp_kind)
abramowitz_x(6)=cmplx(-15.d0,18.d0,dp_kind) 20 19 abramowitz_x(6)=cmplx(-15.d0,18.d0,dp_kind)
abramowitz_y(6)=cmplx(1.026183d0,0.036552d0,dp_kind) 21 20 abramowitz_y(6)=cmplx(1.026183d0,0.036552d0,dp_kind)
22 21
! Value of z*exp(z)*e1(z) from Abramowitz & Stegun 23 22 ! Value of z*exp(z)*e1(z) from Abramowitz & Stegun
! to cover the different cases of the algo 24 23 ! to cover the different cases of the algo
! 25 24 !
! Case (5,5) modulus <10 with positive real part 26 25 ! Case (5,5) modulus <10 with positive real part
! Case (-5,5) modulus <10 with negative real part 27 26 ! Case (-5,5) modulus <10 with negative real part
! Case (11,5) modulus between 10 and 20 with positive real part 28 27 ! Case (11,5) modulus between 10 and 20 with positive real part
! Case (-11,5) modulus between 10 and 20 with negative real part 29 28 ! Case (-11,5) modulus between 10 and 20 with negative real part
! Case (15,18) modulus > 20 with positive real part 30 29 ! Case (15,18) modulus > 20 with positive real part
! Case (-15,18) modulus > 20 with negative real part 31 30 ! Case (-15,18) modulus > 20 with negative real part
32 31
do i=1,6 33 32 do i=1,6
z=abramowitz_x(i) 34 33 z=abramowitz_x(i)
resz=z*exp(z)*e1(z) 35 34 resz=z*exp(z)*e1(z)
write(*,*) "Tabulated : ",abramowitz_y(i) 36 35 write(*,*) "Tabulated : ",abramowitz_y(i)