📄 errors_prb.f90
字号:
return
end
subroutine test05
!
!*******************************************************************************
!
!! TEST05
!
implicit none
!
integer, parameter :: n = 4
!
real c(0:n)
real q
real r
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) '+=============================================+'
write ( *, '(a)' ) '| |'
write ( *, '(a)' ) '| Exercise 5 |'
write ( *, '(a)' ) '| |'
write ( *, '(a)' ) '| Q = 0.707107 |'
write ( *, '(a)' ) '| |'
write ( *, '(a)' ) '| Compute: |'
write ( *, '(a)' ) '| |'
write ( *, '(a)' ) '| R = |'
write ( *, '(a)' ) '| 8118 * Q**4 |'
write ( *, '(a)' ) '| - 11482 * Q**3 |'
write ( *, '(a)' ) '| + Q**2 |'
write ( *, '(a)' ) '| + 5741 * Q |'
write ( *, '(a)' ) '| - 2030 |'
write ( *, '(a)' ) '| |'
write ( *, '(a)' ) '| Correct value: |'
write ( *, '(a)' ) '| |'
write ( *, '(a)' ) '| R = - 0.191527325270E-10 |'
write ( *, '(a)' ) '| |'
write ( *, '(a)' ) '+=============================================+'
write ( *, '(a)' ) ' '
q = 0.707107E+00
c(0) = - 2030.0E+00
c(1) = 5741.0E+00
c(2) = 1.0E+00
c(3) = - 11482.0E+00
c(4) = 8118.0E+00
call rpoly_val ( n, c, q, r )
write ( *, '(a,g14.6)' ) ' R (direct evaluation) = ', r
call rpoly_val_horner ( n, c, q, r )
write ( *, '(a,g14.6)' ) ' R (Horner''s method) = ', r
return
end
subroutine test06
!
!*******************************************************************************
!
!! TEST06
!
implicit none
!
integer, parameter :: n = 2
integer, parameter :: lda = n
!
real a(lda,n)
real ab(n)
integer i
integer info
integer ipivot(n)
integer job
real qraux(n)
real qty(n)
real qy(n)
real r(n)
real rsd(n)
real work(n)
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) '+=============================================+'
write ( *, '(a)' ) '| |'
write ( *, '(a)' ) '| Exercise 6 |'
write ( *, '(a)' ) '| |'
write ( *, '(a)' ) '| A = [ 64919121 - 159018721 ] |'
write ( *, '(a)' ) '| [ 41869520.5 - 102558961 ] |'
write ( *, '(a)' ) '| |'
write ( *, '(a)' ) '| B = [ 1 ] |'
write ( *, '(a)' ) '| [ 0 ] |'
write ( *, '(a)' ) '| |'
write ( *, '(a)' ) '| Solve: |'
write ( *, '(a)' ) '| |'
write ( *, '(a)' ) '| A * X = B |'
write ( *, '(a)' ) '| |'
write ( *, '(a)' ) '| Correct X: |'
write ( *, '(a)' ) '| |'
write ( *, '(a)' ) '| 205,117,922.0 |'
write ( *, '(a)' ) '| 83,739,041.0 |'
write ( *, '(a)' ) '| |'
write ( *, '(a)' ) '+=============================================+'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' R1: Gauss elimination using SGEFA and SGESL'
write ( *, '(a)' ) ' R2: QR factorization using SQRDC and SQRSL.'
write ( *, '(a)' ) ' '
a(1,1) = 64919121.0E+00
a(1,2) = -159018721.0E+00
a(2,1) = 41869520.5E+00
a(2,2) = -102558961.0E+00
r(1) = 1.0E+00
r(2) = 0.0E+00
call sgefa ( a, lda, n, ipivot, info )
if ( info == 0 ) then
job = 0
call sgesl ( a, lda, n, ipivot, r, job )
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Gauss elimination solution:'
write ( *, '(a)' ) ' '
do i = 1, n
write ( *, '(i4,g14.6)' ) i, r(i)
end do
else
write ( *, '(a,i4)' ) ' SGEFA failed, returning INFO = ', info
end if
a(1,1) = 64919121.0E+00
a(1,2) = -159018721.0E+00
a(2,1) = 41869520.5E+00
a(2,2) = -102558961.0E+00
r(1) = 1.0E+00
r(2) = 0.0E+00
job = 0
call sqrdc ( a, lda, n, n, qraux, ipivot, work, job )
job = 110
call sqrsl ( a, lda, n, n, qraux, r, qy, qty, r, rsd, ab, job, info )
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Least Squares solution:'
write ( *, '(a)' ) ' '
do i = 1, n
write ( *, '(g14.6)' ) r(i)
end do
return
end
subroutine test065
!
!*******************************************************************************
!
!! TEST065
!
implicit none
!
integer, parameter :: n = 2
integer, parameter :: lda = n
!
real a(lda,n)
real a_save(n,n)
real ab(n)
real det(2)
integer i
integer info
integer ipivot(n)
integer job
real qraux(n)
real qty(n)
real qy(n)
real resid(n)
real rhs_save(n)
real rsd(n)
real work(n)
real x(n)
real x_save(n)
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) '+=============================================+'
write ( *, '(a)' ) '| |'
write ( *, '(a)' ) '| Exercise 6.5 |'
write ( *, '(a)' ) '| |'
write ( *, '(a)' ) '| A = [ 888445 887112 ] |'
write ( *, '(a)' ) '| [ 887112 885781 ] |'
write ( *, '(a)' ) '| |'
write ( *, '(a)' ) '| det ( A ) = 1 |'
write ( *, '(a)' ) '| |'
write ( *, '(a)' ) '| B = [ 1 ] |'
write ( *, '(a)' ) '| [ 0 ] |'
write ( *, '(a)' ) '| |'
write ( *, '(a)' ) '| Solve: |'
write ( *, '(a)' ) '| |'
write ( *, '(a)' ) '| A * X = B |'
write ( *, '(a)' ) '| |'
write ( *, '(a)' ) '| Correct X: |'
write ( *, '(a)' ) '| |'
write ( *, '(a)' ) '| 885781 |'
write ( *, '(a)' ) '| -887112 |'
write ( *, '(a)' ) '| |'
write ( *, '(a)' ) '+=============================================+'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' R1: Gauss elimination using SGEFA and SGESL'
write ( *, '(a)' ) ' R2: QR factorization using SQRDC and SQRSL.'
write ( *, '(a)' ) ' '
a_save(1,1) = 888445.0E+00
a_save(1,2) = 887112.0E+00
a_save(2,1) = 887112.0E+00
a_save(2,2) = 885781.0E+00
rhs_save(1:2) = (/ 1.0E+00, 0.0E+00 /)
x_save(1:2) = (/ 885781.0E+00, -887112.0E+00 /)
a(1:2,1:2) = a_save(1:2,1:2)
x(1:2) = rhs_save(1:2)
call sgefa ( a, lda, n, ipivot, info )
if ( info == 0 ) then
job = 0
call sgesl ( a, lda, n, ipivot, x, job )
resid(1:n) = matmul ( a_save(1:n,1:n), x(1:n) ) - rhs_save(1:n)
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Gauss elimination solution and residual:'
write ( *, '(a)' ) ' '
do i = 1, n
write ( *, '(i4,2g14.6)' ) i, x(i), resid(i)
end do
job = 10
call sgedi ( a, lda, n, ipivot, det, work, job )
write ( *, '(a)' ) ' '
write ( *, '(a,g14.6,a,g14.6)' ) 'SGEDI estimates determinant = ', &
det(1), ' * 10** ', det(2)
else
write ( *, '(a,i4)' ) ' SGEFA failed, returning INFO = ', info
end if
a(1:2,1:2) = a_save(1:2,1:2)
x(1:2) = rhs_save(1:2)
job = 0
call sqrdc ( a, lda, n, n, qraux, ipivot, work, job )
job = 110
call sqrsl ( a, lda, n, n, qraux, x, qy, qty, x, rsd, ab, job, info )
resid(1:n) = matmul ( a_save(1:n,1:n), x(1:n) ) - rhs_save(1:n)
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Least Squares solution and residual:'
write ( *, '(a)' ) ' '
do i = 1, n
write ( *, '(i4,2g14.6)' ) i, x(i), resid(i)
end do
resid(1:n) = matmul ( a_save(1:n,1:n), x_save(1:n) ) - rhs_save(1:n)
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Exact solution and residual:'
write ( *, '(a)' ) ' '
do i = 1, n
write ( *, '(i4,2g14.6)' ) i, x_save(i), resid(i)
end do
return
end
subroutine test07
!
!*******************************************************************************
!
!! TEST07
!
implicit none
!
integer, parameter :: n = 4
integer, parameter :: lda = n
!
real a(lda,n)
real ab(n)
integer i
integer info
integer ipivot(n)
integer job
real qraux(n)
real qty(n)
real qy(n)
real r(n)
real rsd(n)
real work(n)
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) '+=============================================+'
write ( *, '(a)' ) '| |'
write ( *, '(a)' ) '| Exercise 7 |'
write ( *, '(a)' ) '| |'
write ( *, '(a)' ) '| A = [ -367296 -43199 519436 -954302 ]|'
write ( *, '(a)' ) '| [ 259718 -477151 -367295 -1043199 ]|'
write ( *, '(a)' ) '| [ 886731 88897 -1254026 -1132096 ]|'
write ( *, '(a)' ) '| [ 627013 566048 -886732 911103 ]|'
write ( *, '(a)' ) '| |'
write ( *, '(a)' ) '| B = [ 1 ] |'
write ( *, '(a)' ) '| [ 1 ] |'
write ( *, '(a)' ) '| [ 1 ] |'
write ( *, '(a)' ) '| [ 0 ] |'
write ( *, '(a)' ) '| |'
write ( *, '(a)' ) '| Solve: |'
write ( *, '(a)' ) '| |'
write ( *, '(a)' ) '| A * X = B |'
write ( *, '(a)' ) '| |'
write ( *, '(a)' ) '| Correct X: |'
write ( *, '(a)' ) '| |'
write ( *, '(a)' ) '| 8.86731088897E+17 |'
write ( *, '(a)' ) '| 8.86731088897E+11 |'
write ( *, '(a)' ) '| 6.27013566048E+17 |'
write ( *, '(a)' ) '| 6.27013566048E+11 |'
write ( *, '(a)' ) '| |'
write ( *, '(a)' ) '+=============================================+'
write ( *, '(a)' ) ' '
a(1,1) = -367296.0E+00
a(1,2) = -43199.0E+00
a(1,3) = 519436.0E+00
a(1,4) = -954302.0E+00
a(2,1) = 259718.0E+00
a(2,2) = -477151.0E+00
a(2,3) = -367295.0E+00
a(2,4) = -1043199.0E+00
a(3,1) = 886731.0E+00
a(3,2) = 88897.0E+00
a(3,3) = -1254026.0E+00
a(3,4) = -1132096.0E+00
a(4,1) = 627013.0E+00
a(4,2) = 566048.0E+00
a(4,3) = -886732.0E+00
a(4,4) = 911103.0E+00
r(1:4) = (/ 1.0E+00, 1.0E+00, 1.0E+00, 0.0E+00 /)
call sgefa ( a, lda, n, ipivot, info )
if ( info /= 0 ) then
write ( *, '(a,i4)' ) ' SGEFA failed, returning INFO = ', info
else
job = 0
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -