lxsd / fvn

Download as
Browse Code ยป

Commit 126a3aed07763d1b0975159db844a6348597f38e

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

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

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

... ... @@ -1099,6 +1099,10 @@
1099 1099 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1100 1100 !
1101 1101 !
  1102 +
  1103 +
  1104 +
  1105 +
1102 1106 subroutine fvn_d_lspoly(np,x,y,deg,coeff,status)
1103 1107 !
1104 1108 ! Least square polynomial fitting
... ... @@ -1123,6 +1127,125 @@
1123 1127 integer, intent(out) :: status
1124 1128  
1125 1129 real(kind=8), allocatable, dimension(:,:) :: mat,bmat
  1130 +real(kind=8),dimension(:),allocatable :: work
  1131 +real(kind=8),dimension(1) :: twork
  1132 +integer :: lwork,info
  1133 +
  1134 +integer :: i,j
  1135 +
  1136 +status=1
  1137 +allocate(mat(np,deg+1),bmat(np,1))
  1138 +
  1139 +! Design matrix valorisation
  1140 +mat=reshape( (/ ((x(i)**(j-1),i=1,np),j=1,deg+1) /),shape=(/ np,deg+1 /) )
  1141 +
  1142 +! second member valorisation
  1143 +bmat=reshape ( (/ (y(i),i=1,np) /) ,shape = (/ np,1 /))
  1144 +
  1145 +! query workspace size
  1146 +call dgels('N',np,deg+1,1,mat,np,bmat,np,twork,-1,info)
  1147 +lwork=twork(1)
  1148 +allocate(work(int(lwork)))
  1149 +! real call
  1150 +call dgels('N',np,deg+1,1,mat,np,bmat,np,work,lwork,info)
  1151 +
  1152 +if (info /= 0) then
  1153 + status=0
  1154 +end if
  1155 +
  1156 + coeff = (/ (bmat(i,1),i=1,deg+1) /)
  1157 +
  1158 +deallocate(work)
  1159 +deallocate(mat,bmat)
  1160 +end subroutine
  1161 +
  1162 +subroutine fvn_s_lspoly(np,x,y,deg,coeff,status)
  1163 +!
  1164 +! Least square polynomial fitting
  1165 +!
  1166 +! Find the coefficients of the least square polynomial of a given degree
  1167 +! for a set of coordinates.
  1168 +!
  1169 +! The degree must be lower than the number of points
  1170 +!
  1171 +! np (in) : number of points
  1172 +! x(np) (in) : x data
  1173 +! y(np) (in) : y data
  1174 +! deg (in) : polynomial's degree
  1175 +! coeff(deg+1) (out) : polynomial coefficients
  1176 +! status (out) : =0 if a problem occurs
  1177 +!
  1178 +implicit none
  1179 +
  1180 +integer, intent(in) :: np,deg
  1181 +real(kind=4), intent(in), dimension(np) :: x,y
  1182 +real(kind=4), intent(out), dimension(deg+1) :: coeff
  1183 +integer, intent(out) :: status
  1184 +
  1185 +real(kind=4), allocatable, dimension(:,:) :: mat,bmat
  1186 +real(kind=4),dimension(:),allocatable :: work
  1187 +real(kind=4),dimension(1) :: twork
  1188 +integer :: lwork,info
  1189 +
  1190 +integer :: i,j
  1191 +
  1192 +status=1
  1193 +allocate(mat(np,deg+1),bmat(np,1))
  1194 +
  1195 +! Design matrix valorisation
  1196 +mat=reshape( (/ ((x(i)**(j-1),i=1,np),j=1,deg+1) /),shape=(/ np,deg+1 /) )
  1197 +
  1198 +! second member valorisation
  1199 +bmat=reshape ( (/ (y(i),i=1,np) /) ,shape = (/ np,1 /))
  1200 +
  1201 +! query workspace size
  1202 +call sgels('N',np,deg+1,1,mat,np,bmat,np,twork,-1,info)
  1203 +lwork=twork(1)
  1204 +allocate(work(int(lwork)))
  1205 +! real call
  1206 +call sgels('N',np,deg+1,1,mat,np,bmat,np,work,lwork,info)
  1207 +
  1208 +if (info /= 0) then
  1209 + status=0
  1210 +end if
  1211 +
  1212 + coeff = (/ (bmat(i,1),i=1,deg+1) /)
  1213 +
  1214 +deallocate(work)
  1215 +deallocate(mat,bmat)
  1216 +end subroutine
  1217 +
  1218 +
  1219 +
  1220 +
  1221 +
  1222 +
  1223 +
  1224 +
  1225 +subroutine fvn_d_lspoly_svd(np,x,y,deg,coeff,status)
  1226 +!
  1227 +! Least square polynomial fitting
  1228 +!
  1229 +! Find the coefficients of the least square polynomial of a given degree
  1230 +! for a set of coordinates.
  1231 +!
  1232 +! The degree must be lower than the number of points
  1233 +!
  1234 +! np (in) : number of points
  1235 +! x(np) (in) : x data
  1236 +! y(np) (in) : y data
  1237 +! deg (in) : polynomial's degree
  1238 +! coeff(deg+1) (out) : polynomial coefficients
  1239 +! status (out) : =0 if a problem occurs
  1240 +!
  1241 +implicit none
  1242 +
  1243 +integer, intent(in) :: np,deg
  1244 +real(kind=8), intent(in), dimension(np) :: x,y
  1245 +real(kind=8), intent(out), dimension(deg+1) :: coeff
  1246 +integer, intent(out) :: status
  1247 +
  1248 +real(kind=8), allocatable, dimension(:,:) :: mat,bmat
1126 1249 real(kind=8),dimension(:),allocatable :: work,singval
1127 1250 real(kind=8),dimension(1) :: twork
1128 1251 integer :: lwork,info,rank
... ... @@ -1155,7 +1278,7 @@
1155 1278 deallocate(mat,bmat,singval)
1156 1279 end subroutine
1157 1280  
1158   -subroutine fvn_s_lspoly(np,x,y,deg,coeff,status)
  1281 +subroutine fvn_s_lspoly_svd(np,x,y,deg,coeff,status)
1159 1282 !
1160 1283 ! Least square polynomial fitting
1161 1284 !