lxsd / fvn

Download as
Browse Code ยป

Commit f61865f4638158170082dca249903e6f846da6be

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

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

Showing 1 changed file with 195 additions and 1 deletions Side-by-side Diff

... ... @@ -22,7 +22,8 @@
22 22 ! if you find it usefull it would be kind to give credits ;-) Nevertheless, you
23 23 ! may give credits to quadpack authors.
24 24 !
25   -! Version 1.1
  25 +! svn version
  26 +! June 2007 : added some complex trigonometric functions
26 27 !
27 28 ! TO DO LIST :
28 29 ! + Order eigenvalues and vectors in decreasing eigenvalue's modulus order -> atm
... ... @@ -36,6 +37,11 @@
36 37 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
37 38  
38 39 implicit none
  40 +! We define pi and i for the module
  41 +real(kind=8),parameter :: fvn_pi = 3.141592653589793_8
  42 +complex(kind=8),parameter :: fvn_i = (0._8,1._8)
  43 +
  44 +
39 45 ! All quadpack routines are private to the module
40 46 private :: d1mach,dqag,dqag_2d_inner,dqag_2d_outer,dqage,dqage_2d_inner, &
41 47 dqage_2d_outer,dqk15,dqk15_2d_inner,dqk15_2d_outer,dqk21,dqk21_2d_inner,dqk21_2d_outer, &
... ... @@ -1772,6 +1778,194 @@
1772 1778 include "fvn_quadpack/dqk21_2d_inner.f"
1773 1779 include "fvn_quadpack/dqk15_2d_outer.f"
1774 1780  
  1781 +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  1782 +!
  1783 +! Trigonometric functions
  1784 +!
  1785 +! fvn_z_acos, fvn_z_asin : complex arc cosine and sine
  1786 +! fvn_d_acosh : arc cosinus hyperbolic
  1787 +! fvn_d_asinh : arc sinus hyperbolic
  1788 +!
  1789 +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  1790 +function fvn_z_acos(z)
  1791 + ! double complex arccos function adapted from
  1792 + ! the c gsl library
  1793 + ! http://www.gnu.org/software/gsl/
  1794 + implicit none
  1795 + complex(kind=8) :: fvn_z_acos
  1796 + complex(kind=8) :: z
  1797 + real(kind=8) :: rz,iz,x,y,a,b,y2,r,s,d,apx,am1
  1798 + real(kind=8),parameter :: a_crossover=1.5_8,b_crossover = 0.6417_8
  1799 + complex(kind=8),parameter :: i=(0._8,1._8)
  1800 + real(kind=8) :: r_res,i_res
  1801 +
  1802 + rz=dble(z)
  1803 + iz=aimag(z)
  1804 + if ( iz == 0._8 ) then
  1805 + fvn_z_acos=fvn_z_acos_real(rz)
  1806 + return
  1807 + end if
  1808 +
  1809 + x=dabs(rz)
  1810 + y=dabs(iz)
  1811 + r=fvn_d_hypot(x+1.,y)
  1812 + s=fvn_d_hypot(x-1.,y)
  1813 + a=0.5*(r + s)
  1814 + b=x/a
  1815 + y2=y*y
  1816 +
  1817 + if (b <= b_crossover) then
  1818 + r_res=dacos(b)
  1819 + else
  1820 + if (x <= 1.) then
  1821 + d=0.5*(a+x)*(y2/(r+x+1)+(s + (1 - x)))
  1822 + r_res=datan(dsqrt(d)/x)
  1823 + else
  1824 + apx=a+x
  1825 + d=0.5*(apx/(r+x+1)+apx/(s + (x - 1)))
  1826 + r_res=datan((y*dsqrt(d))/x);
  1827 + end if
  1828 + end if
  1829 +
  1830 + if (a <= a_crossover) then
  1831 + if (x < 1.) then
  1832 + am1=0.5*(y2 / (r + (x + 1)) + y2 / (s + (1 - x)))
  1833 + else
  1834 + am1=0.5*(y2 / (r + (x + 1)) + (s + (x - 1)))
  1835 + end if
  1836 + i_res = dlog(1.+(am1 + sqrt (am1 * (a + 1))));
  1837 + else
  1838 + i_res = dlog (a + dsqrt (a*a - 1.));
  1839 + end if
  1840 + if (rz <0.) then
  1841 + r_res=fvn_pi-r_res
  1842 + end if
  1843 + i_res=-sign(1._8,iz)*i_res
  1844 + fvn_z_acos=dcmplx(r_res)+fvn_i*dcmplx(i_res)
  1845 +
  1846 +end function fvn_z_acos
  1847 +
  1848 +function fvn_z_acos_real(r)
  1849 + ! return the double complex arc cosinus for a
  1850 + ! double precision argument
  1851 + implicit none
  1852 + real(kind=8) :: r
  1853 + complex(kind=8) :: fvn_z_acos_real
  1854 +
  1855 + if (dabs(r)<=1._8) then
  1856 + fvn_z_acos_real=dcmplx(dacos(r))
  1857 + return
  1858 + end if
  1859 + if (r < 0._8) then
  1860 + fvn_z_acos_real=dcmplx(fvn_pi)-fvn_i*dcmplx(fvn_d_acosh(-r))
  1861 + else
  1862 + fvn_z_acos_real=fvn_i*dcmplx(fvn_d_acosh(r))
  1863 + end if
  1864 +end function
  1865 +
  1866 +
  1867 +function fvn_z_asin(z)
  1868 + ! double complex arcsin function derived from
  1869 + ! the c gsl library
  1870 + ! http://www.gnu.org/software/gsl/
  1871 + implicit none
  1872 + complex(kind=8) :: fvn_z_asin
  1873 + complex(kind=8) :: z
  1874 + real(kind=8) :: rz,iz,x,y,a,b,y2,r,s,d,apx,am1
  1875 + real(kind=8),parameter :: a_crossover=1.5_8,b_crossover = 0.6417_8
  1876 + real(kind=8) :: r_res,i_res
  1877 +
  1878 + rz=dble(z)
  1879 + iz=aimag(z)
  1880 + if ( iz == 0._8 ) then
  1881 + ! z is real
  1882 + fvn_z_asin=fvn_z_asin_real(rz)
  1883 + return
  1884 + end if
  1885 +
  1886 + x=dabs(rz)
  1887 + y=dabs(iz)
  1888 + r=fvn_d_hypot(x+1.,y)
  1889 + s=fvn_d_hypot(x-1.,y)
  1890 + a=0.5*(r + s)
  1891 + b=x/a
  1892 + y2=y*y
  1893 +
  1894 + if (b <= b_crossover) then
  1895 + r_res=dasin(b)
  1896 + else
  1897 + if (x <= 1.) then
  1898 + d=0.5*(a+x)*(y2/(r+x+1)+(s + (1 - x)))
  1899 + r_res=datan(x/dsqrt(d))
  1900 + else
  1901 + apx=a+x
  1902 + d=0.5*(apx/(r+x+1)+apx/(s + (x - 1)))
  1903 + r_res=datan(x/(y*dsqrt(d)));
  1904 + end if
  1905 + end if
  1906 +
  1907 + if (a <= a_crossover) then
  1908 + if (x < 1.) then
  1909 + am1=0.5*(y2 / (r + (x + 1)) + y2 / (s + (1 - x)))
  1910 + else
  1911 + am1=0.5*(y2 / (r + (x + 1)) + (s + (x - 1)))
  1912 + end if
  1913 + i_res = dlog(1.+(am1 + sqrt (am1 * (a + 1))));
  1914 + else
  1915 + i_res = dlog (a + dsqrt (a*a - 1.));
  1916 + end if
  1917 + r_res=sign(1._8,rz)*r_res
  1918 + i_res=sign(1._8,iz)*i_res
  1919 + fvn_z_asin=dcmplx(r_res)+fvn_i*dcmplx(i_res)
  1920 +
  1921 +end function fvn_z_asin
  1922 +
  1923 +function fvn_z_asin_real(r)
  1924 + ! return the double complex arc sinus for a
  1925 + ! double precision argument
  1926 + implicit none
  1927 + real(kind=8) :: r
  1928 + complex(kind=8) :: fvn_z_asin_real
  1929 +
  1930 + if (dabs(r)<=1._8) then
  1931 + fvn_z_asin_real=dcmplx(dasin(r))
  1932 + return
  1933 + end if
  1934 + if (r < 0._8) then
  1935 + fvn_z_asin_real=dcmplx(-fvn_pi/2._8)+fvn_i*dcmplx(fvn_d_acosh(-r))
  1936 + else
  1937 + fvn_z_asin_real=dcmplx(fvn_pi/2._8)-fvn_i*dcmplx(fvn_d_acosh(r))
  1938 + end if
  1939 +end function fvn_z_asin_real
  1940 +
  1941 +function fvn_d_acosh(r)
  1942 + ! return the arc hyperbolic cosine
  1943 + implicit none
  1944 + real(kind=8) :: r
  1945 + real(kind=8) :: fvn_d_acosh
  1946 + if (r >=1) then
  1947 + fvn_d_acosh=dlog(r+dsqrt(r*r-1))
  1948 + else
  1949 + !! TODO : Better error handling!!!!!!
  1950 + stop "Argument to fvn_d_acosh lesser than 1"
  1951 + end if
  1952 +end function fvn_d_acosh
  1953 +
  1954 +function fvn_d_asinh(r)
  1955 + ! return the arc hyperbolic sine
  1956 + implicit none
  1957 + real(kind=8) :: r
  1958 + real(kind=8) :: fvn_d_asinh
  1959 + fvn_d_asinh=dlog(r+dsqrt(r*r+1))
  1960 +end function fvn_d_asinh
  1961 +
  1962 +function fvn_d_hypot(a,b)
  1963 + implicit none
  1964 + ! return the euclidian norm of vector(a,b)
  1965 + real(kind=8) :: a,b
  1966 + real(kind=8) :: fvn_d_hypot
  1967 + fvn_d_hypot=dsqrt(a*a+b*b)
  1968 +end function
1775 1969  
1776 1970  
1777 1971