lxsd / fvn

Download as
Browse Code ยป

Commit 8a085e03510a4dc6ba9606d81bb929d53a680dfc

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

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

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

... ... @@ -65,6 +65,7 @@
65 65 ! inva (out) : inversed matrix
66 66 ! status (ou) : =0 if something failed
67 67 !
  68 + implicit none
68 69 integer, intent(in) :: d
69 70 real, intent(in) :: a(d,d)
70 71 real, intent(out) :: inva(d,d)
... ... @@ -113,6 +114,7 @@
113 114 ! inva (out) : inversed matrix
114 115 ! status (ou) : =0 if something failed
115 116 !
  117 + implicit none
116 118 integer, intent(in) :: d
117 119 double precision, intent(in) :: a(d,d)
118 120 double precision, intent(out) :: inva(d,d)
... ... @@ -161,6 +163,7 @@
161 163 ! inva (out) : inversed matrix
162 164 ! status (ou) : =0 if something failed
163 165 !
  166 + implicit none
164 167 integer, intent(in) :: d
165 168 complex, intent(in) :: a(d,d)
166 169 complex, intent(out) :: inva(d,d)
... ... @@ -210,6 +213,7 @@
210 213 ! inva (out) : inversed matrix
211 214 ! status (ou) : =0 if something failed
212 215 !
  216 + implicit none
213 217 integer, intent(in) :: d
214 218 double complex, intent(in) :: a(d,d)
215 219 double complex, intent(out) :: inva(d,d)
... ... @@ -264,6 +268,7 @@
264 268 ! a (in) : The Matrix
265 269 ! status (out) : =0 if LU factorization failed
266 270 !
  271 + implicit none
267 272 integer, intent(in) :: d
268 273 real, intent(in) :: a(d,d)
269 274 integer, intent(out) :: status
... ... @@ -306,6 +311,7 @@
306 311 ! a (in) : The Matrix
307 312 ! status (out) : =0 if LU factorization failed
308 313 !
  314 + implicit none
309 315 integer, intent(in) :: d
310 316 double precision, intent(in) :: a(d,d)
311 317 integer, intent(out) :: status
... ... @@ -347,6 +353,7 @@
347 353 ! a (in) : The Matrix
348 354 ! status (out) : =0 if LU factorization failed
349 355 !
  356 + implicit none
350 357 integer, intent(in) :: d
351 358 complex, intent(in) :: a(d,d)
352 359 integer, intent(out) :: status
... ... @@ -390,6 +397,7 @@
390 397 ! det (out) : determinant
391 398 ! status (out) : =0 if LU factorization failed
392 399 !
  400 + implicit none
393 401 integer, intent(in) :: d
394 402 double complex, intent(in) :: a(d,d)
395 403 integer, intent(out) :: status
... ... @@ -441,6 +449,7 @@
441 449 ! rcond (out) : guess what
442 450 ! status (out) : =0 if something went wrong
443 451 !
  452 + implicit none
444 453 integer, intent(in) :: d
445 454 real, intent(in) :: a(d,d)
446 455 real, intent(out) :: rcond
... ... @@ -493,6 +502,7 @@
493 502 ! rcond (out) : guess what
494 503 ! status (out) : =0 if something went wrong
495 504 !
  505 + implicit none
496 506 integer, intent(in) :: d
497 507 double precision, intent(in) :: a(d,d)
498 508 double precision, intent(out) :: rcond
... ... @@ -546,6 +556,7 @@
546 556 ! rcond (out) : guess what
547 557 ! status (out) : =0 if something went wrong
548 558 !
  559 + implicit none
549 560 integer, intent(in) :: d
550 561 complex, intent(in) :: a(d,d)
551 562 real, intent(out) :: rcond
... ... @@ -598,6 +609,7 @@
598 609 ! rcond (out) : guess what
599 610 ! status (out) : =0 if something went wrong
600 611 !
  612 + implicit none
601 613 integer, intent(in) :: d
602 614 double complex, intent(in) :: a(d,d)
603 615 double precision, intent(out) :: rcond
... ... @@ -657,7 +669,7 @@
657 669 ! integer (out) : status =0 if something went wrong
658 670 !
659 671 ! interfacing Lapack routine SGEEV
660   -
  672 + implicit none
661 673 integer, intent(in) :: d
662 674 real, intent(in) :: a(d,d)
663 675 complex, intent(out) :: evala(d)
... ... @@ -730,6 +742,7 @@
730 742 ! integer (out) : status =0 if something went wrong
731 743 !
732 744 ! interfacing Lapack routine DGEEV
  745 + implicit none
733 746 integer, intent(in) :: d
734 747 double precision, intent(in) :: a(d,d)
735 748 double complex, intent(out) :: evala(d)
... ... @@ -803,7 +816,7 @@
803 816 ! integer (out) : status =0 if something went wrong
804 817 !
805 818 ! interfacing Lapack routine CGEEV
806   -
  819 + implicit none
807 820 integer, intent(in) :: d
808 821 complex, intent(in) :: a(d,d)
809 822 complex, intent(out) :: evala(d)
... ... @@ -851,7 +864,7 @@
851 864 ! integer (out) : status =0 if something went wrong
852 865 !
853 866 ! interfacing Lapack routine ZGEEV
854   -
  867 + implicit none
855 868 integer, intent(in) :: d
856 869 double complex, intent(in) :: a(d,d)
857 870 double complex, intent(out) :: evala(d)
858 871  
... ... @@ -1079,7 +1092,127 @@
1079 1092 end function
1080 1093  
1081 1094  
  1095 +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  1096 +!
  1097 +! Least square problem
1082 1098 !
  1099 +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  1100 +!
  1101 +!
  1102 +subroutine fvn_d_lspoly(np,x,y,deg,coeff,status)
  1103 +!
  1104 +! Least square polynomial fitting
  1105 +!
  1106 +! Find the coefficients of the least square polynomial of a given degree
  1107 +! for a set of coordinates.
  1108 +!
  1109 +! The degree must be lower than the number of points
  1110 +!
  1111 +! np (in) : number of points
  1112 +! x(np) (in) : x data
  1113 +! y(np) (in) : y data
  1114 +! deg (in) : polynomial's degree
  1115 +! coeff(deg+1) (out) : polynomial coefficients
  1116 +! status (out) : =0 if a problem occurs
  1117 +!
  1118 +implicit none
  1119 +
  1120 +integer, intent(in) :: np,deg
  1121 +real(kind=8), intent(in), dimension(np) :: x,y
  1122 +real(kind=8), intent(out), dimension(deg+1) :: coeff
  1123 +integer, intent(out) :: status
  1124 +
  1125 +real(kind=8), allocatable, dimension(:,:) :: mat,bmat
  1126 +real(kind=8),dimension(:),allocatable :: work,singval
  1127 +real(kind=8),dimension(1) :: twork
  1128 +integer :: lwork,info,rank
  1129 +
  1130 +integer :: i,j
  1131 +
  1132 +status=1
  1133 +allocate(mat(np,deg+1),bmat(np,1),singval(deg+1))
  1134 +
  1135 +! Design matrix valorisation
  1136 +mat=reshape( (/ ((x(i)**(j-1),i=1,np),j=1,deg+1) /),shape=(/ np,deg+1 /) )
  1137 +
  1138 +! second member valorisation
  1139 +bmat=reshape ( (/ (y(i),i=1,np) /) ,shape = (/ np,1 /))
  1140 +
  1141 +! query workspace size
  1142 +call dgelss(np,deg+1,1,mat,np,bmat,np,singval,-1.,rank,twork,-1,info)
  1143 +lwork=twork(1)
  1144 +allocate(work(int(lwork)))
  1145 +! real call
  1146 +call dgelss(np,deg+1,1,mat,np,bmat,np,singval,-1.,rank,work,lwork,info)
  1147 +
  1148 +if (info /= 0) then
  1149 + status=0
  1150 +end if
  1151 +
  1152 + coeff = (/ (bmat(i,1),i=1,deg+1) /)
  1153 +
  1154 +deallocate(work)
  1155 +deallocate(mat,bmat,singval)
  1156 +end subroutine
  1157 +
  1158 +subroutine fvn_s_lspoly(np,x,y,deg,coeff,status)
  1159 +!
  1160 +! Least square polynomial fitting
  1161 +!
  1162 +! Find the coefficients of the least square polynomial of a given degree
  1163 +! for a set of coordinates.
  1164 +!
  1165 +! The degree must be lower than the number of points
  1166 +!
  1167 +! np (in) : number of points
  1168 +! x(np) (in) : x data
  1169 +! y(np) (in) : y data
  1170 +! deg (in) : polynomial's degree
  1171 +! coeff(deg+1) (out) : polynomial coefficients
  1172 +! status (out) : =0 if a problem occurs
  1173 +!
  1174 +implicit none
  1175 +
  1176 +integer, intent(in) :: np,deg
  1177 +real(kind=4), intent(in), dimension(np) :: x,y
  1178 +real(kind=4), intent(out), dimension(deg+1) :: coeff
  1179 +integer, intent(out) :: status
  1180 +
  1181 +real(kind=4), allocatable, dimension(:,:) :: mat,bmat
  1182 +real(kind=4),dimension(:),allocatable :: work,singval
  1183 +real(kind=4),dimension(1) :: twork
  1184 +integer :: lwork,info,rank
  1185 +
  1186 +integer :: i,j
  1187 +
  1188 +status=1
  1189 +allocate(mat(np,deg+1),bmat(np,1),singval(deg+1))
  1190 +
  1191 +! Design matrix valorisation
  1192 +mat=reshape( (/ ((x(i)**(j-1),i=1,np),j=1,deg+1) /),shape=(/ np,deg+1 /) )
  1193 +
  1194 +! second member valorisation
  1195 +bmat=reshape ( (/ (y(i),i=1,np) /) ,shape = (/ np,1 /))
  1196 +
  1197 +! query workspace size
  1198 +call sgelss(np,deg+1,1,mat,np,bmat,np,singval,-1.,rank,twork,-1,info)
  1199 +lwork=twork(1)
  1200 +allocate(work(int(lwork)))
  1201 +! real call
  1202 +call sgelss(np,deg+1,1,mat,np,bmat,np,singval,-1.,rank,work,lwork,info)
  1203 +
  1204 +if (info /= 0) then
  1205 + status=0
  1206 +end if
  1207 +
  1208 + coeff = (/ (bmat(i,1),i=1,deg+1) /)
  1209 +
  1210 +deallocate(work)
  1211 +deallocate(mat,bmat,singval)
  1212 +end subroutine
  1213 +
  1214 +
  1215 +!
1083 1216 ! Muller
1084 1217 !
1085 1218 !
... ... @@ -1799,8 +1932,8 @@
1799 1932 complex(kind=8),parameter :: i=(0._8,1._8)
1800 1933 real(kind=8) :: r_res,i_res
1801 1934  
1802   - rz=dble(z)
1803   - iz=aimag(z)
  1935 + rz=dreal(z)
  1936 + iz=dimag(z)
1804 1937 if ( iz == 0._8 ) then
1805 1938 fvn_z_acos=fvn_z_acos_real(rz)
1806 1939 return
... ... @@ -1875,8 +2008,8 @@
1875 2008 real(kind=8),parameter :: a_crossover=1.5_8,b_crossover = 0.6417_8
1876 2009 real(kind=8) :: r_res,i_res
1877 2010  
1878   - rz=dble(z)
1879   - iz=aimag(z)
  2011 + rz=dreal(z)
  2012 + iz=dimag(z)
1880 2013 if ( iz == 0._8 ) then
1881 2014 ! z is real
1882 2015 fvn_z_asin=fvn_z_asin_real(rz)