!
Subroutine Reg_SVD_Solver(key)
! key=1 -- regularization; key=2 -- too small singular values are cut away (preferred);
! key=any_other_number -- standard singular value decomposition
use Advertisement
use IMSLF90
implicit none
integer*4, intent(in) :: key
real*8 ro(1:2*l_max)
complex*16 f(1:2*n_max), r_p(2*n_max,1), sol(2*l_max,1), &
                   U(2*n_max,2*n_max), V(2*l_max,2*l_max)
real*8 lambda, nrm(2*n_max)
integer*4 s_max, number, i, j
lambda=0.d00
if (m.eq.0) then
 s_max=l_max; number=s_max
 r_p=(1.d00,0.d00); sol=(0.d00,0.d00); ro=0.d00
! call Norming_Matrix(1, n_max, 1, l_max) !!!
 call lin_sol_svd(MATRIX(1:n_max, 1:l_max), r_p, sol, s=ro, u=U, v=V)
! call Norming_Right_Part(1, n_max) !!!
 call Projection(n_M(2,:), n_N(2,:))
 if (key.eq.2) call Number_Search
 if (key.eq.1) call Lambda_Search
 print *, ro(number)/ro(1), lambda, number
 call Solution_Assembling(l_M(2,:), l_N(2,:))
 number=s_max
 r_p=(1.d00,0.d00); sol=(0.d00,0.d00); ro=0.d00
! call Norming_Matrix(n_max+1, 2*n_max, l_max+1, 2*l_max)
 call lin_sol_svd(MATRIX(n_max+1:2*n_max, l_max+1:2*l_max), r_p, sol, &
                         s=ro, u=U, v=V)
! call Norming_Right_Part(1, n_max)
 call Projection(n_N(2,:), n_M(2,:))
 if (key.eq.2) call Number_Search
 if (key.eq.1) call Lambda_Search
 print *, ro(number)/ro(1), lambda, number
 call Solution_Assembling(l_N(2,:), l_M(2,:))
else
 s_max=2*l_max; number=s_max
 r_p=(1.d00,0.d00); sol=(0.d00,0.d00); ro=0.d00
! call Norming_Matrix(1, 2*n_max, 1, 2*l_max)
 call lin_sol_svd(MATRIX(1:2*n_max, 1:2*l_max), r_p, sol, s=ro, u=U, v=V)
! call Norming_Right_Part(1, 2*n_max)
 call Projection(n_M(2,:), n_N(3,:))
 if (key.eq.2) call Number_Search
 if (key.eq.1) call Lambda_Search
 print *, ro(number)/ro(1), lambda, number
 call Solution_Assembling(l_M(2,:), l_N(3,:))
 do i=n_max+1, 2*n_max !*****Sign Change to Obtain theSecond System************
 do j=1, 2*n_max
  U(i, j)=-U(i, j)
 end do
end do
do i=l_max+1, 2*l_max
 do j=1, 2*l_max
  V(i, j)=-V(i, j)
 end do
end do !***************************************************************
! call Norming_Right_Part(1, 2*n_max)
 call Projection(n_M(3,:), n_N(2,:))
 if (key.eq.1) call Lambda_Search
 print *, ro(number)/ro(1), lambda, number
 call Solution_Assembling(l_M(3,:), l_N(2,:))
end if
Contains
!
!*********The Evaluation of Right Part Projections on Left Singular Vectors**********
Subroutine Projection(ff1, ff2)
implicit none
complex*16, intent(in) :: ff1(n_max), ff2(n_max)
complex*16 ff(2*n_max)
f=(0.d00, 0.d00)
if (m.eq.0) then
 do i=1, n_max
  do j=1, n_max
   f(i)=f(i)+ff1(j)*DCONJG(U(j, i))
  end do
 end do
else
 do i=1, n_max
  ff(i)=ff1(i); ff(i+n_max)=ff2(i)
 end do
 do i=1, 2*n_max
  do j=1, 2*n_max
   f(i)=f(i)+ff(j)*DCONJG(U(j, i))
  end do
 end do
end if
End Subroutine Projection
!
!*******Solution Expression via Singular Decomposotion*************************
Subroutine Solution_Assembling(ff1, ff2)
implicit none
complex*16, intent(out) :: ff1(l_max), ff2(l_max)
if (m.eq.0) then
 ff1=(0.d00, 0.d00)
 do i=1, number !
  ff1(1:l_max)=ff1(1:l_max)+f(i)*ro(i)/(ro(i)**2+lambda)*V(1:l_max, i)
 end do
else
 ff1=(0.d00, 0.d00); ff2=(0.d00, 0.d00)
 do i=1, number !
  ff1(1:l_max)=ff1(1:l_max)+f(i)*ro(i)/(ro(i)**2+lambda)*V(1:l_max, i)
  ff2(1:l_max)=ff2(1:l_max)+f(i)*ro(i)/(ro(i)**2+lambda)*V(1+l_max:2*l_max, i)
 end do
end if
End Subroutine Solution_Assembling
!
!*******************Optimal Number of Terms Search***********************
Subroutine Number_Search
implicit none
real*8 limit
if (exc.gt.0.d00) limit=limit1
if (exc.lt.0.d00) limit=limit2
do i=s_max, 1, -1
 if (ro(i)/ro(1).lt.limit) number=number-1
end do
End Subroutine Number_Search
!*********************Four-Point Maximum Search*************************
Subroutine Lambda_Search
implicit none
parameter delta=1.d-09, n4in=1.d00
real*8 lm(4), klm(4), p
complex*16 tr
tr=(0.d00,0.d00)
do i=1, s_max
 tr=tr+f(i)
end do
if (tr.eq.(0.d00,0.d00)) then
 lambda=0.d00
else
lm(1)=0.d00; lm(4)=n4in
p=(lm(4)-lm(1))/3.d00
lm(2)=lm(1)+p; lm(3)=lm(2)+p
klm(1)=k(lm(1)); klm(2)=k(lm(2)); klm(3)=k(lm(3))
do
 klm(4)=k(lm(4))
 p=klm(1); j=1
 do i=2, 4
  if (klm(i).gt.p) then 
   p=klm(i); j=i
  end if
 end do
 if (j.le.3) Exit
 lm(4)=2.d00*lm(4)
end do
do
 p=(lm(4)-lm(1))/3.d00
 lm(2)=lm(1)+p; lm(3)=lm(2)+p+p/1.d02
 klm(2)=k(lm(2)); klm(3)=k(lm(3))
 p=klm(1); j=1
 do i=2, 4
  if (klm(i).gt.p) then 
   p=klm(i); j=i
  end if
 end do
 if (j.eq.1) then
  lm(4)=lm(2); klm(4)=klm(2)
 end if
 if (j.eq.2.or.j.eq.3) then
  lm(1)=lm(j-1); klm(1)=klm(j-1)
  lm(4)=lm(j+1); klm(4)=klm(j+1)
 end if
 if (j.eq.4) then
  lm(1)=lm(3); klm(1)=klm(3)
 end if
 lambda=(lm(4)+lm(1))/2.d00
 if (dabs(klm(4)-klm(1))/(klm(4)+klm(1))/2.d00.lt.delta) Exit
end do
end if
lambda=lambda/1.d00 !
End Subroutine Lambda_Search
!
!**************L-Curve Curvature Calculation*******************************
Real*8 Function k(lmd)
implicit none
real*8, intent(in) :: lmd
real*8 fro, rorola, rola2, rola3, rola4, norm1, norm2, res1, res2
norm1=0.d00; norm2=0.d00; res1=0.d00; res2=0.d00
do i=1, s_max
 fro=ro(i)*ro(i)*(cdabs(f(i))**2)
 rola2=ro(i)*ro(i)+lmd
 rorola=ro(i)*ro(i)/rola2
 rola3=rola2**3
 rola4=rola3*rola2
 rola2=rola2**2
 res1=res1+fro*(rorola-1.d00)/rola2
 res2=res2+fro*(3.d00*rorola-2.d00)/rola3
 norm1=norm1+fro/rola3
 norm2=norm2+fro/rola4
end do
res1=-2.d00*res1; res2=2.d00*res2
norm1=-2.d00*norm1; norm2=6.d00*norm2
k=dabs(res1*norm2-res2*norm1)/dsqrt((res1**2+norm1**2)**3)
End Function k
!
Subroutine Curve_Drow
implicit none
parameter width=1.d01
real*8 step
step=width/1000
lambda=0.d00
do i=1, 1000
write (06,*) lambda, k(lambda)
lambda=lambda+step
end do
End Subroutine Curve_Drow
!
Subroutine Norming_Matrix(n1, n2, l1, l2)
implicit none
integer*4, intent(in) :: n1, n2, l1, l2
real*8 max, mod
do i=n1, n2
   max=-1.d00
  do j=l1, l2
     mod=cdabs(MATRIX(i,j))
     if (mod.gt.max) max=mod
  end do
  j=1; nrm(i)=1.d00
  if (max.lt.1.d00) then
    do
       max=max*2.d00   
       if (max.le.1.d00) then
	     nrm(i)=nrm(i)/2.d00
	     j=j+1
       else 
	     Exit
	   end if 
    end do
   else
    do
       max=max/2.d00
       if (max/2.d00.ge.1.d00) then
	     nrm(i)=nrm(i)*2.d00
	     j=j+1
       else 
	     Exit
	   end if 
     end do
   end if
end do
do i=n1, n2
  do j=l1, l2
       MATRIX(i,j)=MATRIX(i,j)/nrm(i)
  end do
end do
End Subroutine Norming_Matrix
!
Subroutine Norming_Right_Part(n1, n2)
implicit none
integer*4, intent(in) :: n1, n2
do i=n1, n2
  r_p(i,1)=r_p(i,1)/nrm(i)
end do
End Subroutine Norming_Right_Part
!
End Subroutine Reg_SVD_Solver
!
