c From: "COMPUTATIONAL PHYSICS, 2nd Ed" c by RH Landau, MJ Paez, and CC Bordeianu c Copyright Wiley-VCH, 2007. c Electronic Materials copyright: R Landau, Oregon State Univ, 2007; c MJ Paez, Univ Antioquia, 2007; and CC Bordeianu, Univ Bucharest, 2007. c Support by National Science Foundation c c scatt.f: scattering phase shift in momentum space from delta shell c potential, LU decomposition with partial pivoting. c uses gauss.f, LUfactor, LUSolve (included) c Program scatt Integer n, Size, i, j, Row, Column Double Precision b, Pot Parameter (Size = 300, pi = 3.1415926535897932384626, b = 10.) Double Precision lambda, scale, ko, Temp, F(Size, Size) Double Precision k(Size), w(Size), D(Size), r(Size), V(Size) Double Precision L(Size, Size), U(Size,Size), P(Size,Size) Integer PivotInfo(Size) c Input potential strength lambda Write(*, *) 'enter lambda' Read(*, *) lambda Write(*, *) 'enter scaling factor' Read(*, *) scale Write(*, *) 'enter ko' Read(*, *) ko Write(*, *) 'enter grid size' Read(*, *) n c Set up Gaussian pts &wts, intrvl [0, inf], mid-point at 'scale'. c Set last element in k array to ko Call gauss(n, 2, 0d0, scale, k, w) Do i = 1, n D(i) = 2.d0/pi*w(i)*k(i)*k(i)/(k(i)*k(i)-ko*ko) End Do D(n+1) = 0. Do j = 1, n D(n+1) = D(n+1)+w(j)*ko*ko/(k(j)*k(j)-ko*ko) End Do D(n+1) = D(n+1)*(-2.d0/pi) c Set up F matrix and V vector Do i = 1, n+1 Do j = 1, n+1 Pot = -b*b*lambda*SIN(b*k(i))*SIN(b*k(j)) Pot = Pot/(k(i)*b*k(j)*b) F(i, j) = Pot*D(j) IF (i .EQ. j) Then F(i, j) = F(i, j)+1.d0 Endif End Do V(i) = Pot End Do c c LU factorization. LU factors of F, store partial pivoting info call LUfactor(F, n+1, Size, L, U, PivotInfo) c Pivot and solve, set P to identity matrix Do Row = 1, n+1 Do Column = 1, n+1 P(Row, Column) = 0 If (Row .EQ. Column) P(Row, Column) = 1 End Do End Do c Interchange rows to get true P matrix Do Row = 1, n+1 Do Column = 1, n+1 Temp = P(Row, Column) P(Row, Column) = P(PivotInfo(Row), Column) P(PivotInfo(Row), Column) = Temp End Do End Do Call LUSolve(V, L, U, n+1, Size, PivotInfo, r) c Output results Write(*, *) ko*ko, Datan(-r(n+1)*ko) End c LU factorization, partial pivoting of A in prep for solving Ax = b Subroutine LUfactor(A, n, Size, L, U, PivotInfo) Integer n, Column, CurrentPivotRow, CurrentRow, SwapCol, Row Integer ElimCol, Size Double Precision A(Size, Size), L(Size, Size), U(Size, Size) Integer PivotInfo(Size) Double Precision CurrentPivotValue, Swap Do Column = 1, n-1 CurrentPivotRow = Column CurrentPivotValue = A(CurrentPivotRow, Column) c Determine row for largest pivot Do CurrentRow = Column+1, n If (DABS(A(CurrentRow, Column)) .GT. CurrentPivotValue) Then CurrentPivotValue = DABS(A(CurrentRow, Column)) CurrentPivotRow = CurrentRow Endif End Do PivotInfo(Column) = CurrentPivotRow c Swap rows so largest value at pivot Do SwapCol = Column, n Swap = A(Column, SwapCol) A(Column, SwapCol) = A(PivotInfo(Column), SwapCol) A(PivotInfo(Column), Swapcol) = Swap End Do c Gaussian Elimination c Get upper triangular A and un-pivoted lower triangular L Do Row = Column+1, n L(Row, Column) = A(Row, Column)/A(Column, Column) Do ElimCol = Column+1, n A(Row,ElimCol) = A(Row,ElimCol) - L(Row,Column) * A(Column,ElimCol) End Do End Do End Do c Make sure bottom right value doesnot get pivoted to 0 PivotInfo(n) = n c Now pivot the L Do Row = 2, n-1 Do Column = 1, Row-1 Swap = L(Row, Column) L(Row, Column) = L(PivotInfo(Row), Column) L(PivotInfo(Row), Column) = Swap End Do End Do c clean up L and U Do Column = 1, n Do Row = 1, Column U(Row, Column) = A(Row, Column) L(Row, Column) = 0 IF (Row .EQ. Column) L(Row, Column) = 1 End Do Do Row = Column+1, n U(Row, Column) = 0 End Do End Do Return End Subroutine LUSolve(b, L, U, n, Size, PivotInfo, x) Integer n, Size, Row, Column Double Precision b(Size), x(Size) Integer PivotInfo(Size) Double Precision L(Size, Size), U(Size, Size) Double Precision Temp c Interchange rows of b for pivoting Do Row = 1, n Temp = b(Row) b(Row) = b(PivotInfo(Row)) b(PivotInfo(Row)) = Temp End Do c Solve Ly = b by forward elimination, since L diagonal, y(1) = b(1) Do Row = 2, n Do Column = 1, Row-1 b(Row) = b(Row)-L(Row, Column)*b(Column) End Do b(Row) = b(Row)/L(Row, Row) End Do c solve Ux = y by back substitution x(n) = b(n)/U(n, n) Do Row = n-1, 1, -1 x(Row) = b(Row) Do Column = Row+1, n x(Row) = x(Row)-U(Row, Column)*x(Column) End Do x(Row) = x(Row)/U(Row, Row) End Do Return End