Sola/Fortran-95-2003-Program-3rd-Edition-Exercise
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

init

Browse Source
This commit is contained in:
SolaSUSTech
2025-09-25 16:33:13 +08:00
commit 88fdb762e0
15 changed files with 7983 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

319
指针测试.f90 Normal file
View File

@ -0,0 +1,319 @@
program example
implicit none
call test
call test2
end program example
module ModDoLinkList
implicit none
integer, parameter :: sgl=selected_real_kind(p=1)
type :: doNode
real(sgl) :: var1
type(doNode), pointer :: before
type(doNode), pointer :: next
end type
contains
recursive subroutine DoNodeAdd(newNode, ptr)
type(doNode), intent(inout), pointer :: newNode
type(doNode), intent(inout), pointer :: ptr
if ( .not. associated(newNode) ) stop ""
if ( associated(ptr) ) then
if ( associated(ptr%next) ) then
call DoNodeAdd(newNode, ptr%next)
else
ptr%next => newNode
newNode%before => ptr
end if
else
ptr => newNode
end if
end subroutine DoNodeAdd
subroutine test1(value, ptr)
type(doNode), intent(inout), target :: value
type(doNode), intent(inout), pointer :: ptr
type(doNode), pointer :: temp => null()
type(doNode), target :: a
type(doNode), pointer :: newNode => null()
allocate(newNode)
newNode%var1 = 200.
newNode%before => null()
newNode%next => null()
a%var1 = 100.
a%before => null()
a%next => null()
temp => value%before
temp%next => a
write(*, *)
write(*, *) '如果传递的是值, 则 ', value%var1
temp => ptr%before
ptr%before%next => a
write(*, *) '如果传递的是指针, 则 ', ptr%var1
newNode%before => ptr ! 插入结点前指针 => 操作结点
temp => ptr%next
temp%before => newNode ! 操作结点后指针指向的结点的前指针 => 插入结点
newNode%next => temp ! 插入结点的后指针 => 操作结点后指针指向的结点
ptr%next => newNode
end subroutine
recursive subroutine DoNodeSortForword(newNode, ptr) ! 向前排序
implicit none
type(doNode), intent(inout), target :: newNode ! 插入结点
type(doNode), intent(inout), target :: ptr ! 操作结点
type(doNode), pointer :: temp
write(*, *) '当前操作结点为: ', ptr%var1, '; 当前插入结点为:', newNode%var1
! if ( .not. associated(newNode) ) then ! 如果插入结点未关联
! stop "" ! 报错退出
! else ! 如果插入结点已关联
write(*, *) ' 插入结点存在'
if ( newNode%var1 < ptr%var1 ) then ! 如果插入结点值比操作结点值小
write(*, *) ' 插入结点值小于操作结点值'
if ( associated(ptr%before) ) then ! 如果操作结点前指针已关联
write(*, *) ' 由于操作结点值前指针已关联, 检测前一结点'
call DoNodeSortForword(newNode, ptr%before) ! 递归调用
else ! 如果操作结点前指针为空
write(*, *) ' 由于操作结点值前指针未关联, 则在最前端插入插入节点'
ptr%before => newNode ! 操作结点前指针 => 插入结点
newNode%next => ptr ! 插入结点后指针 => 操作节点
end if
else ! 如果插入结点值比操作结点值大
write(*, *) ' 插入结点值大于操作结点值, 将结点插入操作结点之后'
newNode%before => ptr ! 插入结点前指针 => 操作结点
write(*, *) ' 插入结点前指针指向: ', newNode%before%var1
temp => ptr%next
! ptr%next => newNode ! 操作结点的后指针 => 插入结点
temp%before => newNode ! 操作结点后指针指向的结点的前指针 => 插入结点
write(*, *) ' 操作结点后结点前指针指向:', temp%before%var1
newNode%next => temp ! 插入结点的后指针 => 操作结点后指针指向的结点
write(*, *) ' 插入结点后指针指向: ', newNode%next%var1
ptr%next => newNode
write(*, *) ' 操作结点后指针指向: ', ptr%next%var1
end if
! if ( .not. associated(ptr) ) then ! 如果操作结点前指针为空
! write(*, '(A)', advance='no') '10'
! ptr%before => newNode !
! newNode%next => ptr
! else
! write(*, '(A)', advance='no') '11'
! if ( newNode%var1 < ptr%var1 ) then
! call DoNodeSortForword(newNode, ptr%before)
! else
! newNode%before => ptr
! ptr%next%before => newNode
! newNode%next => ptr%next
! ptr%next => newNode
! end if
! end if
! newNode => null()
call DoNodePrint1(ptr)
write(*, *)
! ptr => null()
! end if
end subroutine DoNodeSortForword
recursive subroutine DoNodeSortForword1(newNode, ptr) ! 向前排序
implicit none
type(doNode), intent(in), pointer :: newNode ! 插入结点
type(doNode), intent(in), pointer :: ptr ! 操作结点
type(doNode), pointer :: temp
write(*, *) '当前操作结点为: ', ptr%var1, '; 当前插入结点为:', newNode%var1
if ( .not. associated(newNode) ) then ! 如果插入结点未关联
stop "" ! 报错退出
else ! 如果插入结点已关联
write(*, *) ' 插入结点存在'
if ( newNode%var1 < ptr%var1 ) then ! 如果插入结点值比操作结点值小
write(*, *) ' 插入结点值小于操作结点值'
if ( associated(ptr%before) ) then ! 如果操作结点前指针已关联
write(*, *) ' 由于操作结点值前指针已关联, 检测前一结点'
call DoNodeSortForword1(newNode, ptr%before) ! 递归调用
else ! 如果操作结点前指针为空
write(*, *) ' 由于操作结点值前指针未关联, 则在最前端插入插入节点'
ptr%before => newNode ! 操作结点前指针 => 插入结点
newNode%next => ptr ! 插入结点后指针 => 操作节点
end if
else ! 如果插入结点值比操作结点值大
! write(*, *) ' 插入结点值大于操作结点值, 将结点插入操作结点之后'
! newNode%before => ptr ! 插入结点前指针 => 操作结点
! write(*, *) ' 插入结点前指针指向: ', newNode%before%var1
! temp => ptr%next
! ptr%next => newNode ! 操作结点的后指针 => 插入结点
! ptr%next%before => newNode ! 操作结点后指针指向的结点的前指针 => 插入结点
! write(*, *) ' 操作结点后结点前指针指向:', temp%before%var1
! newNode%next => ptr%next ! 插入结点的后指针 => 操作结点后指针指向的结点
! write(*, *) ' 插入结点后指针指向: ', newNode%next%var1
! ptr%next => newNode
! write(*, *) ' 操作结点后指针指向: ', ptr%next%var1
!
! newNode%before => ptr
! newNode%next => ptr%next
! ptr%next => newNode
! newNode%next%before => newNode
!
write(*, *) ptr%next%var1
newNode%before => ptr
write(*, *) ptr%next%var1
temp => ptr%next
write(*, *) ptr%next%var1
! temp%before => newNode
write(*, *) ptr%next%var1
newNode%next => ptr%next
write(*, *) ptr%next%var1
! ptr%next => newNode
newNode%next%before => newNode
! ptr%next%before => newNode
write(*, *) ptr%next%var1
ptr%next => newNode
write(*, *) ptr%next%var1, newNode%next%var1
end if
call DoNodePrint1(ptr)
write(*, *)
end if
end subroutine DoNodeSortForword1
recursive subroutine DoNodePrint(ptr)
type(doNode), intent(in), pointer :: ptr
if ( associated(ptr) ) then
write(*, '(F6.2)', advance='no') ptr%var1
call DoNodePrint(ptr%next)
end if
end subroutine DoNodePrint
recursive subroutine DoNodePrint1(ptr)
type(doNode), intent(in), pointer :: ptr
if ( associated(ptr) ) then
write(*, '(F6.2)', advance='no') ptr%var1
call DoNodePrint1(ptr%before)
end if
end subroutine DoNodePrint1
end module ModDoLinkList
subroutine Test
use ModDoLinkList
implicit none
type(doNode), pointer :: newNode => null()
type(doNode), pointer :: head => null()
type(doNode), pointer :: tail => null()
type(doNode), pointer :: ptr => null()
real(sgl) :: temp
integer :: i
integer :: errorLevel
do i = 1, 21
allocate(newNode)
newNode%var1 = real(i)
newNode%before => null()
newNode%next => null()
if ( .not. associated(head) ) head => newNode
! if ( .not. associated(head) ) then
! head => newNode
! write(*, *) '已插入首结点 ', newNode%var1
! else
! call DoNodeAdd(newNode, head)
! write(*, *) '已插入结点 ', newNode%var1
! end if
call DoNodeAdd(newNode, tail)
tail => newNode
end do
allocate(newNode)
newNode%var1 = 17.5
newNode%before => null()
newNode%next => null()
ptr => head
do
if ( associated(ptr) ) then
write(*, '(F6.2)', advance='no') ptr%var1
ptr => ptr%next
else
exit
end if
end do
write(*, *)
ptr => tail
call DoNodeSortForword1(newNode, ptr)
call DoNodePrint(head)
write(*, *)
call DoNodePrint1(tail)
write(*, *)
do
if ( associated(head%before) ) then
head => head%before
else
exit
end if
end do
ptr => tail
ptr => head
write(*, *)
do
if ( associated(ptr) ) then
write(*, '(F6.2)', advance='no') ptr%var1
! write(*, *) '当前结点值为:', ptr%var1, '; 下一结点值为:', ptr%before%var1
! ptr => ptr%before
ptr => ptr%next
else
exit
end if
end do
ptr => tail%before
call test1(ptr, ptr)
write(*, *) ptr%before%var1, ptr%var1, ptr%next%var1, ptr%next%next%var1
end subroutine Test
subroutine test2
use ModDoLinkList
integer :: i
type(doNode), pointer :: newNode
type(doNode), pointer :: head
type(doNode), pointer :: middle
type(doNode), pointer :: tail
type(doNode), pointer :: ptr
allocate(newNode)
newNode%var1 = 1.
newNode%before => null()
newNode%next => null()
head => newNode
allocate(newNode)
newNode%var1 = 2.
newNode%before => null()
newNode%next => null()
head%next => newNode
newNode%before => head
middle => newNode
allocate(newNode)
newNode%var1 = 3.
newNode%before => null()
newNode%next => null()
middle%next => newNode
newNode%before => middle
tail => newNode
write(*, *) head%var1, middle%var1, tail%var1
! head%next => tail
! write(*, *) head%next%var1, middle%var1
! head%next%next => head
! write(*, *) head%next%next%var1, middle%next%var1, tail%var1
! ptr => head%next
! head%next => tail
! middle%var1 = 4.
! write(*, *) ptr%var1, head%next%var1
allocate(newNode)
newNode%var1 = 4.
newNode%before => null()
newNode%next => null()
newNode%before => middle
newNode%next => middle%next
! middle%next => newNode
! newNode%next%before => newNode
middle%next%before => newNode
middle%next => newNode
ptr => head
do
if ( associated(ptr) ) then
write(*, '(F10.2)', advance='no') ptr%var1
ptr => ptr%next
else
exit
end if
end do
write(*, *)
ptr => tail
do
if ( associated(ptr) ) then
write(*, '(F10.2)', advance='no') ptr%var1
ptr => ptr%before
else
exit
end if
end do
write(*, *)
end subroutine

56
程序模板.f90 Normal file
View File

@ -0,0 +1,56 @@
! ==============================================================================
! 通过 gfortran ./test.f90 -o ./run && ./run 运行
! 程序名：
!
! 目的:
!
! 修订记录:
! 日期 编程者 改动描述
! =================== ============= =====================================
!
! 程序结构:
!
! ==============================================================================
! 模块：
module ModName
implicit none
! 数据字典
! 声明常数
REAL, PARAMETER :: PI=3.14159265 ! PI值
REAL, PARAMETER :: e=2.718281828459 ! 自然对数
INTEGER, PARAMETER :: arrayLength=20 ! 数组基准长度
! 声明变量
! 创建显式接口
contains
subroutine SubName(varName1,varName2)
implicit none
! 数据字典
end subroutine SubName
end module ModName
! ==============================================================================
! 主程序：
program ProName
use ModName
implicit none
! 数据字典
! 声明常量
! 声明变量
! 变量初始化
! 数据输入
! 运算过程
! 结果输出
end program ProName
! ==============================================================================
! 子程序
! subroutine SubName(varName1,varName2)
! use MouName
! implicit none
! Type, intent(inout) :: varName
! end subroutine SubName
! ==============================================================================
! 函数
! function FunName(varName1,varName2)
! use MouName
! implicit none
! end function FunName
! ==============================================================================

641
第10章习题.f90 Normal file
View File

@ -0,0 +1,641 @@
! ==============================================================================
! 通过 gfortran ./test.f90 -o ./run && ./run 运行
! 程序名：
! 第10章习题，及书上例题
! 目的:
!
! 修订记录:
! 日期 编程者 改动描述
! =================== ============= =====================================
! 2021-05-10 17:15:53 Sola 测验10-1 4 判断星期几
! 2021-05-10 17:22:01 Sola 测验10-1 5 字符串反序
! 2021-05-10 17:33:13 Sola 测验10-1 6-8 测试字符
! 2021-05-10 18:14:05 Sola 例题10-3 转换输出数值格式
! 2021-05-10 21:58:38 Sola 测验10-2 3
! 2021-05-11 14:30:07 Sola 习题10-4 字符串转大写
! 2021-05-11 15:00:14 Sola 习题10-5 字符串转小写
! 2021-05-11 16:03:39 Sola 习题10-8 首字母大写
! 2021-05-11 17:39:18 Sola 习题10-9 10-8可变函数版(话说直接写的就是可变函数版本的...)
! 2021-05-11 17:39:48 Sola 习题10-10 检测字符中实际字符数
! 2021-05-11 18:16:41 Sola 习题10-11 检测第一个和最后一个非空字符位置(话说上一题的函数改一改不就是了)
! 2021-05-11 19:10:54 Sola 习题10-12 输入参数文件
! 2021-05-11 21:51:02 Sola 习题10-13 直方图 ??? 这是什么鬼需求
! 2021-05-12 11:28:44 Sola 习题10-14 随机数直方图
! 2021-05-12 13:18:26 Sola 习题10-15 拷贝文件去除注释
! 程序结构:
!
! ==============================================================================
! 模块：
module Chapter10
implicit none
! 数据字典
! 声明常数
REAL, PARAMETER :: PI=3.14159265 ! PI值
REAL, PARAMETER :: e=2.718281828459 ! 自然对数
INTEGER, PARAMETER :: arrayLength=20 ! 数组基准长度
! 声明变量
! 创建显式接口
contains
end module Chapter10
! ==============================================================================
! 主程序：
program ProName
! use ModName
implicit none
! 数据字典
! 声明常量
! 声明变量
! 变量初始化
! 数据输入
! 运算过程
! 结果输出
! call Exercises10_1_4
! call Exercises10_1_5
! call Exercises10_1_6_8
! call Example10_3
! call Exercises10_2_3
! call Exercises10_4
! call Exercises10_10
! call Exercises10_12
! call Exercises10_13
! call Exercises10_14
call Exercises10_15
end program ProName
! ==============================================================================
! 子程序
! subroutine SubName(varName1,varName2)
! use MouName
! implicit none
! Type, intent(inout) :: varName
! end subroutine SubName
! ==============================================================================
! 函数
! function FunName(varName1,varName2)
! use MouName
! implicit none
! end function FunName
! ==============================================================================
! 测试10-1 4 判断星期几
subroutine Exercises10_1_4
implicit none
integer :: i
write(*,*) (day(i), i = 7, 1, -1)
contains
function day(iday)
integer, intent(in) :: iday
character(len=3) :: day
character(len=3), dimension(7) :: days=(/'SUN', 'MON', 'TUE', 'WED', 'THU', 'FRI', 'SAT'/)
if ( (iday>=1) .and. (iday<=7) ) then
day = days(iday)
end if
end function day
end subroutine Exercises10_1_4
! 测试10-1 5 字符串反序
subroutine Exercises10_1_5
implicit none
write(*,*) swap_string('Hello World!')
contains
function swap_string(string)
character(len=*), intent(in) :: string
character(len=len(string)) :: swap_string
integer :: length, i
length = len(string)
do i = 1, length
swap_string(length-i+1: length-i+1) = string(i: i)
end do
end function swap_string
end subroutine Exercises10_1_5
! 测验10-1 6-8
subroutine Exercises10_1_6_8
implicit none
call sub1
call sub2
call sub3
contains
subroutine sub1
character(len=20) :: last='JOHNSON'
character(len=20) :: first='JAMES'
character :: middle_initial='R'
character(len=42) :: name
write(*,*) middle_initial
name = last //', '//first//middle_initial
write(*,*) name
end subroutine sub1
subroutine sub2
character(len=4) :: a='123'
character(len=12) :: b
b = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
write(*,*) a, ', ', b
b(5: 8) = a(2: 3)
write(*,*) a, ', ', b
end subroutine sub2
subroutine sub3
character(len=80) :: line
integer :: ipos1, ipos2, ipos3, ipos4
line = 'This is a test line containing some input data!'
ipos1 = index(line, 'in')
ipos2 = index(line, 'Test')
ipos3 = index(line, 't l')
ipos4 = index(line, 'in', .TRUE.)
write(*,*) ipos1, ipos2, ipos3, ipos4
end subroutine sub3
end subroutine Exercises10_1_6_8
! 例题10-3 转换输出数值格式
subroutine Example10_3
implicit none
real :: input
character(len=1) :: runLevel
outer:do
write(*, *) '请输入数值:'
read(*, *) input
write(*, *) '输出的结果为:', num2str(input)
inner:do
write(*, *) '是否接着输入下一个数值? 继续(Y)/结束(N)'
read(*, *) runLevel
if ( runLevel == 'Y' .or. runLevel == 'y' ) then
exit inner
else if ( runLevel == 'N' .or. runLevel == 'n' ) then
exit outer
else
write(*,*) '非法输入! 请重新输入!'
end if
end do inner
end do outer
contains
function num2str(num)
character(len=12) :: num2str ! 函数输出类型
real, intent(in) :: num ! 输入实数
if ( abs(num) <= 9999999. .and. abs(num) >= 0.01 .or. num == 0 ) then
write(num2str, '(F12.4)') num
else
write(num2str, '(ES12.5)') num
end if
end function num2str
end subroutine Example10_3
! 测验10-2 3
subroutine Exercises10_2_3
implicit none
character(len=30) :: line = '123456789012345678901234567890'
character(len=30) :: fmt = '(3X, I6, 12X, I3, F6.2)'
integer :: ival1, ival2
real :: rval3
read (line, fmt) ival1, ival2, rval3
write(*,*) ival1, ival2, rval3
end subroutine Exercises10_2_3
! 习题10-4 字符串转大写
subroutine Exercises10_4
implicit none
character(len=132) :: input
character :: runLevel
outer:do
write(*, *) '请输入一段字符（小于132字，包含空格字符请用引号括起）'
read(*, *) input
write(*, *) '转换大写结果为：', Ucase(input)
write(*, *) '转换小写结果为：', Lcase(input)
write(*, *) '首字符大写结果为：', Caps(input)
inner:do
write(*, *) '是否接着转换下一个字符串? 继续(Y)/结束(N)'
read(*, *) runLevel
if ( runLevel == 'Y' .or. runLevel == 'y' ) then
exit inner
else if ( runLevel == 'N' .or. runLevel == 'n' ) then
exit outer
else
write(*,*) '非法输入! 请重新输入!'
end if
end do inner
end do outer
contains
! 转换为大写
function Ucase(str)
character(len=*), intent(in) :: str ! 定义输入字符串
character(len=len(str)) :: ucase ! 定义函数类型
integer :: i ! 循环参数
do i = 1, len(str) ! 对输入每个字符循环
if ( lge(str(i: i), 'a') .and. lle(str(i: i), 'z') ) then ! 如果字符在a~z中
Ucase(i: i) = achar( iachar(str(i: i)) - 32 ) ! 输出大写
else
Ucase(i: i) = str(i: i) ! 如果不在, 输出原字符
end if
end do
end function Ucase
! 转换为小写
function Lcase(str)
character(len=*), intent(in) :: str ! 定义输入字符串
character(len=len(str)) :: Lcase ! 定义函数类型
integer :: i ! 循环参数
do i = 1, len(str) ! 对每个输入字符循环
if ( lge(str(i: i), 'A') .and. lle(str(i: i), 'Z') ) then ! 如果字符在A~Z中
Lcase(i: i) = achar( iachar(str(i: i)) + 32 ) ! 输出小写
else
Lcase(i: i) = str(i: i) ! 如果不再, 输出原字符
end if
end do
end function Lcase
! 首字符大写
! 情况可能如下:
! 1. 小写字母, runLevel .eqv. .TRUE. 转换为大写, runLevel = .FALSE.
! 2. 小写字母, runLevel .eqv. .FALSE. 不变
! 3. 大写字母, runLevel .eqv. .TRUE. 不变, runLevel = .FALSE.
! 4. 大写字母, runLevel .eqv. .FALSE. 转换为小写
! 5. 非字符, runLevel = .TRUE.
function Caps(str)
character(len=*), intent(in) :: str ! 输入字符
character(len=len(str)) :: Caps ! 定义函数类型
integer :: i ! 循环参数
logical :: runLevel ! 运行级别(判断是否为首字母)
runLevel = .TRUE. ! 初始化运行级别
do i = 1, len(str) ! 遍历每个字符
if ( lge(str(i: i), 'a') .and. lle(str(i: i), 'z') .and. ( runLevel .eqv. .TRUE. ) ) then ! 小写字母为首字母
Caps(i: i) = achar( iachar(str(i: i)) - 32 ) ! 转换为大写字母
runLevel = .FALSE. ! 下一个字符非首字母
elseif ( lge(str(i: i), 'a') .and. lle(str(i: i), 'z') .and. ( runLevel .eqv. .FALSE. ) ) then ! 小写字母非首字母
Caps(i: i) = str(i: i) ! 不改变字符
elseif ( lge(str(i: i), 'A') .and. lle(str(i: i), 'Z') .and. ( runLevel .eqv. .TRUE. ) ) then ! 大写字母为首字母
Caps(i: i) = str(i: i) ! 不改变字符
runLevel = .FALSE. ! 下一个字符非首字母
elseif ( lge(str(i: i), 'A') .and. lle(str(i: i), 'Z') .and. ( runLevel .eqv. .FALSE. ) ) then ! 大写字母非首字母
Caps(i: i) = achar( iachar(str(i: i)) + 32 ) ! 转换为小写字母
elseif ( lge(str(i: i), '0') .and. lle(str(i: i), '9') ) then ! 如果是数字
Caps(i: i) = str(i: i) ! 不改变字符
runLevel = .FALSE. ! 下一个字符不是首字母
else ! 非字母
Caps(i: i) = str(i: i) ! 不改变字符
runLevel = .TRUE. ! 下一个字符是首字母(如果是字母)
end if
end do
end function Caps
end subroutine Exercises10_4
! 习题10-10 检测字符串中实际字符数量
subroutine Exercises10_10
implicit none
character(len=132) :: input
character :: runLevel
integer :: errorLevel
integer :: firstNonBlank, lastNonBlank
outer:do
write(*, *) '请输入一段字符（小于132字，包含空格字符请用引号括起）'
read(*, *) input
write(*, *) '该字符的长度为：', LenUsed(input)
write(*, *) '该字符的允许长度为：', len(input)
write(*, *) '该字符除去尾部空格的长度为：', len_trim(input)
call NonBlank(input, firstNonBlank, lastNonBlank, errorLevel)
if ( errorLevel /= 0 ) then
write(*, *) '错误! 没有输入字符或输入字符为空!'
else
write(*, *) '第一个非空字符在第', firstNonBlank, '位, 最后一个非空字符在第', lastNonBlank, '位。'
end if
inner:do
write(*, *) '是否接着计算下一个字符串? 继续(Y)/结束(N)'
read(*, *) runLevel
if ( runLevel == 'Y' .or. runLevel == 'y' ) then
exit inner
else if ( runLevel == 'N' .or. runLevel == 'n' ) then
exit outer
else
write(*,*) '非法输入! 请重新输入!'
end if
end do inner
end do outer
contains
! 习题10-10 判断字符串中有多少字符
function LenUsed(str)
character(len=*), intent(in) :: str ! 输入字符串
integer :: LenUsed ! 定义函数返回类型
integer :: i ! 循环参数
integer :: firstSpace, lastSpace ! 首位空白字符位置
firstSpace = 0 ! 初始化变量
lastSpace = len(str)
do i = 1, lastSpace ! 判断字符串首最后一个空白字符位置
if ( str(i:i) == ' ' ) then
firstSpace = i
else
exit
end if
end do
if ( firstSpace /= lastSpace ) then ! 如果不是全部都是空白字符
do i = lastSpace, firstSpace+1, -1 ! 判断字符串尾第一个空白字符位置
if ( str(i:i) == ' ' ) then
lastSpace = i
else
exit
end if
end do
LenUsed = lastSpace - firstSpace - 1 ! 判断字符串实际使用长度
else
LenUsed = 0 ! 如果全部都是空白字符, 则长度为0
end if
end function LenUsed
! 习题10-11 判断字符串第一个和最后一个空白字符位置
subroutine NonBlank(str, firstNonBlank, lastNonBlank, errorLevel)
character(len=*), intent(in) :: str ! 输入字符串
integer :: i ! 循环参数
integer, intent(out) :: firstNonBlank, lastNonBlank ! 首位空白字符位置
integer, intent(out) :: errorLevel
firstNonBlank = len(str) ! 初始化变量
lastNonBlank = 0
do i = firstNonBlank, 1, -1 ! 判断字符串最后一个非空白位置
if ( .not. str(i:i) == ' ' ) then
lastNonBlank = i
exit
end if
end do
if ( lastNonBlank /= 0 ) then ! 如果不是全部都是空白字符
do i = 1, lastNonBlank ! 判断字符串第一个空白字符位置
if ( .not. str(i:i) == ' ' ) then
firstNonBlank = i
exit
end if
end do
errorLevel = 0
else
firstNonBlank = 0 ! 如果全部都是空白字符, 则位置为0
errorLevel = 1
end if
end subroutine NonBlank
end subroutine Exercises10_10
! 习题10-12 输入参数文件
subroutine Exercises10_12
implicit none
character(len=132) :: str
real :: start, stop, dt
logical :: plot
integer :: errorLevel
open(unit=1, status='scratch', iostat=errorLevel) ! 打开文件并输入数据
if ( errorLevel /= 0 ) stop "打开临时文件失败"
write(1, '(A)') &
&"start=0.0",&
&"stop=10.0",&
&"dt=0.2",&
&"plot on",&
&" ",&
&" "
rewind(unit=1, iostat=errorLevel) ! 回到第一行
if ( errorLevel /= 0 ) stop "操作临时文件失败"
do ! 读取文件知道文件末尾
read(1, '(A)', iostat=errorLevel) str ! 将内容赋值给字符串
if ( errorLevel /= 0 ) exit ! 判断是否到达文件末尾
call InputData(str, start, stop, dt, plot) ! 读取值
end do
write(*, *) start, stop, dt, plot ! 显示当前读取到的值
close(unit=1, iostat=errorLevel) ! 关闭临时文件
if ( errorLevel /= 0 ) stop "关闭临时文件失败" ! 检测关闭状态
contains
subroutine InputData(str, start, stop, dt, plot) ! 读取值子程序
character(len=*), intent(inout) :: str ! 输入的字符串
real, intent(out) :: start, stop, dt ! 输出数值
integer :: tempLoc ! 临时保存位置的变量
integer :: equLoc, length ! 等号位置及字符串长度
logical :: plot ! 输出逻辑值
equLoc = index(str, '=') ! 得到等号位置
length = len(str) ! 得到字符串长度
if ( equLoc == 0 ) then ! 如果没有等号
tempLoc = index( Ucase(str), 'PLOT') ! 检测全大写字符串中是否有PLOT字符
if ( tempLoc /= 0 ) then ! 如果有
if ( index(Ucase(str(1: length)), 'ON') /= 0 ) then ! 判断PLOT状态并赋值
plot = .TRUE.
elseif ( index(Ucase(str(1: length)), 'OFF') /= 0) then
plot = .FALSE.
end if
end if
return
end if
tempLoc = index( Ucase(str), 'START') ! 判断是否是START变量
if ( tempLoc /= 0 .and. tempLoc < equLoc ) then ! 如果是
write(str, '(A)') str(equLoc+1: length) ! 将值部分读入字符串
read(str, *) start ! 读取值, 接下来相同
return
end if
tempLoc = index( Ucase(str), 'STOP')
if ( tempLoc /= 0 .and. tempLoc < equLoc ) then
write(str, '(A)') str(equLoc+1: length)
read(str, *) stop
return
end if
tempLoc = index( Ucase(str), 'DT')
if ( tempLoc /= 0 .and. tempLoc < equLoc ) then
write(str, '(A)') str(equLoc+1: length)
read(str, *) dt
return
end if
end subroutine InputData
! 转换为大写
function Ucase(str)
character(len=*), intent(in) :: str ! 定义输入字符串
character(len=len(str)) :: ucase ! 定义函数类型
integer :: i ! 循环参数
do i = 1, len(str) ! 对输入每个字符循环
if ( lge(str(i: i), 'a') .and. lle(str(i: i), 'z') ) then ! 如果字符在a~z中
Ucase(i: i) = achar( iachar(str(i: i)) - 32 ) ! 输出大写
else
Ucase(i: i) = str(i: i) ! 如果不在, 输出原字符
end if
end do
end function Ucase
end subroutine Exercises10_12
! 习题10-13 直方图 ??? 这是什么鬼需求
! 基本逻辑如下:
! 1. 首先打开一个临时文件, 并向其中输入数据
! 2. 读取数据, 并向数组中填入相关值
! 3. 依据数据, 构建一个二维数组, 并模拟图表构成
! 4. 打印这个数组, 模拟直方图的形式
subroutine Exercises10_13
implicit none
integer :: errorLevel
character(len=6), dimension(7) :: arrayName ! 类名
integer, dimension(7) :: arrayValue ! 类值
arrayName = (/'100~95', '94~90 ', '89~85 ', '84~80 ', '79~75 ', '74~70 ', '69~65 '/) ! 定义类名
arrayValue = (/3, 6, 9, 7, 4, 2, 1/) ! 定义类值
write(*,*) ' Form 10.13 学生成绩分布直方图' ! 输出标题
call DrawHistogram(arrayName, arrayValue, errorLevel) ! 绘图
contains
! 直方图绘制
subroutine DrawHistogram(arrayName, arrayValue, errorLevel)
character(len=*), dimension(:), intent(in) :: arrayName ! 输入类名
integer, dimension(:), intent(in) :: arrayValue ! 输入类值
integer, intent(out) :: errorLevel ! 错误码
character(len=max(maxval(len_trim(arrayName))+1, 6)), allocatable, dimension(:, :) :: arrayDraw ! 绘图矩阵
integer :: temp, length ! 范围边界
character(len=max(maxval(len_trim(arrayName))+1, 6)) :: bar, line ! 绘制形状
integer :: i ! 循环参数
if ( size(arrayName, 1) /= size(arrayValue, 1) ) then ! 如果类名和值数量不匹配, 报错并返回
errorLevel = 1
return
end if
length = size(arrayValue, 1) ! 获取图表类数目
! temp = 1 ! 初始化类值最大值位置
! do i = 2, length ! 获取类值最大值位置
! if ( arrayValue(i) > arrayValue(temp) ) then
! temp = i
! end if
! end do
! temp = arrayValue(temp) ! 获取最大类值(话说为啥不直接用maxval函数)
temp = maxval(arrayValue) ! 获取最大类值
bar = '' ! 初始化形状
do i = 1, len(bar)-2
bar(i: i) = '%' ! 形成形状(用于表示直方图)
end do
do i = 1, len(line)
line(i: i) = '_' ! 用于显示图表下边界
end do
allocate(arrayDraw(temp+4, length+1), stat=errorLevel) ! 定义数组
if (errorLevel /= 0) print *, "arrayDraw: Allocation request denied"
arrayDraw = '' ! 初始化绘制数组
do i = 1, temp + 3
write(arrayDraw(i, 1)(1: 3), '(I3)') temp + 3 - i ! 绘制数组坐标轴纵轴值
end do
do i = 1, temp + 3
arrayDraw(i, 1)(len(bar)-1:len(bar)) = '| ' ! 绘制数组坐标轴纵轴边界
end do
arrayDraw(temp+3, 1)(len(bar)-1:len(bar)) = '|_' ! 绘制数组坐标轴零点边界
do i = temp-2, 1, -5
arrayDraw(i, 1)(len(bar)-1:len(bar)) = '|-' ! 绘制数组坐标轴纵轴刻度
end do
arrayDraw(temp+3, 2: length+1) = line ! 绘制数组坐标轴横轴
write(arrayDraw(temp+4, 2:size(arrayName, 1)+1), '(A)') (trim(arrayName(i)), i = 1, size(arrayName, 1)) ! 绘制数组坐标轴横轴类名
do i = 1, size(arrayName, 1)
arrayDraw(temp+3-arrayValue(i):temp+2, i+1) = bar ! 绘制数组直方图
end do
do i = 1, temp + 4
write(*, '(100A)') arrayDraw(i, :) ! 打印绘制数组
end do
if (allocated(arrayDraw)) deallocate(arrayDraw, stat=errorLevel) ! 释放数组
if (errorLevel /= 0) print *, "arrayDraw: Deallocation request denied"
errorLevel = 0 ! 设定错误等级为0
end subroutine DrawHistogram
end subroutine Exercises10_13
! 习题10-14 随机数直方图
module ran001
implicit none
integer :: n = 12345
end module ran001
subroutine Exercises10_14
implicit none
integer :: i
integer :: errorLevel
real :: randomValue
character(len=9), dimension(20) :: arrayName ! 类名
integer, dimension(20) :: arrayValue ! 类值
write(*,*) ' Form 10.14 随机数分布直方图' ! 输出标题
arrayName = (/&
&'0.00~0.05', '0.05~0.10', '0.10~0.15', '0.15~0.20', &
&'0.20~0.25', '0.25~0.30', '0.30~0.35', '0.35~0.40', &
&'0.40~0.45', '0.45~0.50', '0.50~0.55', '0.55~0.60', &
&'0.60~0.65', '0.65~0.70', '0.70~0.75', '0.75~0.80', &
&'0.80~0.85', '0.85~0.90', '0.90~0.95', '0.95~1.00'/) ! 定义类名
call seed0(12346.)
arrayValue = 0
do i = 1, 20000
call random(randomValue)
arrayValue(int(randomValue*20+1)) = arrayValue(int(randomValue*20+1)) + 1
end do
call DrawHistogram(arrayName, arrayValue, errorLevel) ! 绘图
contains
! 直方图绘制
subroutine DrawHistogram(arrayName, arrayValue, errorLevel)
character(len=*), dimension(:), intent(in) :: arrayName ! 输入类名
integer, dimension(:), intent(in) :: arrayValue ! 输入类值
integer, intent(out) :: errorLevel ! 错误码
character(len=max(maxval(len_trim(arrayName))+1, 7)), allocatable, dimension(:, :) :: arrayDraw ! 绘图矩阵
integer :: temp, length ! 范围边界
character(len=max(maxval(len_trim(arrayName))+1, 7)) :: bar, line ! 绘制形状
integer :: i ! 循环参数
integer :: maxValue ! 最大值
if ( size(arrayName, 1) /= size(arrayValue, 1) ) then ! 如果类名和值数量不匹配, 报错并返回
errorLevel = 1
return
end if
length = size(arrayValue, 1) ! 获取图表类数目
temp = maxval(arrayValue) ! 获取最大类值
bar = '' ! 初始化形状
do i = 1, len(bar)-2
bar(i: i) = '%' ! 形成形状(用于表示直方图)
end do
do i = 1, len(line)
line(i: i) = '_' ! 用于显示图表下边界
end do
allocate(arrayDraw(14, length+1), stat=errorLevel) ! 定义数组
if (errorLevel /= 0) print *, "arrayDraw: Allocation request denied"
arrayDraw = '' ! 初始化绘制数组
maxValue = maxval(arrayValue)
do i = 1, 13
write(arrayDraw(i, 1)(1: 4), '(I4)') nint(real(maxValue)*(13. - real(i))/10.) ! 绘制数组坐标轴纵轴值
end do
do i = 1, 12
arrayDraw(i, 1)(len(bar)-2:len(bar)) = '| ' ! 绘制数组坐标轴纵轴边界
end do
arrayDraw(13, 1)(len(bar)-2:len(bar)) = '|__' ! 绘制数组坐标轴零点边界
do i = 8, 1, -5
arrayDraw(i, 1)(len(bar)-2:len(bar)) = '|- ' ! 绘制数组坐标轴纵轴刻度
end do
arrayDraw(13, 2: length+1) = line ! 绘制数组坐标轴横轴
write(arrayDraw(14, 2:size(arrayName, 1)+1), '(A)') (trim(arrayName(i)), i = 1, size(arrayName, 1)) ! 绘制数组坐标轴横轴类名
do i = 1, size(arrayName, 1)
arrayDraw(13-nint(real(arrayValue(i))*10./real(maxValue)):12, i+1) = bar ! 绘制数组直方图
end do
do i = 1, 14
write(*, '(100A)') arrayDraw(i, :) ! 打印绘制数组
end do
if (allocated(arrayDraw)) deallocate(arrayDraw, stat=errorLevel) ! 释放数组
if (errorLevel /= 0) print *, "arrayDraw: Deallocation request denied"
errorLevel = 0 ! 设定错误等级为0
end subroutine DrawHistogram
subroutine seed0(iseed)
use ran001
real, intent(in) :: iseed
n = abs(iseed)
end subroutine seed0
subroutine random(ran)
use ran001
real, intent(inout) :: ran
n = mod(8121*n+28411,134456)
ran = real(n)/134456
end subroutine random
end subroutine Exercises10_14
! 习题10-15 拷贝文件去除注释
subroutine Exercises10_15
implicit none
character(len=132) :: str
integer :: errorLevel
open(unit=1, status='scratch', iostat=errorLevel)
if ( errorLevel /= 0 ) stop ""
write(1, '(A)') &
&"subroutine DrawHistogram(arrayName, arrayValue, errorLevel)'!'", &
&"character(len=*), dimension(:), intent(in) :: arrayName ! 输入类名", &
&"integer, dimension(:), intent(in) :: arrayValue ! 输入类值", &
&"integer, intent(out) :: errorLevel ! 错误码", &
&"character(len=max(maxval(len_trim(arrayName))+1, 7)), allocatable, dimension(:, :) :: arrayDraw ! 绘图矩阵", &
&"integer :: temp, length ! 范围边界", &
&"character(len=max(maxval(len_trim(arrayName))+1, 7)) :: bar, line ! 绘制形状"
rewind(unit=1, iostat=errorLevel)
if ( errorLevel /= 0 ) stop ""
do
read(1, '(A)', iostat=errorLevel) str
if ( errorLevel /= 0 ) exit
write(*, *) Uncomment(str)
end do
contains
function Uncomment(str)
character(len=*), intent(in) :: str
character(len=len(str)) :: Uncomment
integer :: i
integer :: runLevel
runLevel = 0
do i = 1, len(str)
if ( str(i: i) == '!' .and. (runLevel == 0) ) then ! 将感叹号转换为空格
Uncomment(i: i) = ' '
else
Uncomment(i: i) = str(i: i)
end if
if ( str(i: i) == '"' .and. runLevel == 0 ) then ! 判断不转换感叹号的场景
runLevel = 1
elseif ( str(i: i) == '"' .and. runLevel == 1 ) then
runLevel = 0
elseif ( str(i: i) == "'" .and. runLevel == 0 ) then
runLevel = 2
elseif ( str(i: i) == "'" .and. runLevel == 2 ) then
runLevel = 0
end if
end do
end function Uncomment
end subroutine Exercises10_15

398
第11章习题.f90 Normal file
View File

@ -0,0 +1,398 @@
! ==============================================================================
! 通过 gfortran ./test.f90 -o ./run && ./run 运行
! 程序名：
! 第11章习题
! 目的:
!
! 修订记录:
! 日期 编程者 改动描述
! =================== ============= =====================================
! 2021-05-13 14:32:35 Sola 习题11-5 判断格式是否正确
! 2021-05-13 15:42:31 Sola 习题11-6 函数的导数
! 2021-05-13 17:17:22 Sola 习题11-7 经时计算，判断单精度和双精度时间
! 2021-05-14 19:19:29 Sola 习题11-8 跳过，习题11-9 复数计算
! 2021-05-14 19:56:11 Sola 习题11-10 复数的振幅和相位
! 2021-05-14 20:09:50 Sola 习题11-11 欧拉公式
! 程序结构:
!
! ==============================================================================
! 模块：
module Chapter11
implicit none
! 数据字典
! 声明常数
REAL, PARAMETER :: PI=3.14159265 ! PI值
REAL, PARAMETER :: e=2.718281828459 ! 自然对数
INTEGER, PARAMETER :: arrayLength=20 ! 数组基准长度
! 声明变量
! 创建显式接口
contains
! subroutine SubName(varName1,varName2)
! implicit none
! ! 数据字典
! end subroutine SubName
end module Chapter11
! ==============================================================================
! 主程序：
program ProName
implicit none
! 数据字典
! 声明常量
! 声明变量
! 变量初始化
! 数据输入
! 运算过程
! 结果输出
! call Exercises11_5
! call Exercises11_6
! call Exercises11_7
! call Exercises11_9
! call Exercises11_10
call Exercises11_11
end program ProName
! ==============================================================================
! 子程序
! subroutine SubName(varName1,varName2)
! use MouName
! implicit none
! Type, intent(inout) :: varName
! end subroutine SubName
! ==============================================================================
! 函数
! function FunName(varName1,varName2)
! use MouName
! implicit none
! end function FunName
! ==============================================================================
! 习题11-5
subroutine Exercises11_5
implicit none
call Suba
! call Subb
contains
subroutine Suba
integer, parameter :: sgl = kind(0.0)
integer, parameter :: dbl = kind(0.0D0)
real(kind=sgl) :: a
real(kind=dbl) :: b
integer :: i
integer :: errorLevel
open(unit=1, status='scratch', iostat=errorLevel)
if ( errorLevel /= 0 ) stop ""
write(*, *) sgl, dbl
do i = 1, 45
write(*, *) i, selected_real_kind(r=i)
end do
write(1, '(A)') &
&"111111111111111111111111111111111111111111111", &
&"222222222222222222222222222222222222222222222"
rewind(unit=1, iostat=errorLevel)
if ( errorLevel /= 0 ) stop ""
read(1, '(F16.2)') a, b
write(*, *) a, b
end subroutine Suba
! subroutine Subb
! end subroutine Subb
end subroutine Exercises11_5
! 习题11-6 函数的导数
subroutine Exercises11_6
implicit none
integer, parameter :: realType = selected_real_kind(p=13) ! 确认实数类型
real(realType) :: x0, dx ! 待测点, 步长
real(realType) :: derivationX0 ! 导数值
real(realType), external :: Fx ! 外部函数
x0 = 0._realType ! 变量初始化
dx = 0.01_realType
call Derivation(Fx, x0, dx, derivationX0) ! 计算导数
write(*, *) '函数在0处的值为', Fx(0._realType), '在0处的导数值为', derivationX0 ! 输出结果
contains
subroutine Derivation(inputFunction, x0, dx, derivationX0)
integer, parameter :: realType = selected_real_kind(p=13) ! 确认实数类型
real(realType), intent(in) :: x0, dx ! 输入点位及步长
real(realType), intent(out) :: derivationX0 ! 输出的导数值
real(realType), external :: inputFunction ! 外部函数
derivationX0 = (inputFunction(x0 + dx) - inputFunction(x0))/dx ! 计算导数值
end subroutine Derivation
end subroutine Exercises11_6
function Fx(x)
implicit none
integer, parameter :: realType = selected_real_kind(p=13) ! 确认实数类型
real(realType), intent(in) :: x ! 输入点位
real(realType) :: Fx ! 定义函数输出类型
Fx = 10._realType*sin(20._realType*x) ! 计算函数值
end function Fx
! 习题11-7 经时计算 不过话说回来，现在的编译器在这边好像还是有优化的，，，结果可能不太准
subroutine Exercises11_7
implicit none
integer, parameter :: dbl = selected_real_kind(p=13)
integer, parameter :: sgl = selected_real_kind(p=1)
real(dbl), dimension(10, 10) :: matrix
real(dbl), dimension(10) :: arrayX
real(sgl), dimension(10, 10) :: matrix1
real(sgl), dimension(10) :: arrayX1
integer, dimension(8) :: timeNow
real :: timePast
integer, dimension(8) :: timeOld
integer :: errorLevel
integer :: i
open(unit=1, status='scratch', iostat=errorLevel)
if ( errorLevel /= 0 ) stop ""
write(1, '(A)') &
&" -2., 5., 1., 3., 4. -1., -2., -1., -5., -2.", &
&" 6., 4., -1., 6., -4., -5., 3., -1., 4., 3.", &
&" -6., -5., -2., -2., -3., 6., 4., 2., -6., 4.", &
&" 2., 4., 4., 4., 5., -4., 0., 0., -4., 6.", &
&" -4., -1., 3., -3., -4., -4., -4., 4., 3., -3.", &
&" 4., 3., 5., 1., 1., 1., 0., 3., 3., 6.", &
&" 1., 2., -2., 0., 3., -5., 5., 0., 1., -4.", &
&" -3., -4., 2., -1., -2., 5., -1., -1., -4., 1.", &
&" 5., 5., -2., -5., 1., -4., -1., 0., -2., -3.", &
&" -5., -2., -5., 2., -1., 3., -1., 1., -4., 4."
rewind(unit=1, iostat=errorLevel)
if ( errorLevel /= 0 ) stop ""
arrayX = (/ -5., -6., -7., 0., 5., -8., 1., -4., -7., 6./)
read(1, *) (matrix(i, :), i = 1, 10)
rewind(unit=1, iostat=errorLevel)
if ( errorLevel /= 0 ) stop ""
arrayX1 = (/ -5., -6., -7., 0., 5., -8., 1., -4., -7., 6./)
read(1, *) (matrix1(i, :), i = 1, 10)
call set_timer
do i = 1, 1000000
call GAEli1(matrix1, arrayX1, errorLevel)
! arrayX1 = (/ -5., -6., -7., 0., 5., -8., 1., -4., -7., 6./)
end do
call elapsed_time(timePast)
write(*, *) '使用单精度计算消耗时间', timePast, 's'
call set_timer
do i = 1, 1000000
call GAEli2(matrix, arrayX, errorLevel)
! arrayX = (/ -5., -6., -7., 0., 5., -8., 1., -4., -7., 6./)
end do
call elapsed_time(timePast)
write(*, *) '使用双精度计算消耗时间', timePast, 's'
contains
! 解方程子程序
! 经时子程序
subroutine set_timer ! 创建子程序1
call DATE_AND_TIME(values=timeNow) ! 调用当前时间子程序
end subroutine set_timer ! 结束子程序1
subroutine elapsed_time(timePast) ! 创建子程序2
real, intent(out) :: timePast ! 定义输出变量
timeOld = timeNow ! 传递值
call set_timer ! 调用子程序1
timePast = ((real(timeNow(3)-timeOld(3))*24 + real(timeNow(5)-timeOld(5)))&
&*60 + real(timeNow(6)-timeOld(6)))*60 + real(timeNow(7)-timeOld(7)) + &
&real(timeNow(8)-timeOld(8))/1000 ! 计算经历时间(秒)
end subroutine elapsed_time ! 结束子程序2
! 高斯-亚当消元法，不破坏输入矩阵
subroutine GAEli1(matrixInput1, arrayX, errorLevel)
integer, parameter :: varKind = selected_real_kind(p=2)
real(varKind), dimension(:, :), intent(inout) :: matrixInput1 ! 输入矩阵(输入)
real(varKind), dimension(size(matrixInput1, 1), size(matrixInput1, 2)) :: matrixInput
! 运算矩阵
real(varKind), dimension(:), intent(inout) :: arrayX ! 输入常数向量, 输出X解向量
integer, intent(out) :: errorLevel ! 错误值
real(varKind) :: temp ! 临时值, 用于数值交换
integer :: maxLocate ! 最大值所在行
integer :: i, n, m ! 局部变量: 循环参数
matrixInput = matrixInput1
m = size(matrixInput, 1)
do n = 1, m
maxLocate = n ! 初始化绝对值最大的位置
do i = n+1, m ! 执行最大支点技术，减少舍入误差
if ( abs(matrixInput(i, n)) > abs(matrixInput(maxLocate, n)) ) then
maxLocate = i
end if
end do
if ( abs(matrixInput(maxLocate, n)) < 1.0E-30 ) then
errorLevel = 1 ! 如果绝对值最大为0, 则矩阵不满秩, 无解
return ! 退出运算
end if
if ( maxLocate /= n ) then ! 如果绝对值最大值位置发生了变化, 则交换
do i = 1, m
temp = matrixInput(maxLocate, i)
matrixInput(maxLocate, i) = matrixInput(n, i)
matrixInput(n, i) = temp
end do
temp = arrayX(maxLocate)
arrayX(maxLocate) = arrayX(n)
arrayX(n) = temp
end if
do i = 1, m ! 消去其他行所有第n列的系数
if ( i /= n ) then
temp = -matrixInput(i, n)/matrixInput(n, n) ! 这里务必要设置一个临时值保存数值, 不然会被修改
matrixInput(i, :) = matrixInput(i, :) + matrixInput(n, :)*temp
arrayX(i) = arrayX(i) + arrayX(n)*temp
end if
end do
end do
do i = 1, m ! 产生X的解向量
arrayX(i) = arrayX(i)/matrixInput(i, i)
matrixInput(i, i) = 1.
end do
errorLevel = 0
end subroutine GAEli1
subroutine GAEli2(matrixInput1, arrayX, errorLevel)
integer, parameter :: varKind = selected_real_kind(p=13)
real(varKind), dimension(:, :), intent(inout) :: matrixInput1 ! 输入矩阵(输入)
real(varKind), dimension(size(matrixInput1, 1), size(matrixInput1, 2)) :: matrixInput
! 运算矩阵
real(varKind), dimension(:), intent(inout) :: arrayX ! 输入常数向量, 输出X解向量
integer, intent(out) :: errorLevel ! 错误值
real(varKind) :: temp ! 临时值, 用于数值交换
integer :: maxLocate ! 最大值所在行
integer :: i, n, m ! 局部变量: 循环参数
matrixInput = matrixInput1
m = size(matrixInput, 1)
do n = 1, m
maxLocate = n ! 初始化绝对值最大的位置
do i = n+1, m ! 执行最大支点技术，减少舍入误差
if ( abs(matrixInput(i, n)) > abs(matrixInput(maxLocate, n)) ) then
maxLocate = i
end if
end do
if ( abs(matrixInput(maxLocate, n)) < 1.0E-30 ) then
errorLevel = 1 ! 如果绝对值最大为0, 则矩阵不满秩, 无解
return ! 退出运算
end if
if ( maxLocate /= n ) then ! 如果绝对值最大值位置发生了变化, 则交换
do i = 1, m
temp = matrixInput(maxLocate, i)
matrixInput(maxLocate, i) = matrixInput(n, i)
matrixInput(n, i) = temp
end do
temp = arrayX(maxLocate)
arrayX(maxLocate) = arrayX(n)
arrayX(n) = temp
end if
do i = 1, m ! 消去其他行所有第n列的系数
if ( i /= n ) then
temp = -matrixInput(i, n)/matrixInput(n, n) ! 这里务必要设置一个临时值保存数值, 不然会被修改
matrixInput(i, :) = matrixInput(i, :) + matrixInput(n, :)*temp
arrayX(i) = arrayX(i) + arrayX(n)*temp
end if
end do
end do
do i = 1, m ! 产生X的解向量
arrayX(i) = arrayX(i)/matrixInput(i, i)
matrixInput(i, i) = 1.
end do
errorLevel = 0
end subroutine GAEli2
end subroutine Exercises11_7
! 习题11-9 复数计算
subroutine Exercises11_9
implicit none
integer, parameter :: dbl = selected_real_kind(p=3)
complex(dbl), dimension(3, 3) :: matrix
complex(dbl), dimension(3) :: arrayX
integer :: errorLevel
integer :: i
open(unit=1, status='scratch', iostat=errorLevel)
if ( errorLevel /= 0 ) stop ""
write(1, '(A)') &
&"( -2., 5.), ( 1., 3.), ( 4., -1.)", &
&"( 2., -1.), ( -5., -2.), ( -1., 6.)", &
&"( -1., 6.), ( -4., -5.), ( 3., -1.)", &
&"( 7., 5.), (-10., -8.), ( -3., -3.)"
rewind(unit=1, iostat=errorLevel)
if ( errorLevel /= 0 ) stop ""
read(1, *) (matrix(i, :), i = 1, 3)
read(1, *) arrayX
call GAEli(matrix, arrayX, errorLevel)
write(*, *) '计算结果为：'
write(*, *) 'x1 = ', arrayX(1)
write(*, *) 'x2 = ', arrayX(2)
write(*, *) 'x3 = ', arrayX(3)
contains
! 复数求解
subroutine GAEli(matrixInput1, arrayX, errorLevel)
integer, parameter :: varKind = selected_real_kind(p=3)
complex(varKind), dimension(:, :), intent(inout) :: matrixInput1 ! 输入矩阵(输入)
complex(varKind), dimension(size(matrixInput1, 1), size(matrixInput1, 2)) :: matrixInput
! 运算矩阵
complex(varKind), dimension(:), intent(inout) :: arrayX ! 输入常数向量, 输出X解向量
integer, intent(out) :: errorLevel ! 错误值
complex(varKind) :: temp ! 临时值, 用于数值交换
integer :: maxLocate ! 最大值所在行
integer :: i, n, m ! 局部变量: 循环参数
matrixInput = matrixInput1
m = size(matrixInput, 1)
do n = 1, m
maxLocate = n ! 初始化绝对值最大的位置
do i = n+1, m ! 执行最大支点技术，减少舍入误差
if ( cabs(matrixInput(i, n)) > cabs(matrixInput(maxLocate, n)) ) then
maxLocate = i
end if
end do
if ( cabs(matrixInput(maxLocate, n)) < 1.0E-30 ) then
errorLevel = 1 ! 如果绝对值最大为0, 则矩阵不满秩, 无解
return ! 退出运算
end if
if ( maxLocate /= n ) then ! 如果绝对值最大值位置发生了变化, 则交换
do i = 1, m
temp = matrixInput(maxLocate, i)
matrixInput(maxLocate, i) = matrixInput(n, i)
matrixInput(n, i) = temp
end do
temp = arrayX(maxLocate)
arrayX(maxLocate) = arrayX(n)
arrayX(n) = temp
end if
do i = 1, m ! 消去其他行所有第n列的系数
if ( i /= n ) then
temp = -matrixInput(i, n)/matrixInput(n, n) ! 这里务必要设置一个临时值保存数值, 不然会被修改
matrixInput(i, :) = matrixInput(i, :) + matrixInput(n, :)*temp
arrayX(i) = arrayX(i) + arrayX(n)*temp
end if
end do
end do
do i = 1, m ! 产生X的解向量
arrayX(i) = arrayX(i)/matrixInput(i, i)
matrixInput(i, i) = 1.
end do
errorLevel = 0
end subroutine GAEli
end subroutine Exercises11_9
! 习题11-10 复数的振幅和相位
subroutine Exercises11_10
implicit none
integer, parameter :: sgl=selected_real_kind(p=2) ! 定义单精度
complex(sgl) :: var1 ! 定义复数
real(sgl) :: amp, theta ! 定义振幅和相位
real(sgl), parameter :: PI=3.14159265 ! 圆周率
call InputComplex(amp, theta) ! 调用子程序, 获取输入复数的振幅和相位
write(*, *) '振幅为：', amp, '， 相位为：', theta, '°' ! 输出结果
contains
subroutine InputComplex(amp, theta)
integer, parameter :: sgl=selected_real_kind(p=2) ! 定义单精度
real(sgl), intent(out) :: amp, theta ! 定义输出结果
complex(sgl) :: var1 ! 定义输入复数
write(*, *) '请输入一个复数：' ! 提示信息
read(*, *) var1 ! 读取输入复数
amp = cabs(var1) ! 获取振幅
theta = atan(aimag(var1)/real(var1))*360./(2.*PI) ! 获取相位(角度)
end subroutine InputComplex
end subroutine Exercises11_10
! 习题11-11 欧拉公式
subroutine Exercises11_11
implicit none
integer, parameter :: sgl=selected_real_kind(p=2) ! 定义单精度
real(sgl) :: theta ! 定义角度(弧度)
complex(sgl) :: var1 ! 定义复数
real(sgl) :: PI=3.14159265 ! 圆周率
integer :: i ! 循环参数
do i = 0, 2 ! 循环theta = 0, pi/2, pi
theta = i*PI/2. ! 计算theta
write(*, '("theta = ", F6.2,", e^theta_i = " 2("(", ES9.2, ",", ES9.2, ") "))') &
&theta, cexp(cmplx(0., theta, sgl)), EulerFormula(theta)! 输出结果
end do
contains
! 欧拉公式
function EulerFormula(theta)
integer, parameter :: sgl=selected_real_kind(p=2) ! 定义单精度
real(sgl), intent(in) :: theta ! 定义输入角度(弧度)
complex(sgl) :: EulerFormula ! 定义函数返回类型
EulerFormula = cmplx(cos(theta), sin(theta), sgl) ! 计算返回值
end function EulerFormula
end subroutine Exercises11_11

298
第12章习题.f90 Normal file
View File

@ -0,0 +1,298 @@
! ==============================================================================
! 通过 gfortran ./test.f90 -o ./run && ./run 运行
! 程序名：
! 第12章习题
! 目的:
!
! 修订记录:
! 日期 编程者 改动描述
! =================== ============= =====================================
! 2021-05-16 16:04:01 Sola 习题12-1 改进例题程序
! 2021-05-16 20:45:49 Sola 习题12-2 复数坐标系转换
! 2021-05-16 20:46:28 Sola 习题12-3 复数极坐标乘法
! 2021-05-16 20:46:40 Sola 习题12-4 复数极坐标除法
! 2021-05-16 20:56:15 Sola 习题12-5 建立过了，跳过
! 2021-05-16 20:59:10 Sola 习题12-6 卡笛尔坐标系下点位和直线
! 2021-05-16 21:04:08 Sola 习题12-7 两点间距离
! 2021-05-16 21:14:41 Sola 习题12-8 通过两点计算直线参数
! 2021-05-16 21:36:52 Sola 习题12-9 追踪雷达目标，莫得数据，跳过
! 程序结构:
!
! ==============================================================================
! 模块：
module Chapter12
implicit none
! 数据字典
! 声明常数
REAL, PARAMETER :: PI=3.14159265 ! PI值
REAL, PARAMETER :: e=2.718281828459 ! 自然对数
INTEGER, PARAMETER :: arrayLength=20 ! 数组基准长度
integer, parameter :: sgl = selected_real_kind(p=1) ! 单精度类型
type :: complexChange
real(sgl) :: var1 ! 参数1
real(sgl) :: var2 ! 参数2
contains
procedure, pass :: Car2Pol ! 直角坐标系转化为极坐标系
procedure, pass :: Pol2Car ! 极坐标系转化为直角坐标系
procedure, pass :: PolProduct ! 极坐标系乘法
procedure, pass :: PolDivision ! 极坐标系乘法
end type complexChange
type :: point ! 点位的派生数据
real(sgl) :: x ! X坐标
real(sgl) :: y ! Y坐标
contains
procedure, pass :: Distance ! 两点间距离
procedure, pass :: Point2line ! 计算两点间直线方程
end type point
type :: line ! 直线的派生数据
real(sgl) :: m ! 斜率
real(sgl) :: b ! 截距
end type line
type :: radarInfo
real(sgl) :: length ! 距离
real(sgl) :: theta ! 角度
real(sgl) :: time ! 扫描时间
end type radarInfo
! 声明变量
! 创建显式接口
contains
! subroutine SubName(varName1,varName2)
! implicit none
! ! 数据字典
! end subroutine SubName
! 直角坐标系转化为极坐标系
type(complexChange) function Car2Pol(this)
class(complexChange) :: this
Car2Pol%var1 = sqrt(this%var1**2 + this%var2**2)
Car2Pol%var2 = atan(this%var2, this%var1)
end function Car2Pol
! 极坐标系转化为直角坐标系
type(complexChange) function Pol2Car(this)
class(complexChange) :: this
Pol2Car%var1 = this%var1*cos(this%var2)
Pol2Car%var2 = this%var1*sin(this%var2)
end function Pol2Car
! 复数的极坐标系乘法
type(complexChange) function PolProduct(this, input)
class(complexChange) :: this, input
PolProduct%var1 = this%var1*input%var1
PolProduct%var2 = mod(this%var2 + input%var2 + PI, 2*PI) - PI
end function PolProduct
! 复数的极坐标除法
type(complexChange) function PolDivision(this, input)
class(complexChange) :: this, input
PolDivision%var1 = this%var1/input%var1
PolDivision%var2 = mod(this%var2 - input%var2 + PI, 2*PI) - PI
end function PolDivision
! 计算两点间距离
real function Distance(pointA, pointB)
class(point) :: pointA, pointB
Distance = sqrt((pointB%x - pointA%x)**2 + (pointB%y - pointA%y)**2)
end function Distance
type(line) function Point2line(pointA, pointB)
class(point) :: pointA, pointB
if ( abs(pointA%x - pointB%x) < 1E-30 ) then
stop "所求直线无斜率（与Y轴平行）"
end if
Point2line%m = (pointA%y - pointB%y)/(pointA%x - pointB%x)
Point2line%b = pointA%y - Point2line%m*pointA%x
end function Point2line
end module Chapter12
! ==============================================================================
! 主程序：
program ProName
implicit none
! 数据字典
! 声明常量
! 声明变量
! 变量初始化
! 数据输入
! 运算过程
! 结果输出
! call customer_database
! call Exercises12_2
! call Exercises12_7
end program ProName
! ==============================================================================
! 子程序
! subroutine SubName(varName1,varName2)
! use MouName
! implicit none
! Type, intent(inout) :: varName
! end subroutine SubName
! ==============================================================================
! 函数
! function FunName(varName1,varName2)
! use MouName
! implicit none
! end function FunName
! ==============================================================================
! 习题12-1 修改例题
! 定义了公共模块用来读取数据
module types
implicit none
type :: presonal_info
character(len=12) :: first
character :: mi
character(len=12) :: last
character(len=26) :: street
character(len=12) :: city
character(len=2) :: state
integer :: zip
end type presonal_info
end module types
! 输入数据以及排序的主函数
subroutine customer_database
use types
implicit none
integer, parameter :: MAX_SIZE = 100
logical, external :: lt_last
logical, external :: lt_city
logical, external :: lt_zip
type(presonal_info), dimension(MAX_SIZE) :: customers
integer :: choice
logical :: exceed = .FALSE.
character(len=20) :: filename
integer :: i
integer :: nvals = 0
integer :: status
type(presonal_info) :: temp
open(unit=1, status='scratch', iostat=status)
if ( status /= 0 ) stop ""
write(1, '(A)') &
&"John Q Public 123 Sesame Street Anywhere NY 10035", &
&"James R Johnson Rt. 5 Box 207C West Monroe LA 71291", &
&"Joseph P Ziskend P. O. Box 433 APO AP 96555", &
&"Andrew D Jackson Jackson Square New Orleans LA 70003", &
&"Jane X Doe 12 Lakeside Drive Glenview IL 60025", &
&"Colin A Jeffries 11 Main Street Chicago IL 60003"
rewind(unit=1, iostat=status)
if ( status /= 0 ) stop ""
do
read(1, 1010, iostat=status) temp
1010 format(A12, 1X, A1, 1X, A12, 1X, A26, 1X, A12, 1X, A2, 1X, I5)
if ( status /= 0 ) exit
nvals = nvals + 1
if ( nvals <= MAX_SIZE ) then
customers(nvals) = temp
else
exceed = .TRUE.
end if
end do
if ( exceed ) then
write(*, 1020) nvals, MAX_SIZE
1020 format(' Maximum array size exceeded: ', I6, ' > ', I6)
else
write(*, 1030)
1030 format(&
1X, 'Enter way to sort database:', /&
1X, ' 1 -- By last name ', /&
1X, ' 2 -- By city ', /&
1X, ' 3 -- By zip code ')
read(*, *) choice
select case (choice)
case(1)
call sort_database(customers, nvals, lt_last)
case(2)
call sort_database(customers, nvals, lt_city)
case(3)
call sort_database(customers, nvals, lt_zip)
case default
write(*, *) 'Invalid choice entered!'
end select
write(*, '(A)') 'The sorted database values are: '
write(*, 1040) (customers(i), i = 1, nvals)
1040 format(A12, 1X, A1, 1X, A12, 1X, A26, 1X, A12, 1X, A2, 1X, I5)
end if
end subroutine customer_database
! 排序对应数据子程序
subroutine sort_database(array, n, lt_fun)
use types
implicit none
integer, intent(in) :: n
type(presonal_info), dimension(n), intent(inout) :: array
logical, external :: lt_fun
integer :: i
integer :: iptr
integer :: j
type(presonal_info) :: temp
do i = 1, n-1
iptr = i
do j = i+1, n
if ( lt_fun(array(j),array(iptr)) ) then
iptr = j
end if
end do
if ( i /= iptr ) then
temp = array(i)
array(i) = array(iptr)
array(iptr) = temp
end if
end do
end subroutine sort_database
! 排序函数
logical function lt_last(a, b)
use types
implicit none
type(presonal_info), intent(in) :: a, b
lt_last = LLT(a%last, b%last)
end function lt_last
! 主要在这里修改，全部检测大写即可，如果需要继续改进的话，名称可能也要改？倒是也没必要，名字只有首字母大写
logical function lt_city(a, b)
use types
implicit none
type(presonal_info), intent(in) :: a, b
lt_city = LLT(Ucase(a%city), Ucase(b%city))
contains
function Ucase(str)
character(len=*), intent(in) :: str ! 定义输入字符串
character(len=len(str)) :: ucase ! 定义函数类型
integer :: i ! 循环参数
do i = 1, len(str) ! 对输入每个字符循环
if ( lge(str(i: i), 'a') .and. lle(str(i: i), 'z') ) then ! 如果字符在a~z中
Ucase(i: i) = achar( iachar(str(i: i)) - 32 ) ! 输出大写
else
Ucase(i: i) = str(i: i) ! 如果不在, 输出原字符
end if
end do
end function Ucase
end function lt_city
logical function lt_zip(a, b)
use types
implicit none
type(presonal_info), intent(in) :: a, b
lt_zip = a%zip < b%zip
end function lt_zip
! 习题12-2 具体函数参考派生数据在模块中的定义
! 习题12-3 极坐标表示复数乘法
! 习题12-4 极坐标表示复数出发
subroutine Exercises12_2
use Chapter12
implicit none
type(complexChange) :: POLAR, a, b
! 习题12-2
POLAR = complexChange(123., 456.)
write(*, *) 'POLAR为： ', POLAR
write(*, *) 'POLAR转化为极坐标系为： ', POLAR%Car2Pol()
write(*, *) 'POLAR转化为直角坐标系为： ', POLAR%Pol2Car()
! 习题12-3
POLAR = POLAR%Car2Pol()
a = POLAR
b = POLAR%PolProduct(a)
write(*, *) 'POLAR之间的乘积为： ', b
! 习题12-4
b = b%PolDivision(a)
write(*, *) '其乘积除以POLAR为： ', b
contains
end subroutine Exercises12_2
! 习题12-7 两点间距离，两点间建立直线
subroutine Exercises12_7
use Chapter12
implicit none
type(point) :: pointA, pointB
pointA = point(1., 3.)
pointB = point(3., 1.)
write(*, *) '点A与点B之间的距离为： ', pointA%Distance(pointB)
write(*, *) '点A与点B之间的直线的斜率和截距为： ', pointA%Point2line(pointB)
contains
end subroutine Exercises12_7

208
第13章习题.f90 Normal file
View File

@ -0,0 +1,208 @@
! ==============================================================================
! 通过 gfortran ./test.f90 -o ./run && ./run 运行
! 程序名：
! 第13章习题
! 目的:
!
! 修订记录:
! 日期 编程者 改动描述
! =================== ============= =====================================
! 2021-05-19 21:36:27 Sola 习题13-1 上一章写过了
! 2021-05-19 21:36:44 Sola 习题13-2 递归函数和子程序计算阶乘
! 2021-05-19 22:06:42 Sola 习题13-3 验证例题13-2的子程序
! 2021-05-19 22:30:37 Sola 习题13-4 ~ 习题13-18 跳过
! 2021-05-19 22:56:02 Sola 习题13-19 极坐标复数
! 2021-05-19 23:21:36 Sola 习题13-20 复数的极坐标乘除
! 2021-05-19 23:40:41 Sola 习题13-21 ~ 习题13-22 跳过
! 2021-05-19 23:42:15 Sola 习题13-23 ...之前就是这么写的
! 2021-05-19 23:44:46 Sola 习题13-24 跳过
! 程序结构:
!
! ==============================================================================
! 主程序：
program Chapter13
implicit none
! 数据字典
! 声明常量
! 声明变量
! 变量初始化
! 数据输入
! 运算过程
! 结果输出
! call Exercises13_2
! call Exercises13_3
! call Exercises13_19
! call Exercises13_20
end program Chapter13
! ==============================================================================
! 习题13-2 递归函数和子程序计算阶乘
subroutine Exercises13_2
implicit none
interface
subroutine SubFactorial(n, result)
implicit none
integer, intent(in) :: n
integer, intent(out) :: result
integer :: temp
end subroutine SubFactorial
recursive function FunFactorial(n) result(result)
implicit none
integer, intent(in) :: n
integer :: result
end function FunFactorial
end interface
integer :: result
call SubFactorial(5, result)
write(*, *) "通过子程序计算5的阶乘为： ", result
write(*, *) "通过函数计算10的阶乘为： ", FunFactorial(10)
end subroutine Exercises13_2
! 阶乘运算子程序
recursive subroutine SubFactorial(n, result)
implicit none
integer, intent(in) :: n
integer, intent(out) :: result
integer :: temp
if ( n >= 1 ) then
call SubFactorial(n-1, temp)
result = n*temp
else
result = 1
end if
end subroutine SubFactorial
! 阶乘运算函数
recursive function FunFactorial(n) result(result)
implicit none
integer, intent(in) :: n
integer :: result
if ( n >= 1 ) then
result = n*FunFactorial(n-1)
else
result = 1
end if
end function FunFactorial
! 习题13-3 验证例题13-2子程序, 求极值
subroutine Exercises13_3
implicit none
interface
subroutine Extremes(a, n, maxVal, posMaxVal, minVal, posMinVal)
implicit none
integer, intent(in) :: n
real, intent(in), dimension(n) :: a
real, intent(out), optional :: maxVal
integer, intent(out), optional :: posMaxVal
real, intent(out), optional :: minVal
integer, intent(out), optional :: posMinVal
end subroutine Extremes
end interface
real, dimension(18) :: input
integer :: maxLoc, minLoc
real :: maxValue, minValue
input = (/ 3., 4., 0., 1., 2., 1., 1., 9., 9., 8., 0., 7., 2., 0., 7., 3., 3., 3./)
call Extremes(input, 18, minVal=minValue, maxVal=maxValue, posMinVal=minLoc, posMaxVal=maxLoc)
write(*, *) "数组在第", maxLoc, "位取到最大值", maxValue
write(*, *) "数组在第", minLoc, "位取到最小值", minValue
end subroutine Exercises13_3
subroutine Extremes(a, n, maxVal, posMaxVal, minVal, posMinVal)
implicit none
integer, intent(in) :: n
real, intent(in), dimension(n) :: a
real, intent(out), optional :: maxVal
integer, intent(out), optional :: posMaxVal
real, intent(out), optional :: minVal
integer, intent(out), optional :: posMinVal
integer :: i
real :: realMax
integer :: posMax
real :: realMin
integer :: posMin
realMax = a(1)
posMax = 1
realMin = a(1)
posMin = 1
do i = 2, n
if ( a(i) > realMax ) then
realMax = a(i)
posMax = i
end if
if ( a(i) < realMin ) then
realMin = a(i)
posMin = i
end if
end do
if ( present(maxVal) ) maxVal = realMax
if ( present(posMaxVal) ) posMaxVal = posMax
if ( present(minVal) ) minVal = realMin
if ( present(posMinVal) ) posMinVal = posMin
end subroutine Extremes
! 习题13-19 极坐标复数
module Exercises13_19_Mod
implicit none
interface assignment(=)
module procedure Complex2Polar
module procedure Polar2Complex
end interface
interface operator(*)
module procedure PolarMul
end interface
interface operator(/)
module procedure PolarDiv
end interface
type :: polar
real :: z
real :: theta
end type
private
! private :: Complex2Polar, Polar2Complex
public :: assignment(=), polar, operator(*), operator(/)
contains
subroutine Complex2Polar(result, input)
implicit none
type(polar), intent(out) :: result
complex, intent(in) :: input
result%z = cabs(input)
result%theta = atan(aimag(input)/real(input))
end subroutine
subroutine Polar2Complex(result, input)
implicit none
complex, intent(out) :: result
type(polar), intent(in) :: input
result = cmplx(input%z*cos(input%theta), input%z*sin(input%theta))
end subroutine
function PolarMul(var1, var2) result(result)
implicit none
type(polar), intent(in) :: var1, var2
type(polar) :: result
result%z = var1%z*var2%z
result%theta = mod(var1%theta + var2%theta + 3.141593, 3.141593*2) - 3.141593
end function PolarMul
function PolarDiv(var1, var2) result(result)
implicit none
type(polar), intent(in) :: var1, var2
type(polar) :: result
result%z = var1%z/var2%z
result%theta = mod(var1%theta - var2%theta + 3.141593, 3.141593*2) - 3.141593
end function PolarDiv
end module Exercises13_19_Mod
subroutine Exercises13_19
use Exercises13_19_Mod, only: assignment(=), polar
implicit none
type(polar) :: a
complex :: b
b = (1.0, 2.0)
a = b
b = a
write(*, *) "计算得到的极坐标形式为", a, "; 计算得到的直角坐标形式为", b
end subroutine Exercises13_19
! 习题13-20 复数的极坐标乘除
subroutine Exercises13_20
use Exercises13_19_Mod, only: polar, operator(*), operator(/), assignment(=)
implicit none
complex :: a, b
type(polar) :: c, d
a = (1.0, 1.0)
b = (1.0,-1.0)
c = a
d = b
write(*, *) "c的初始值为: ", c, "; d的初始值为: ", d
write(*, *) "c*d的结果为: ", c*d, "; c/d的结果为: ", c/d
end subroutine Exercises13_20

500
第14章习题.f90 Normal file
View File

@ -0,0 +1,500 @@
! ==============================================================================
! 通过 gfortran ./test.f90 -o ./run && ./run 运行
! 程序名：
! 第14章习题
! 目的:
!
! 修订记录:
! 日期 编程者 改动描述
! =================== ============= =====================================
! 2021-05-20 22:06:14 Sola 测验14-1 格式描述符的使用
! 2021-05-22 00:53:01 Sola 测验14-2 跳过，顺便判断正误全错
! 2021-05-22 16:36:07 Sola 习题14-1 ~ 习题14-3 跳过
! 2021-05-22 16:36:28 Sola 习题14-4 整数描述符
! 2021-05-22 16:39:34 Sola 习题14-5 使用其他进制描述符
! 2021-05-22 16:52:07 Sola 习题14-6 使用通用类型显示随机数
! 2021-05-22 16:58:00 Sola 习题14-7 使用:描述符
! 2021-05-22 17:36:35 Sola 习题14-8 使用通用类型描述符
! 2021-05-22 17:41:53 Sola 习题14-9 工程表示法
! 2021-05-22 17:45:23 Sola 习题14-10 跳过
! 2021-05-22 17:45:32 Sola 习题14-11 验证列表输出
! 2021-05-22 19:05:42 Sola 习题14-12 验证列表读取
! 2021-05-22 19:36:08 Sola 习题14-13 跳过
! 2021-05-22 19:36:17 Sola 习题14-14 验证不同类型输出
! 2021-05-22 19:55:46 Sola 习题14-15 ~ 习题14-17 跳过
! 2021-05-22 19:56:16 Sola 习题14-18 截尾拷贝文件
! 2021-05-23 13:14:29 Sola 习题14-19 INQUIRE语句测试等
! 2021-05-23 14:00:38 Sola 习题14-20 逆置方式复制文件
! 2021-05-23 14:40:18 Sola 习题14-21 比较格式化和未格式化文件
! 2021-05-23 15:47:44 Sola 习题14-22 比较顺序和直接访问文件
! 程序结构:
!
! ==============================================================================
! 主程序：
program Chapter14
implicit none
! 数据字典
! 声明常量
! 声明变量
! 变量初始化
! 数据输入
! 运算过程
! 结果输出
! call Test14_1
call Exercises14_4
! call Exercises14_6
! call Exercises14_7
! call Exercises14_8
! call Exercises14_11
! call Exercises14_14
! call Exercises14_18
! call Exercises14_19
! call Exercises14_20
! call Exercises14_21
call Exercises14_22
end program Chapter14
! ==============================================================================
subroutine Test14_1
implicit none
real :: a=4096.07
integer :: i=-2002, j=1776, k=-3
write(*, 1) a, a, a, a, a
1 format(1X, F10.1, F9.2, E12.5, G12.5, G11.4)
read(*, *) i, j, k
write(*, 2) i, j, k
2 format(' i = ', I10, ' j = ', I10, ' k = ', I10)
! write(*, '(I8, I8.8)') 1024, 1024
end subroutine Test14_1
! 习题14-4 整数描述符 习题14-5 使用其他进制描述符
subroutine Exercises14_4
implicit none
integer :: i
write(*, *) 'print I8 & I8.8'
write(*, 1) 1024, 1024, -128, -128, 30000, 30000
1 format(I8, 2X, I8.8)
write(*, *) 'print B16, O11 & Z8'
write(*, 2) (1024, i = 1, 3), (-128, i = 1, 3), (30000, i = 1, 3)
2 format(B16, T20, O11, T40, Z8)
end subroutine Exercises14_4
! 习题14-6 使用万能类型显示随机数
subroutine Exercises14_6
implicit none
real :: temp
integer :: i
do i = 1, 9
call random_seed()
call random_number(temp)
temp = temp*110000 - 10000
write(*, '(I1, 2X, G11.5)') i, temp
end do
end subroutine Exercises14_6
! 习题14-7 使用:描述符
subroutine Exercises14_7
implicit none
real, dimension(9) :: temp
integer :: i
do i = 1, 9
! call random_seed()
call random_number(temp(i))
temp(i) = temp(i)*110000 - 10000
end do
! write(*, '(2("VALUE(", SSI1, ") = ", SPF10.2:, 2X))') (i, temp(i), i = 1, 9)
write(*, '(2("VALUE(", SSI1, ") = ", SPI7.6, SSF0.2:, 2X))') (i, int(temp(i)), abs(temp(i)-int(temp(i))), i = 1, 9)
end subroutine Exercises14_7
! 习题14-8 使用通用类型描述符 习题14-9 工程表示法
subroutine Exercises14_8
implicit none
! 习题14-8 使用通用类型描述符
write(*, '(G10.4)') -6.38765E10
write(*, '(G10.4)') -6.38765E2
write(*, '(G10.4)') -6.38765E-1
write(*, '(G10.4)') 2345.6
write(*, '(G10.4)') .TRUE.
write(*, '(G10.4)') 'String!'
! 习题14-9 工程表示法
write(*, '(EN15.6)') -6.38765E10
write(*, '(EN15.6)') -6.38765E2
write(*, '(EN15.6)') -6.38765E-1
write(*, '(EN15.6)') 2345.6
end subroutine Exercises14_8
! 习题14-11 验证列表输出
! 习题14-12 验证列表读取
subroutine Exercises14_11
implicit none
integer :: i, j
real, dimension(3, 3) ::array
integer :: errorLevel
namelist /io/ array
array = reshape((/((10.*i*j, j = 1, 3), i = 0, 2)/), (/3, 3/))
write(*, *) "习题14-11 验证列表输出"
write(*, nml=io)
open(unit=1, status='scratch', iostat=errorLevel)
if ( errorLevel /= 0 ) stop ""
write(1, '(A)') &
&"&io array(1, 1) = -100.", &
&"array(3, 1) = 6., array(1, 3) = -6./", &
&"array(2, 2) = 1000. /"
rewind(unit=1, iostat=errorLevel)
if ( errorLevel /= 0 ) stop ""
read(1, nml=io)
write(*, *) "习题14-12 验证列表读取"
write(*, nml=io)
end subroutine Exercises14_11
! 习题14-14 验证不同类型输出
subroutine Exercises14_14
implicit none
call SubA
call SubB
contains
subroutine SubA
implicit none
real :: value=356.248
integer :: i
write(*, 200) 'Value = ', (value, i = 1, 5)
200 format('0', A, F10.4, G10.2, G11.5, G11.6, ES10.3)
end subroutine SubA
subroutine SubB
implicit none
integer, dimension(5) :: i
integer :: j
do j = 1, 5
i(j) = j**2
end do
read(*, *) i
write(*, 500) i
500 format(3(10X, I5))
end subroutine SubB
end subroutine Exercises14_14
! 习题14-18 截尾拷贝文件
! 1. 在OPEN语句中使用STATUS=和IOSTAT=子句确认输入文件已经存在
! 2. 在OPEN语句中使用STATUS=和IOSTAT=子句确认输出文件不存在
! 3. 如果输出文件存在，提示用户是否覆盖，否则终止程序
! 4. 拷贝完成后，询问用户是否删除原文件
! 变量：输入文件名、输出文件名、拷贝临时变量、错误状态值
subroutine Exercises14_18
implicit none
character(len=128) :: inputFile, outputFile ! 输入输出文件名
integer :: errorLevel ! 错误状态码
character(len=200) :: temp ! 保存输入的临时变量
character :: overwriteSwitch ! 判断是否覆盖已存在的输出文件的变量
logical :: outputFileOpen ! 判断输出文件是否打开的变量
do ! 获取输入文件名
write(*, fmt='(A)', advance='no') 'Please enter the name of the input file : ' ! 提示输入输入文件名
read(*, *) inputFile ! 读取输入文件名
open(unit=1, status='old', iostat=errorLevel, file=inputFile) ! 打开输入文件
if ( errorLevel /= 0 ) then
write(*, *) 'Warning: The input file dont exist!' ! 如果输入文件不存在, 提示错误并重新输入
else
exit ! 如果输入文件存在, 进行下一环节
end if
end do
write(*, fmt='(A)', advance='no') 'Please enter the name of the output file : ' ! 提示输入输出文件名
read(*, *) outputFile ! 读取输出文件名
open(unit=2, status='new', iostat=errorLevel, file=outputFile) ! 以新文件形式打开输出文件
if ( errorLevel /= 0 ) then
write(*, fmt='(A)', advance='no') 'Warning: The output file has existed, overwrite it? (Y/N): ' ! 如果输出文件存在, 提示是否覆盖
do
read(*, *, iostat=errorLevel) overwriteSwitch ! 读取用户选项
if ( errorLevel /= 0 .or. ( Ucase(overwriteSwitch) /= 'Y' .and. Ucase(overwriteSwitch) /= 'N' ) ) then ! 如果输入非法
write(*, fmt='(A)', advance='no') 'Illgle input, please enter again (Y/N): ' ! 提示错误, 并再次读取用户输入
elseif ( Ucase(overwriteSwitch) == 'Y' ) then
open(unit=2, status='replace', iostat=errorLevel, file=outputFile) ! 如果选择覆盖
if ( errorLevel /= 0 ) stop "Warning: Replace the output file fatal!" ! 如果打开输出文件失败, 退出程序
exit ! 如果打开输出文件成功, 进行下一环节
else
exit ! 如果选择不覆盖, 进入下一环节
end if
end do
end if
if ( Ucase(overwriteSwitch) /= 'N' ) then ! 如果输出文件不存在或用户选择覆盖
inquire(unit=2, opened=outputFileOpen, iostat=errorLevel) ! 确认输出文件已打开
if ( errorLevel /= 0 ) stop "Query output file status error " ! 如果查询输出文件状态出错, 提示错误信息并终止程序
if ( outputFileOpen .eqv. .FALSE. ) stop "The output file is not open!" ! 如果输出文件未打开, 提示错误信息并终止程序
do ! 逐行复制文件内容
read(1, '(A)', iostat=errorLevel) temp ! 读取每行给临时变量
if ( errorLevel < 0 ) then
exit ! 如果到达文件末尾, 结束读取, 进入下一环节
elseif ( errorLevel > 0 ) then
stop "Error reading file record!" ! 如果读取文件记录出错, 提示错误信息并终止程序
else
write(2, '(A)', iostat=errorLevel) trim(temp) ! 将读取到的内容去除尾部空格后, 输出到输出文件
! write(*, '(A)', iostat=errorLevel) trim(temp)
if ( errorLevel /= 0 ) stop "Error copying records!" ! 拷贝记录出错, 提示错误信息并终止程序
end if
end do
write(*, fmt='(A)', advance='no') 'The copy is complete, whether to delete the input file? (Y/N): ' ! 复制文件完成, 提示用户是否删除输入文件
do ! 检测用户输出
read(*, *, iostat=errorLevel) overwriteSwitch ! 读取用户输出(这里重复使用变量了,,,)
if ( errorLevel /= 0 .or. ( Ucase(overwriteSwitch) /= 'Y' .and. Ucase(overwriteSwitch) /= 'N' ) ) then
write(*, fmt='(A)', advance='no') 'Illgle input, please enter again (Y/N): ' ! 如果输入非法, 提示错误信息并重新读取用户输入
elseif ( Ucase(overwriteSwitch) == 'Y' ) then
close(unit=1, status='delete', iostat=errorLevel) ! 如果用户选择删除输入文件, 关闭并删除输入文件
if ( errorLevel /= 0 ) stop "Error closing input file!" ! 如果关闭输入文件出错, 提示错误信息并终止程序
write(*, '(A)') 'Delete input file successed!' ! 顺利关闭并删除输入文件, 提示成功信息
exit ! 结束检测用户输入, 进入下一环节
else
close(unit=1, status='keep', iostat=errorLevel) ! 如果用户选择不删除, 则关闭输入文件
if ( errorLevel /= 0 ) stop "Error closing input file!" ! 如果关闭输入文件出错, 提示错误信息并终止程序
exit ! 顺利关闭输入文件, 结束检测用户输入, 进入下一环节
end if
end do
close(unit=2, iostat=errorLevel) ! 关闭输出文件
if ( errorLevel /= 0 ) stop "Error closing output file!" ! 如果关闭输出文件出错, 提示错误信息并终止程序
end if
write(*, '(A)') 'Program end! If the text appears garbled, please try to open the file in UTF-8 format!' ! 提示程序运行完成
contains
function Ucase(str)
character(len=*), intent(in) :: str ! 定义输入字符串
character(len=len(str)) :: ucase ! 定义函数类型
integer :: i ! 循环参数
do i = 1, len(str) ! 对输入每个字符循环
if ( lge(str(i: i), 'a') .and. lle(str(i: i), 'z') ) then ! 如果字符在a~z中
Ucase(i: i) = achar( iachar(str(i: i)) - 32 ) ! 输出大写
else
Ucase(i: i) = str(i: i) ! 如果不在, 输出原字符
end if
end do
end function Ucase
end subroutine Exercises14_18
! 习题14-19 INQUIRE语句测试等
subroutine Exercises14_19
implicit none
call SubA
call SubB
contains
subroutine SubA
implicit none
character(len=10) :: acc, fmt, act, delim
integer :: unit=35
logical :: lexist, lnamed, lopen
inquire(file='run', exist=lexist)
if ( lexist ) then
open(unit, file='run', status='old')
inquire(unit=unit, opened=lopen, exist=lexist, named=lnamed, access=acc, form=fmt, action=act, delim=delim)
write(*, 100) lexist, lopen, lnamed, acc, fmt, act, delim
100 format(1X, "File status: Exist = ", L1, ' Opened = ', L1, ' Named = ', L1, ' Access = ', A,/&
&' Format = ', A, ' Action = ', A,/&
&' Delims = ', A)
end if
end subroutine SubA
subroutine SubB
implicit none
integer :: i1=10
open (9, file='file1', access='direct', form='formatted', status='new', recl=6)
write(9, '(I6)', rec=1) i1
end subroutine SubB
end subroutine Exercises14_19
! 习题14-20 逆置方式复制文件
subroutine Exercises14_20
implicit none
character(len=128) :: inputFile, outputFile ! 输入输出文件名
integer :: errorLevel ! 错误状态码
character(len=200) :: temp ! 保存输入的临时变量
character :: overwriteSwitch ! 判断是否覆盖已存在的输出文件的变量
logical :: outputFileOpen ! 判断输出文件是否打开的变量
integer :: fileLength = 0 ! 文件长度计数
integer :: i ! 循环参数
do ! 获取输入文件名
write(*, fmt='(A)', advance='no') 'Please enter the name of the input file : ' ! 提示输入输入文件名
read(*, *) inputFile ! 读取输入文件名
open(unit=1, status='old', iostat=errorLevel, file=inputFile) ! 打开输入文件
if ( errorLevel /= 0 ) then
write(*, *) 'Warning: The input file dont exist!' ! 如果输入文件不存在, 提示错误并重新输入
else
exit ! 如果输入文件存在, 进行下一环节
end if
end do
write(*, fmt='(A)', advance='no') 'Please enter the name of the output file : ' ! 提示输入输出文件名
read(*, *) outputFile ! 读取输出文件名
open(unit=2, status='new', iostat=errorLevel, file=outputFile) ! 以新文件形式打开输出文件
if ( errorLevel /= 0 ) then
write(*, fmt='(A)', advance='no') 'Warning: The output file has existed, overwrite it? (Y/N): ' ! 如果输出文件存在, 提示是否覆盖
do
read(*, *, iostat=errorLevel) overwriteSwitch ! 读取用户选项
if ( errorLevel /= 0 .or. ( Ucase(overwriteSwitch) /= 'Y' .and. Ucase(overwriteSwitch) /= 'N' ) ) then ! 如果输入非法
write(*, fmt='(A)', advance='no') 'Illgle input, please enter again (Y/N): ' ! 提示错误, 并再次读取用户输入
elseif ( Ucase(overwriteSwitch) == 'Y' ) then
open(unit=2, status='replace', iostat=errorLevel, file=outputFile) ! 如果选择覆盖
if ( errorLevel /= 0 ) stop "Warning: Replace the output file fatal!" ! 如果打开输出文件失败, 退出程序
exit ! 如果打开输出文件成功, 进行下一环节
else
exit ! 如果选择不覆盖, 进入下一环节
end if
end do
end if
if ( Ucase(overwriteSwitch) /= 'N' ) then ! 如果输出文件不存在或用户选择覆盖
inquire(unit=2, opened=outputFileOpen, iostat=errorLevel) ! 确认输出文件已打开
if ( errorLevel /= 0 ) stop "Query output file status error " ! 如果查询输出文件状态出错, 提示错误信息并终止程序
if ( outputFileOpen .eqv. .FALSE. ) stop "The output file is not open!" ! 如果输出文件未打开, 提示错误信息并终止程序
do ! 逐行复制文件内容
read(1, '(A)', iostat=errorLevel) temp ! 读取每行给临时变量
if ( errorLevel < 0 ) then
exit ! 如果到达文件末尾, 结束读取, 进入下一环节
elseif ( errorLevel > 0 ) then
stop "01: Error reading file record!" ! 如果读取文件记录出错, 提示错误信息并终止程序
end if
fileLength = fileLength + 1 ! 记录文件行数
end do
backspace(unit=1, iostat=errorLevel) ! 回退到上一行(文件结束位置)
if ( errorLevel /= 0 ) stop "02: Error reading file record!"
backspace(unit=1, iostat=errorLevel) ! 回退到上一行(文件末端记录开始)
if ( errorLevel /= 0 ) stop "02: Error reading file record!"
do i = 1, fileLength ! 逐行复制文件内容
read(1, '(A)', iostat=errorLevel) temp ! 读取每行给临时变量
if ( errorLevel /= 0 ) then
stop "03: Error reading file record!" ! 如果读取文件记录出错, 提示错误信息并终止程序
else
write(2, '(A)', iostat=errorLevel) trim(temp) ! 将读取到的内容去除尾部空格后, 输出到输出文件
! write(*, '(A)', iostat=errorLevel) trim(temp)
if ( errorLevel /= 0 ) stop "04: Error copying records!" ! 拷贝记录出错, 提示错误信息并终止程序
end if
backspace(unit=1, iostat=errorLevel) ! 回退到本次读取记录开始
if ( errorLevel /= 0 ) stop "05: Error reading file record!"
backspace(unit=1, iostat=errorLevel) ! 回退到下次读取记录开始
if ( errorLevel /= 0 ) stop "06: Error reading file record!"
end do
write(*, fmt='(A)', advance='no') 'The copy is complete, whether to delete the input file? (Y/N): ' ! 复制文件完成, 提示用户是否删除输入文件
do ! 检测用户输出
read(*, *, iostat=errorLevel) overwriteSwitch ! 读取用户输出(这里重复使用变量了,,,)
if ( errorLevel /= 0 .or. ( Ucase(overwriteSwitch) /= 'Y' .and. Ucase(overwriteSwitch) /= 'N' ) ) then
write(*, fmt='(A)', advance='no') 'Illgle input, please enter again (Y/N): ' ! 如果输入非法, 提示错误信息并重新读取用户输入
elseif ( Ucase(overwriteSwitch) == 'Y' ) then
close(unit=1, status='delete', iostat=errorLevel) ! 如果用户选择删除输入文件, 关闭并删除输入文件
if ( errorLevel /= 0 ) stop "Error closing input file!" ! 如果关闭输入文件出错, 提示错误信息并终止程序
write(*, '(A)') 'Delete input file successed!' ! 顺利关闭并删除输入文件, 提示成功信息
exit ! 结束检测用户输入, 进入下一环节
else
close(unit=1, status='keep', iostat=errorLevel) ! 如果用户选择不删除, 则关闭输入文件
if ( errorLevel /= 0 ) stop "Error closing input file!" ! 如果关闭输入文件出错, 提示错误信息并终止程序
exit ! 顺利关闭输入文件, 结束检测用户输入, 进入下一环节
end if
end do
close(unit=2, iostat=errorLevel) ! 关闭输出文件
if ( errorLevel /= 0 ) stop "Error closing output file!" ! 如果关闭输出文件出错, 提示错误信息并终止程序
end if
write(*, '(A)') 'Program end! If the text appears garbled, please try to open the file in UTF-8 format!' ! 提示程序运行完成
contains
function Ucase(str)
character(len=*), intent(in) :: str ! 定义输入字符串
character(len=len(str)) :: ucase ! 定义函数类型
integer :: i ! 循环参数
do i = 1, len(str) ! 对输入每个字符循环
if ( lge(str(i: i), 'a') .and. lle(str(i: i), 'z') ) then ! 如果字符在a~z中
Ucase(i: i) = achar( iachar(str(i: i)) - 32 ) ! 输出大写
else
Ucase(i: i) = str(i: i) ! 如果不在, 输出原字符
end if
end do
end function Ucase
end subroutine Exercises14_20
! 习题14-21 比较格式化和未格式化文件
subroutine Exercises14_21
implicit none
integer, parameter :: sgl=selected_real_kind(p=1) ! 单精度类型数
real(sgl), dimension(10000) :: array ! 输入数组
real(sgl) :: timeFor, timeUnfor ! 输出格式化文件和非格式化文件所需时间
integer :: i ! 循环参数
integer :: errorLevel ! 错误状态码
integer, dimension(8) :: timeNow ! 计算时间用
integer, dimension(8) :: timeOld ! 计算时间用
do i = 1, 10000
call random_number(array(i)) ! 获取一个长度10000的随机数组
end do
array = array*2E6 - 1E6 ! 重设数组值的大小范围
open(unit=1, file='TempFormatted', status='replace', form='formatted', iostat=errorLevel) ! 打开格式化文件
if ( errorLevel /= 0 ) stop ""
open(unit=2, file='TempUnformatted', status='replace', form='unformatted', iostat=errorLevel) ! 打开非格式化文件
if ( errorLevel /= 0 ) stop ""
call set_timer ! 开始计算时间
write(1, '(100ES13.6)') array ! 将数组内容输出到格式化文件
call elapsed_time(timeFor) ! 计算经过时间
call set_timer ! 开始计算时间
do i = 1, 100
write(2) array(100*(i-1)+1: 100*i) ! 将数组输出到非格式化文件中
end do
call elapsed_time(timeUnfor) ! 计算经过时间
write(*, *) '写入格式化文件花费时间 ', timeFor, ' s, 写入非格式化文件花费时间 ', timeUnfor, ' s'! 输出结果
contains
subroutine set_timer ! 创建子程序1
call DATE_AND_TIME(values=timeNow) ! 调用当前时间子程序
end subroutine set_timer ! 结束子程序1
subroutine elapsed_time(timePast) ! 创建子程序2
real, intent(out) :: timePast ! 定义输出变量
timeOld = timeNow ! 传递值
call set_timer ! 调用子程序1
timePast = ((real(timeNow(3)-timeOld(3))*24 + real(timeNow(5)-timeOld(5)))&
&*60 + real(timeNow(6)-timeOld(6)))*60 + real(timeNow(7)-timeOld(7)) + &
&real(timeNow(8)-timeOld(8))/1000 ! 计算经历时间(秒)
end subroutine elapsed_time ! 结束子程序2
end subroutine Exercises14_21
! 习题14-22 比较顺序和直接访问文件
subroutine Exercises14_22
implicit none
integer, parameter :: sgl=selected_real_kind(p=1) ! 单精度类型数
real(sgl), dimension(10000) :: array ! 输入数组
real(sgl) :: timeSeqFor, timeDirFor, timeDirUnf ! 输出格式化文件和非格式化文件所需时间
real(sgl) :: temp ! 临时变量
integer :: i, j ! 循环参数
integer :: errorLevel ! 错误状态码
integer, dimension(8) :: timeNow ! 计算时间用
integer, dimension(8) :: timeOld ! 计算时间用
do i = 1, 10000
call random_number(array(i)) ! 获取一个长度10000的随机数组
end do
array = array*2E6 - 1E6 ! 重设数组值的大小范围
open(unit=1, file='TempSeqFor', status='replace', form='formatted', access='sequential', iostat=errorLevel) ! 打开格式化顺序访问文件
if ( errorLevel /= 0 ) stop ""
write(1, '(ES14.7)') array ! 将数组内容输出到格式化顺序访问文件
open(unit=2, file='TempDirFor', status='replace', form='formatted', access='direct', recl=14, iostat=errorLevel) ! 打开格式化随机访问文件
if ( errorLevel /= 0 ) stop ""
do i = 1, 10000
write(2, rec=i, fmt='(ES14.7)') array(i) ! 将数组内容输出到格式化随机访问文件
end do
inquire(iolength=i) array(1)
open(unit=3, file='TempDirUnf', status='replace', form='unformatted', access='direct', recl=i, iostat=errorLevel) ! 打开非格式化随机访问文件
if ( errorLevel /= 0 ) stop ""
do i = 1, 10000
write(3, rec=i) array(i) ! 将数组输出到非格式化随机访问文件中
end do
call set_timer ! 开始计算时间
do i = 1, 1000
rewind(unit=1, iostat=errorLevel)
if (errorLevel /= 0 ) stop ""
do j = 1, i
read(1, *) temp
end do
rewind(unit=1, iostat=errorLevel)
if (errorLevel /= 0 ) stop ""
do j = 1, 10000-i+1
read(1, *) temp
end do
end do
call elapsed_time(timeSeqFor) ! 计算经过时间
call set_timer ! 开始计算时间
do i = 1, 1000
read(2, '(ES14.7)', rec=i) temp
read(2, '(ES14.7)', rec=10000-i+1) temp
end do
call elapsed_time(timeDirFor) ! 计算经过时间
call set_timer ! 开始计算时间
do i = 1, 1000
read(3, rec=i) temp
read(3, rec=10000-i+1) temp
end do
call elapsed_time(timeDirUnf) ! 计算经过时间
write(*, *) '格式化顺序访问文件读取耗时 : ', timeSeqFor, ' s'
write(*, *) '格式化随机访问文件读取耗时 : ', timeDirFor, ' s'
write(*, *) '非格式化随机访问文件读取耗时 : ', timeDirUnf, ' s'
contains
subroutine set_timer ! 创建子程序1
call DATE_AND_TIME(values=timeNow) ! 调用当前时间子程序
end subroutine set_timer ! 结束子程序1
subroutine elapsed_time(timePast) ! 创建子程序2
real, intent(out) :: timePast ! 定义输出变量
timeOld = timeNow ! 传递值
call set_timer ! 调用子程序1
timePast = ((real(timeNow(3)-timeOld(3))*24 + real(timeNow(5)-timeOld(5)))&
&*60 + real(timeNow(6)-timeOld(6)))*60 + real(timeNow(7)-timeOld(7)) + &
&real(timeNow(8)-timeOld(8))/1000 ! 计算经历时间(秒)
end subroutine elapsed_time ! 结束子程序2
end subroutine Exercises14_22

1016
第15章习题.f90 Normal file
View File

File diff suppressed because it is too large Load Diff

729
第16章习题.f90 Normal file
View File

@ -0,0 +1,729 @@
! ==============================================================================
! 通过 gfortran ./test.f90 -o ./run && ./run 运行
! 程序名：
! 第16章习题
! 目的:
!
! 修订记录:
! 日期 编程者 改动描述
! =================== ============= =====================================
! 2021-06-07 21:12:49 Sola 习题16-1 跳过
! 2021-06-07 21:13:08 Sola 习题16-2 改进本章创建的date类
! 2021-06-08 00:33:44 Sola 习题16-3 薪资计算
! 2021-06-08 15:27:53 Sola 习题16-4 通用多边形
! 2021-06-08 23:01:22 Sola 习题16-5 多维矢量运算
! 程序结构:
!
! ==============================================================================
! 主程序：
program Chapter16
implicit none
! call Exercises16_2
! call Exercises16_3
! call Exercises16_4
call Exercises16_5
end program Chapter16
! 习题16-2 改进本章创建的date类
module ModDateClass
implicit none
private ! 隐藏变量
type, public :: date ! 定义日期类
private
integer :: year = 1900 ! 年份, 默认1900
integer :: month = 1 ! 月份, 默认1月
integer :: day = 1 ! 日期, 默认1日
contains
procedure, public :: set_date => set_date_sub ! 设置年月日
procedure, public :: get_day => get_day_fn ! 获得日期
procedure, public :: get_month => get_month_fn ! 获得月份
procedure, public :: get_year => get_year_fn ! 获得年份
procedure, public :: is_leap_year => is_leap_year_fn ! 是否是闰年
procedure, public :: is_equal => is_equal_fn ! 年份是否相等
procedure, public :: is_earlier_than => is_earlier_fn ! 输入日期对象是否早于当前日期
procedure, public :: is_later_than => is_later_fn ! 输入日期对象是否晚于当前日期
procedure, public :: to_string => to_string_fn ! 输出当前日期的字符串形式
procedure, public :: day_of_year => day_of_year_fn ! 判断该日期是对应年份的第几天
procedure, public :: days_between => days_between_fn ! 计算两个日期之间的间隔天数
end type date
contains
subroutine set_date_sub(this, day, month, year) ! 设置日期
implicit none
class(date) :: this ! 返回自身
integer, intent(in) :: day ! 日期
integer, intent(in) :: month ! 月份
integer, intent(in) :: year ! 年份
this%day = day ! 给日期赋值, 下同
this%month = month
this%year = year
end subroutine set_date_sub
! 获得日期
integer function get_day_fn(this)
implicit none
class(date) :: this
get_day_fn = this%day
end function get_day_fn
! 获得月份
integer function get_month_fn(this)
implicit none
class(date) :: this
get_month_fn = this%month
end function get_month_fn
! 获得年份
integer function get_year_fn(this)
implicit none
class(date) :: this
get_year_fn = this%year
end function get_year_fn
! 判断是否是闰年
logical function is_leap_year_fn(this)
implicit none
class(date) :: this ! 输入自身
if ( mod(this%year, 400) == 0 ) then
is_leap_year_fn = .TRUE. ! 如果可以被400整除, 则是闰年
else if ( mod(this%year, 100) == 0 ) then
is_leap_year_fn = .FALSE. ! 如果不可以被400整除, 但可以被100整除, 则不是闰年
else if ( mod(this%year, 4) == 0 ) then
is_leap_year_fn = .TRUE. ! 如果不可以被100整除, 但是可以被4整除, 则是闰年
else
is_leap_year_fn = .FALSE. ! 如果不可以被4整除, 则不是闰年
end if
end function is_leap_year_fn
! 判断两个日期是否相同
logical function is_equal_fn(this, that)
implicit none
class(date) :: this
class(date) :: that
if ( (this%year == that%year) .and. (this%month == that%month) .and. (this%day == that%day) ) then
is_equal_fn = .TRUE.
else
is_equal_fn = .FALSE.
end if
end function is_equal_fn
! 判断输入日期是否较早
logical function is_earlier_fn(this, that)
implicit none
class(date) :: this
class(date) :: that
if ( that%year > this%year ) then
is_earlier_fn = .FALSE. ! 如果输入日期年份更大, 则输入日期更晚
else if ( that%year < this%year ) then
is_earlier_fn = .TRUE. ! 如果输入日期年份更小, 则输入日期更早
else
if ( that%month > this%month ) then
is_earlier_fn = .FALSE. ! 如果年份相同, 而输入日期月份更大, 则输入日期更晚
else if ( that%month < this%month ) then
is_earlier_fn = .TRUE. ! 如果年份相同, 而输入日期月份更小, 则输入日期更早
else
if ( that%day >= this%day ) then
is_earlier_fn = .FALSE. ! 如果年月相同, 而输入日期更大, 则其更晚
else
is_earlier_fn = .TRUE. ! 如果年月相同, 而输入日期更小, 则其更早
end if
end if
end if
end function is_earlier_fn
! 判断输入日期是否较晚, 逻辑同上相反, 注释略
logical function is_later_fn(this, that)
implicit none
class(date) :: this
class(date) :: that
if ( that%year > this%year ) then
is_later_fn = .TRUE.
else if ( that%year < this%year ) then
is_later_fn = .FALSE.
else
if ( that%month > this%month ) then
is_later_fn = .TRUE.
else if ( that%month < this%month ) then
is_later_fn = .FALSE.
else
if ( that%day >= this%day ) then
is_later_fn = .TRUE.
else
is_later_fn = .FALSE.
end if
end if
end if
end function is_later_fn
! 输入当前日期的字符串
character(len=10) function to_string_fn(this)
implicit none
class(date) :: this
character(len=2) :: dd
character(len=2) :: mm
character(len=4) :: yy
integer :: i
write(dd, '(I2.2)') this%day ! 读入日期
write(mm, '(I2.2)') this%month ! 读入月份
write(yy, '(I4.4)') this%year ! 读入年份
to_string_fn = mm//'/'//dd//'/'//yy ! 输出字符串
! do i = 1, len(to_string_fn)
! if ( iachar(to_string_fn(i: i)) == 32 ) then
! to_string_fn(i: i) = '0' ! 如果有空格, 则替换为0
! end if
! end do
end function to_string_fn
! 计算日期是当前年份的第几天
integer function day_of_year_fn(this)
implicit none
class(date) :: this
integer, dimension(12) :: daysOfMonth ! 用来保存十二个月份的天数
if ( this%month > 1 ) then ! 如果输入日期不是1月份的
daysOfMonth((/1,3,5,7,8,10,12/)) = 31 ! 大月
daysOfMonth((/4,6,9,11/)) = 30 ! 小月
if ( this%is_leap_year() ) then ! 判断是否闰年
daysOfMonth(2) = 29 ! 闰年二月
else
daysOfMonth(2) = 28 ! 非闰年二月
end if
day_of_year_fn = sum(daysOfMonth(1: this%month)) + this%day ! 计算天数
else
day_of_year_fn = this%day ! 如果是1月, 直接计算天数
end if
end function day_of_year_fn
! 计算两个日期之间相隔天数
integer function days_between_fn(this, that)
class(date) :: this
class(date) :: that
integer :: year_days ! 对应年份天数
integer :: step ! 步长
integer :: i ! 循环参数
if ( this%is_earlier_than(that) ) then ! 如果输入年份更早
step = -1 ! 步长为-1
else
step = 1 ! 否则, 步长为1
end if
days_between_fn = 0 ! 初始化间隔
if ( this%year /= that%year ) then ! 如果非同年
do i = this%year, that%year, step ! 对两个年份之间的每一年份循环
if ( i == that%year ) exit ! 如果到达最后一个循环, 则退出(不计算最后一个年份的天数)
if ( mod(i, 400) == 0 ) then ! 判断是否是闰年, 并赋值
year_days = 366
else if ( mod(i, 100) == 0 ) then
year_days = 365
else if ( mod(i, 4) == 0 ) then
year_days = 366
else
year_days = 365
end if
days_between_fn = days_between_fn + year_days*step ! 间隔天数增加当前年份天数*步长
end do
end if
days_between_fn = days_between_fn + that%day_of_year() - this%day_of_year() ! 计算总天数
end function days_between_fn
end module ModDateClass
subroutine Exercises16_2
use ModDateClass
implicit none
type(date) :: date1
type(date) :: date2
type(date) :: date3
integer :: yy, mm, dd
integer :: errorLevel
do
write(*, '(A)', advance='no') 'Please enter the date1 like YYYY MM DD: '
read(*, *, iostat=errorLevel) yy, mm, dd
if ( errorLevel /= 0 ) then
write(*, *) 'Wrong input, please try again.'
else
exit
end if
end do
call date1%set_date(dd, mm, yy)
do
write(*, '(A)', advance='no') 'Please enter the date2 like YYYY MM DD: '
read(*, *, iostat=errorLevel) yy, mm, dd
if ( errorLevel /= 0 ) then
write(*, *) 'Wrong input, please try again.'
else
exit
end if
end do
call date2%set_date(dd, mm, yy)
call date3%set_date(1, 1, 1900)
write(*, 1) date1%to_string(), date1%day_of_year()
1 format('---- ', A, ' is the ', I3, ' days in this year.')
write(*, 2) date1%to_string(), date3%days_between(date1)
2 format('From 01/01/1900 to ', A, ' has ', I6, ' days.')
write(*, 3) date1%to_string(), date2%to_string(), date1%days_between(date2)
3 format('From ', A, ' to ', A, ' has ', I6, ' days.')
end subroutine Exercises16_2
! empolyee_class
module ModEmployeeClass
implicit none
! private
type, public :: employee
character(len=30) :: firstName ! 名
character(len=30) :: lastName ! 姓
character(len=11) :: ssn ! 工作号
real :: pay = 0 ! 薪资
contains
procedure, public :: SetEmployee => SetEmployeeSub ! 设置信息
procedure, public :: SetName => SetNameSub ! 设置名称
procedure, public :: SetSsn => SetSsnSub ! 设置工作号
procedure, public :: GetFirstName => GetFirstNameFn ! 获得名
procedure, public :: GetLastName => GetLastNameFn ! 获得姓
procedure, public :: GetSsn => GetSsnFn ! 获得工作号
! procedure(CalcPay), public, deferred :: CalcPay ! 好像用不了抽象类
procedure, public :: CalcPay => CalcPayFn ! 计算薪资
end type employee
! abstract interface
! real function CalcPay(this, hours)
! implicit none
! class(employee) :: this
! real, intent(in) :: hours
! end function CalcPay
! end interface
private :: SetEmployeeSub, SetNameSub, SetSsnSub
private :: GetFirstNameFn, GetLastNameFn, GetSsnFn, CalcPayFn
contains
subroutine SetEmployeeSub(this, first, last, ssn)
implicit none
class(employee) :: this
character(len=*) :: first
character(len=*) :: last
character(len=*) :: ssn
this%firstName = first
this%lastName = last
this%ssn = ssn
this%pay = 0
end subroutine SetEmployeeSub
subroutine SetNameSub(this, first, last)
implicit none
class(employee) :: this
character(len=*), intent(in) :: first
character(len=*), intent(in) :: last
this%firstName = first
this%lastName = last
end subroutine SetNameSub
subroutine SetSsnSub(this, ssn)
implicit none
class(employee) :: this
character(len=*), intent(in) :: ssn
this%ssn = ssn
end subroutine SetSsnSub
character(len=30) function GetFirstNameFn(this)
implicit none
class(employee) :: this
GetFirstNameFn = this%firstName
end function GetFirstNameFn
character(len=30) function GetLastNameFn(this)
implicit none
class(employee) :: this
GetLastNameFn = this%lastName
end function GetLastNameFn
character(len=11) function GetSsnFn(this)
implicit none
class(employee) :: this
GetSsnFn = this%ssn
end function GetSsnFn
real function CalcPayFn(this, hours) ! 空函数, 用来重载用
implicit none
class(employee) :: this
real, intent(in) :: hours
end function CalcPayFn
end module ModEmployeeClass
! salaried_employee_class
module ModSalariedEmployeeClass
use ModEmployeeClass
implicit none
type, public, extends(employee) :: salariedEmployee ! 扩展类, 有固定底薪
private
real :: salary = 0 ! 底薪
contains
procedure, public :: SetSalary => SetSalarySub
procedure, public :: CalcPay => CalcPayFn
end type salariedEmployee
private :: CalcPayFn, SetSalarySub
contains
subroutine SetSalarySub(this, salary)
implicit none
class(salariedEmployee) :: this
real, intent(in) :: salary
this%pay = salary
this%salary = salary
end subroutine SetSalarySub
real function CalcPayFn(this, hours)
implicit none
class(salariedEmployee) :: this
real, intent(in) :: hours
CalcPayFn = this%salary ! 工资 = 底薪
end function CalcPayFn
end module ModSalariedEmployeeClass
! hourly_employee_class
module ModHourlyEmployeeClass
use ModEmployeeClass
implicit none
type, public, extends(employee) :: hourlyEmployee ! 扩展类, 小时工
private
real :: rate = 0 ! 每小时薪资
contains
procedure, public :: SetPayRate => SetPayRateSub
procedure, public :: CalcPay => CalcPayFn
end type hourlyEmployee
private :: CalcPayFn, SetPayRateSub
contains
subroutine SetPayRateSub(this, rate)
implicit none
class(hourlyEmployee) :: this
real, intent(in) :: rate
this%rate = rate
end subroutine SetPayRateSub
real function CalcPayFn(this, hours)
implicit none
class(hourlyEmployee) :: this
real, intent(in) :: hours
this%pay = hours*this%rate
CalcPayFn = this%pay
end function CalcPayFn
end module ModHourlyEmployeeClass
! salary_plus_employee
module ModSalaryPlusEmployeeClass
use ModEmployeeClass
implicit none
type, public, extends(employee) :: salaryPlusEmployee ! 扩展类, 有底薪, 有加班费
private
real :: salary = 0 ! 底薪
real :: rate = 0 ! 加班小时薪资
contains
procedure, public :: SetSalary => SetSalarySub
procedure, public :: SetPayRate => SetPayRateSub
procedure, public :: CalcPay => CalcPayFn
end type salaryPlusEmployee
private :: SetPayRateSub, SetSalarySub, CalcPayFn
contains
subroutine SetSalarySub(this, salary)
implicit none
class(salaryPlusEmployee) :: this
real, intent(in) :: salary
this%salary = salary
end subroutine SetSalarySub
subroutine SetPayRateSub(this, rate)
implicit none
class(salaryPlusEmployee) :: this
real, intent(in) :: rate
this%rate = rate
end subroutine SetPayRateSub
real function CalcPayFn(this, hours)
implicit none
class(salaryPlusEmployee) :: this
real, intent(in) :: hours
if ( hours > 42 ) then
CalcPayFn = this%salary + this%rate*(hours - 42.)
else
CalcPayFn = this%salary
end if
end function CalcPayFn
end module ModSalaryPlusEmployeeClass
! 习题16-3 薪资计算
subroutine Exercises16_3
use ModEmployeeClass
use ModHourlyEmployeeClass
use ModSalariedEmployeeClass
use ModSalaryPlusEmployeeClass
class(employee), pointer :: workerPtr => null()
type(salariedEmployee), pointer :: workerPtr1 => null()
type(hourlyEmployee), pointer :: workerPtr2 => null()
type(salaryPlusEmployee), pointer :: workerPtr3 => null()
integer :: i
integer :: errorLevel
character(len=30) :: firstName
character(len=30) :: lastName
character(len=11) :: ssn
real :: temp
real :: pay
real :: hours
write(*, '(A)', advance='no') 'Please input your first name : '
read(*, *) firstName
write(*, '(A)', advance='no') 'Please input your last name : '
read(*, *) lastName
write(*, '(A)', advance='no') 'Please input your ssn : '
read(*, *) ssn
write(*, 1, advance='no')
1 format(&
&'There are three types of the work below.',/&
&' 1) Salaried Employee',/&
&' 2) Hourly Employee',/&
&' 3) Salary Plus Employee',/&
&'Please choose your work type : ')
do
read(*, *, iostat=errorLevel) i
if ( (errorLevel /= 0) .or. (i > 3) .or. (i < 1) ) then
write(*, '(A)', advance='no') 'Warning: Illegal input, please try again: '
else
exit
end if
end do
select case(i)
case(1)
if ( associated(workerPtr1) ) deallocate(workerPtr1, stat=errorLevel)
if ( errorLevel /= 0 ) stop ""
allocate(workerPtr1, stat=errorLevel)
if ( errorLevel /= 0 ) stop ""
do
write(*, '(A)', advance='no') 'Please input the salary : '
read(*, *, iostat=errorLevel) temp
if ( errorLevel /= 0 ) then
write(*, *) ''
else
call workerPtr1%SetSalary(temp)
exit
end if
end do
workerPtr => workerPtr1
deallocate(workerPtr1, stat=errorLevel)
if ( errorLevel /= 0 ) stop ""
case(2)
if ( associated(workerPtr2) ) deallocate(workerPtr2, stat=errorLevel)
if ( errorLevel /= 0 ) stop ""
allocate(workerPtr2, stat=errorLevel)
if ( errorLevel /= 0 ) stop ""
do
write(*, '(A)', advance='no') 'Please input the rate : '
read(*, *, iostat=errorLevel) temp
if ( errorLevel /= 0 ) then
write(*, *) ''
else
call workerPtr2%SetPayRate(temp)
exit
end if
end do
workerPtr => workerPtr2
deallocate(workerPtr2, stat=errorLevel)
if ( errorLevel /= 0 ) stop ""
case(3)
if ( associated(workerPtr3) ) deallocate(workerPtr3, stat=errorLevel)
if ( errorLevel /= 0 ) stop ""
allocate(workerPtr3, stat=errorLevel)
if ( errorLevel /= 0 ) stop ""
do
write(*, '(A)', advance='no') 'Please input the salary : '
read(*, *, iostat=errorLevel) temp
if ( errorLevel /= 0 ) then
write(*, *) ''
else
call workerPtr3%SetSalary(temp)
exit
end if
end do
do
write(*, '(A)', advance='no') 'Please input the rate : '
read(*, *, iostat=errorLevel) temp
if ( errorLevel /= 0 ) then
write(*, *) ''
else
call workerPtr3%SetPayRate(temp)
exit
end if
end do
workerPtr => workerPtr3
deallocate(workerPtr3, stat=errorLevel)
if ( errorLevel /= 0 ) stop ""
end select
write(*, '(A)', advance='no') 'Please input the work time a month (h) : '
read(*, *) hours
call workerPtr%SetEmployee(firstName, lastName, ssn)
write(*, 2) workerPtr%GetFirstName(), workerPtr%GetLastName(), workerPtr%GetSsn(), workerPtr%CalcPay(hours)
2 format(&
&'Please enjoy the squeeze of capitalists!',/&
&'Your pay slip:',/&
&' FIRST NAME LAST NAME SSN PAYCHECK',/&
&'============================== ============================== =========== ==========',/&
&A, 1X, A, 1X, A, 1X, '$', F9.2)
deallocate(workerPtr, stat=errorLevel)
if ( errorLevel /= 0 ) stop ""
end subroutine Exercises16_3
! 习题16-4 通用多边形
module ModPointClass
implicit none
type, public :: point
real :: x
real :: y
end type point
end module ModPointClass
module ModShapeClass
implicit none
type, public :: shape
contains
procedure, public :: Area => CalcAreaFn
procedure, public :: Perimeter => CalcPerimeterFn
procedure, public :: ToString => ToStringFn
end type shape
private :: CalcAreaFn, CalcPerimeterFn, ToStringFn
contains
real function CalcAreaFn(this)
implicit none
class(shape) :: this
CalcAreaFn = 0.
end function CalcAreaFn
real function CalcPerimeterFn(this)
implicit none
class(shape) :: this
CalcPerimeterFn = 0.
end function CalcPerimeterFn
character(len=50) function ToStringFn(this)
implicit none
class(shape) :: this
ToStringFn = ''
end function ToStringFn
end module ModShapeClass
module ModPolygonClass
use ModPointClass
implicit none
type, public :: polygon
type(point), dimension(:), allocatable :: p
contains
procedure, public :: SetShape => SetShapeSub
procedure, public :: Area => CalcAreaFn
procedure, public :: Perimeter => CalcPerimeterFn
end type polygon
contains
subroutine SetShapeSub(this, num, pointArray)
class(polygon) :: this
integer, intent(in), optional :: num
class(point), dimension(:), allocatable, intent(in), optional :: pointArray
integer :: errorLevel
integer :: i=0
integer :: n
if ( present(num) ) then
n = num
else
write(*, '(A)', advance='no') 'Please enter the number of the points : '
read(*, *) n
end if
do
if ( n < 3 ) then
write(*, '(A)', advance='no') 'The number of the points isn''t enough, try again : '
read(*, *) n
else
exit
end if
end do
if ( allocated(this%p) ) then
deallocate(this%p, stat=errorLevel)
if ( errorLevel /= 0 ) stop ""
end if
allocate(this%p(n), stat=errorLevel)
if ( errorLevel /= 0 ) stop ""
if ( present(pointArray) ) then
do
if ( size(pointArray, 1) /= n ) then
write(*, '(A)') 'Warning: Input array dimensions do not match!'
write(*, '(A)') 'Please enter the coordinates in counterclockwise order.'
do
i = i + 1
if ( i == n + 1 ) exit
write(*, '(A, I3, A)', advance='no') 'Please enter the coordinate', i, ' : '
read(*, *, iostat=errorLevel) this%p(i)%x, this%p(i)%y
if ( errorLevel /= 0 ) then
write(*, '(A)') ''
i = i - 1
end if
end do
else
this%p = pointArray
exit
end if
end do
else
write(*, '(A)') 'No coordinates entered, Please enter the coordinates in counterclockwise order like x y !'
do
i = i + 1
if ( i == n + 1 ) exit
write(*, '(A, I3, A)', advance='no') 'Please enter the coordinate', i, ' : '
read(*, *, iostat=errorLevel) this%p(i)%x, this%p(i)%y
if ( errorLevel /= 0 ) then
write(*, '(A)') 'Warning: Illegal input information, please try again!'
i = i - 1
end if
end do
end if
end subroutine SetShapeSub
real function CalcAreaFn(this)
implicit none
class(polygon) :: this
integer :: i
CalcAreaFn = 0
do i = 1, size(this%p, 1)-1
CalcAreaFn = CalcAreaFn + (this%p(i)%x*this%p(i+1)%y - this%p(i+1)%x*this%p(i)%y)/2.
end do
CalcAreaFn = CalcAreaFn + (this%p(size(this%p, 1))%x*this%p(1)%y - this%p(1)%x*this%p(size(this%p, 1))%y)/2.
end function CalcAreaFn
real function CalcPerimeterFn(this)
implicit none
class(polygon) :: this
integer :: i
do i = 1, size(this%p, 1)-1
CalcPerimeterFn = CalcPerimeterFn + sqrt((this%p(i+1)%x - this%p(i)%x)**2 + (this%p(i+1)%y - this%p(i)%y)**2)
end do
CalcPerimeterFn = CalcPerimeterFn +&
& sqrt((this%p(1)%x - this%p(size(this%p, 1))%x)**2 + (this%p(1)%y - this%p(size(this%p, 1))%y)**2)
end function CalcPerimeterFn
end module ModPolygonClass
subroutine Exercises16_4
use ModPolygonClass
use ModPointClass
implicit none
integer, parameter :: numPolygon=4
type(polygon), dimension(numPolygon) :: shape1
call shape1%SetShape()
! write(*, '(A, F6.2)') 'The area of the polygon is : ', shape1%Area()
! write(*, '(A, F6.2)') 'The perimeter of the polygon is: ', shape1%Perimeter()
write(*, 1) size(shape1%p, 1), shape1%Area(), shape1%Perimeter()
1 format(/&
&'POINTS AREA PERIMETER',/&
&'====== ========== ===========',/&
T2, I3, T9, F6.2, T21, F6.2)
end subroutine Exercises16_4
! 习题16-5 多维矢量运算
module ModVecClass
implicit none
type, abstract, public :: vec
real :: x
real :: y
contains
generic(plus1), public, deferred :: add => plus1
end type vec
private :: plus1
! interface :: operator(+)
! module procedure plus1
! end interface
! abstract interface operator(+)
! module procedure plus1
! end interface
abstract interface
function plus1(this, that)
implicit none
class(type1) :: this
class(type1) :: that
class(type1) :: plus1
end function plus1
end interface
end module ModVecClass
module ModVec2dClass
use ModVecClass
implicit none
type, extends(vec), public :: vec2d
end type vec2d
private :: VecAddFn, VecSubFn
end module ModVec2dClass
subroutine Exercises16_5
use ModVecClass
use ModVec2dClass
implicit none
type(vec2d), pointer :: vector1
type(vec2d), pointer :: vector2
class(vec), pointer :: vector
integer :: errorLevel
! allocate(vector1, stat=errorLevel)
! if ( errorLevel /= 0 ) stop ""
! vector1 = vec2d(1, 2)
! allocate(vector2, stat=errorLevel)
! if ( errorLevel /= 0 ) stop ""
! vector2 = vec2d(1, 3)
! vector => vector1
! call vector%Add(vector2)
! write(*, *) vector%x, vector%y
! write(*, *) vector%Add(vector2)
end subroutine Exercises16_5

302
第2章习题.f90 Normal file
View File

@ -0,0 +1,302 @@
! 2021:04:14 20:02:17 标准程序格式
! program name
! !
! ! 目的:
! !
! !
! ! 修订记录:
! ! 日期 编程者 改动描述
! ! =================== ============= ======================
! !
! !
! ! 程序结构:
! !
! implicit none
! ! 数据字典
! ! 声明常量
! REAL, PARAMETER :: PI=3.14159265 ! PI值
! REAL, PARAMETER :: e=2.718281828459 ! 自然对数
! INTEGER, PARAMETER :: arrayLength=20 ! 数组基准长度
! ! 声明变量
! ! 变量初始化
! ! 数据输入
! ! 运算过程
! ! 结果输出
! end program name
! 2021:04:14 17:31:01 一个用于读取文件中所有数值的程序案例
! program name
! ! =============================================================
! ! 目的:
! ! 遍历一个文件内的所有变量(需要全部是实数或整数)
! ! 修订记录:
! ! 日期 编程者 改动描述
! ! =================== ============= ======================
! ! 2021-04-14 17:46:57 Sola 编写源代码并校正格式
! ! =============================================================
! implicit none
! ! 数据字典
! ! 结构需要
! integer :: i ! 控制读取字符所在位置
! integer :: errorLevel ! 检查错误信息
! integer :: valueStart ! 读取数值开始位置
! integer :: valueEnd ! 读取数值结束位置
! real :: value ! 读取的数值内容
! character(len=128) :: allValue ! 所在行字符内容
! character(len=128) :: selectValue ! 读取所在行第i个字符内容
! character(len=128) :: readValue ! 读取的字符内容
! ! 使用者自定义
! ! 声明常量
! REAL, PARAMETER :: PI=3.14159265 ! PI值
! REAL, PARAMETER :: e=2.718281828459 ! 自然对数
! ! 声明变量
! ! 变量初始化
! valueStart=1
! ! 打开文件
! open (unit=1, file='content', status='old', action='read', iostat=errorLevel)
! if (errorLevel > 0) stop "读取文件出错"
! ! 遍历数值
! do
! read(1, '(A128)', iostat=errorLevel) allValue ! 读取行内容
! if (errorLevel < 0) exit ! 如果到达最后一行, 退出循环
! if (errorLevel > 0) stop "读取行出错" ! 读取行内容出错, 退出程序
! ! 遍历行内字符
! do i=1, len_trim(allValue), 1
! selectValue=allValue(i:i) ! 读取第i个字符
! if ( .not. ( trim(selectValue) == ',' .or. i == len_trim(allValue)) ) then
! cycle ! 如果不是逗号或到达末尾, 则跳过此次循环
! else ! 如果是逗号或到达末尾
! if ( i == len_trim(allValue) ) then
! valueEnd=i ! 如果是到达末尾, 则数值结束位置为i
! else
! valueEnd=i-1 ! 如果并未达到末尾, 则数值结束位置为i-1
! end if
! readValue=allValue(valueStart:valueEnd) ! 读取当前数值
! read(readValue, '(F5.1)', iostat=errorLevel) value ! 将当前数值赋值给一个实数
! if (errorLevel > 0) stop "存在非合法数值，请检查" ! 赋值存在错误, 退出程序
! valueStart=i+1 ! 下一次数值的开始位置为i+1
! end if
! end do
! valueStart=1 ! 开始新一行, 并将数值开始位置重置
! end do
! close (unit=1) ! 关闭文件
! end program name
! program example
! implicit none
! end program example
! 2021:04:08 19:23:29 2-9
! PROGRAM triangle
! IMPLICIT NONE
! REAL :: a, b, c, theta
! REAL, PARAMETER :: PI=3.14159265
! WRITE (*,*) 'Enter the length of the hypotenuse C:'
! READ (*,*) c
! WRITE (*,*) 'Enter the angle THETA in degrees:'
! READ (*,*) theta
! a = c * COS(theta)
! b = c * SIN(theta)
! WRITE (*,*) 'The length of the adjacent side is ', a
! WRITE (*,*) 'The length of the opppsite side is ', b
! END PROGRAM triangle
! 2021:04:08 19:44:56 2-10
! program example
! implicit none
! real :: a, b, c
! integer :: k, l, m
! read (*,*) a, b, c, k
! read (*,*) l, m
! write (*,*) a, b, c, k, l, m
! end program example
! 2021:04:09 19:44:46 2-11
! program example
! implicit none
! real :: hourWages, workTime, allWages
! write (*,*) 'How many wages per hour?'
! read (*,*) hourWages
! write (*,*) 'How much time work a week?'
! read (*,*) workTime
! allWages = hourWages * workTime
! write (*,*) 'You can get the wages of $', allWages, ' a week'
! end program example
! 2021:04:09 20:31:02 2-12
! program example
! implicit none
! real :: m, h, v, PE, KE, E
! real, PARAMETER :: g=10.0
! write (*,*) 'Please enter the m h v for coculate the energy of the item above the ground.'
! read (*,*) m, h, v
! PE=m*g*h
! KE=1./2.*m*v**2
! E=PE + KE
! write (*,*) 'The energy of the item is:', E, 'J'
! end program example
! 2021:04:09 20:37:44 2-13
! program example
! implicit none
! real, parameter :: g=10.0
! real :: v, h
! write (*,*) 'Please enter the highte of the item.'
! read (*,*) h
! v=sqrt(2.*g*h)
! write (*,*) 'The speed is', v, 'm/s'
! end program example
! 2021:04:09 20:42:37 2-14
! program example
! implicit none
! real, parameter :: c=2.9979E8
! real :: E, m, t, P
! write (*,*) 'Please enter the days of reactor run a year.'
! read (*,*) t
! write (*,*) 'Please enter the power(mW) of the reactor.'
! read (*,*) P
! E=P*t*24.*60*60
! m=E*1E6/c**2
! write (*,*) m, 'kg of consumed material per year.'
! end program example
! 2021:04:09 21:03:57 2-17
! program example
! implicit none
! real, parameter :: g=10.0, PI=3.14159265
! real :: L, T
! write (*,*) 'Please input pendulum length(m).'
! read (*,*) L
! T = 2*PI*sqrt(L/g)
! write(unit=*, fmt=*) 'The oscillation period of the pendulum is', T, 's'
! end program example
! 2021:04:09 21:12:01 2-18
! program example
! implicit none
! real :: a, b, c
! write(unit=*, fmt=*) 'Please enter the length(cm) of the two right angle sides.'
! read (*,*) a, b
! c = sqrt(a**2+b**2)
! write(unit=*, fmt=*) 'The length of the hypotenuse of the right triangle is', c, 'cm.'
! end program example
! 2021:04:09 21:18:48 2-19
! program example
! implicit none
! real :: b, x, calculationResult, calculationCheck
! write(unit=*, fmt=*) 'Please enter logarithm x and base b respectively'
! read (*,*) x, b
! calculationResult = log10(x)/log10(b)
! calculationCheck = log(x)/log(b)
! write(unit=*, fmt=*) 'The calculation result is', calculationResult, 'and the check result is', calculationCheck
! end program example
! 2021:04:09 21:27:29 2-20
! program example
! implicit none
! a = 1
! end program example
! 2021:04:09 21:29:00 2-21
! program example
! implicit none
! real :: d, x1, x2, y1, y2
! write(unit=*, fmt=*) 'Please enter the coordinates of the first point.'
! read (*,*) x1, y1
! write(unit=*, fmt=*) 'Please enter the coordinates of the second point.'
! read (*,*) x2, y2
! d = sqrt((x1-x2)**2+(y1-y2)**2)
! write(unit=*, fmt=*) 'The distance between the two points is', d
! end program example
! 2021:04:09 21:33:10 2-22
! program example
! implicit none
! real :: dB, P2
! real, parameter :: P1=1
! write(unit=*, fmt=*) '请输入接受输入能源的级别'
! read (*,*) P2
! dB = 10*log10(P2/P1)
! write(unit=*, fmt=*) '该输入的分贝值为：', dB, 'dB'
! end program example
! 2021:04:09 21:37:13 2-23
! program example
! implicit none
! real :: x, calculationResult, calculationCheck
! real, parameter :: e=2.718281828459
! write(unit=*, fmt=*) '请输入需要计算的双曲余弦值的x值'
! read (*,*) x
! calculationResult = (e**x+e**(-x))/2.
! calculationCheck = COSH(x)
! write(unit=*, fmt=*) '计算结果为：', calculationResult, '核对结果为：', calculationCheck
! end program example
! 2021:04:09 21:42:29 2-24
! program example
! implicit none
! real :: P, F, APR
! integer :: m, n
! write(unit=*, fmt=*) '请输入每年计算复利的次数以及储存年数'
! read (*,*) m, n
! P = 1000.00
! APR = 5
! F = P*(1.+APR/(100.*m))**(m*n)
! write(unit=*, fmt=*) '该账户', n, '年后存款将达到$', F
! end program example
! 2021:04:09 22:07:57 2-25
! program example
! implicit none
! real :: f0, L, C
! real, parameter :: PI=3.14159265
! write(unit=*, fmt=*) '请输入电感值(mH)与电容值(nF)'
! read (*,*) L, C
! f0 = 1/(2*PI*sqrt(L*C))
! write(unit=*, fmt=*) '该无线电的频率为：', f0, 'hz'
! end program example
! 2021:04:09 22:12:51 2-26
! program example
! implicit none
! real :: a, v, r
! real, parameter :: g=9.81, machToMeter=340
! v=0.8*machToMeter
! a=2.5*g
! r = v**2/a
! write(unit=*, fmt=*) '(a) 飞机的飞行半径为', r, 'm'
! v = 1.5*machToMeter
! r = v**2/a
! write(unit=*, fmt=*) '(b) 飞机的飞行半径为', r, 'm'
! a = 7*g
! r = v**2/a
! write(unit=*, fmt=*) '(c) 飞机的飞行最小半径为', r, 'm'
! end program example
! 2021:04:09 22:21:16 2-27
! program example
! implicit none
! real, parameter :: G=6.673E-11
! real :: vescEarth, vescMoon, vescGu, vescJuipter, M, R
! M = 6.0E24
! R = 6.4E6
! vescEarth = sqrt(2*G*M/R)
! M = 7.4E22
! R = 1.7E6
! vescMoon = sqrt(2*G*M/R)
! M = 8.7E20
! R = 4.7E5
! vescGu = sqrt(2*G*M/R)
! M = 1.9E27
! R = 7.1E7
! vescJuipter = sqrt(2*G*M/R)
! write(unit=*, fmt=*) '地球上物体的逃逸速度为', vescEarth, 'm/s'
! write(unit=*, fmt=*) '月球上物体的逃逸速度为', vescMoon, 'm/s'
! write(unit=*, fmt=*) '谷神星上物体的逃逸速度为', vescGu, 'm/s'
! write(unit=*, fmt=*) '木星上物体的逃逸速度为', vescJuipter, 'm/s'
! end program example

921
第5章习题.f90 Normal file
View File

@ -0,0 +1,921 @@
! 2021:04:12 17:39:07 5-1
! program example
! implicit none
! real :: numSquareRoot
! integer :: i, numSquare, numCube
! ! write(*, '(1X, "Table of Square Roots, Squares, and Cubes"')
! write(*, 1)
! 1 FORMAT(1X, "Table of Square Roots, Squares, and Cubes"/&
! &1X, " Number Square Root Square Cube"/&
! &1X, " ====== =========== ====== ===="/&
! &1X)
! ! write(*, '(1X, " Number Square Root Square Cube")')
! ! write(*, '(1X, " ====== =========== ====== ===="')
! DO i=1,10,1
! numSquareRoot = sqrt(real(i))
! numSquare = i**2
! numCube = i**3
! write(*, 2) i, numSquareRoot, numSquare, numCube
! 2 FORMAT(1X, T5, I2, T13, F8.6, T27, I3, T36, I4)
! END DO
! end program example
! 2021:04:13 01:41:33 5-3.1
! program example
! implicit none
! integer :: inforError
! OPEN (UNIT=25, FILE='IN052691', STATUS='OLD', ACTION='READ', IOSTAT=inforError)
! if ( inforError == 0 ) then
! write(*,'(1X, "成功打开文件")')
! else
! write(*,'(1X, "打开文件失败，错误代码为", I3)') inforError
! end if
! close (unit= 25)
! end program example
! 2021:04:13 01:57:01 5-3.2
! program example
! implicit none
! integer :: inforError
! character(len=8) :: out_name
! out_name='12345678'
! open (unit=1, STATUS='new', ACTION='readwrite', file=out_name, IOSTAT=inforError)
! if ( inforError /= 0 ) then
! write(*, '(1X, "新建文件失败")')
! else
! write(*, '(1X, "新建文件成功")')
! endif
! close (unit=1)
! end program example
! 2021:04:13 02:19:06 5-3.4
! program name
! implicit none
! character(len=20) :: first, last, varName, varValue
! integer :: i=0, errorLevel=0, length=0
! open(unit=1, file='content', status='old', action='read', iostat=errorLevel)
! if ( errorLevel > 0 ) stop "出现了错误"
! do
! read(1,*, iostat=errorLevel) varName, varValue
! if ( errorLevel < 0 ) EXIT
! length=length+1
! if ( varName == 'first' ) first=varValue
! if ( varName == 'last' ) last=varValue
! end do
! rewind (unit=1)
! read(1,'(T1, A)') varValue
! write(*,*) first, last, varValue
! close (unit=1)
! end program name
! 2021:04:13 10:13:10 5.6.3 5-3.a
! program name
! implicit none
! integer :: i
! character(len=20) :: fmt
! fmt="('1','i= ', I6.5)"
! i=-123
! write(*,fmt) i
! end program name
! 2021:04:13 10:25:00 5.6.3 5-3.c
! program name
! implicit none
! integer :: i1, i2
! i1=10
! i2=4**2
! write(*, 300) i1 > i2
! 300 format (' ','Result = ', L6)
! end program name
! 2021:04:13 16:56:13 5.6.3 5-7
! program name
! implicit none
! integer :: i=0, j=0, writeLocate
! real :: value0, value1, value2, value3, value4, value5, value6, value7, value8, value9
! write(*, '(T13, "表格：1~10之间（以0.1为一级）各个数的以10为底的对数")')
! write(*,1)
! 1 format (T9, 'X.0', T16, 'X.1', T23, 'X.2', T30, 'X.3', T37, 'X.4', T44, 'X.5', T51, 'X.6',&
! & T58, 'X.7', T65, 'X.8', T72, 'X.9')
! do i = 1, 10, 1
! value0=log10(real(i)+0)
! value1=log10(real(i)+0.1)
! value2=log10(real(i)+0.2)
! value3=log10(real(i)+0.3)
! value4=log10(real(i)+0.4)
! value5=log10(real(i)+0.5)
! value6=log10(real(i)+0.6)
! value7=log10(real(i)+0.7)
! value8=log10(real(i)+0.8)
! value9=log10(real(i)+0.9)
! write(*,2) real(i), value0, value1, value2, value3, value4, value5, value6, value7, value8, value9
! 2 format (T2, F4.1, T8, F5.3, T15, F5.3, T22, F5.3, T29, F5.3, T36, F5.3, T43, F5.3, T50, F5.3,&
! & T57, F5.3, T64, F5.3, T71, F5.3)
! end do
! end program name
! 2021:04:13 17:40:36 5.6.3 5-8
! program name
!
! implicit none
! integer :: i=0, errorLevel, j=0
! real :: average=0, sum=0, standardDeviation=0, value=0
! open (unit=1, file='content', status='old', action='read', iostat=errorLevel)
! if ( errorLevel /= 0 ) stop "Open file fatal!"
! do
! read(1,*,iostat=errorLevel) value
! if ( errorLevel < 0 ) exit
! sum=sum+value
! i=i+1
! end do
! average=sum/i
! rewind (unit=1)
! do j=1,i,1
! read(1,*,iostat=errorLevel) value
! if ( errorLevel /= 0 ) exit
! standardDeviation=(value-average)**2+standardDeviation
! end do
! standardDeviation=sqrt(standardDeviation/i)
! write(*,2) i, sum, average, standardDeviation
! 2 format (1X, '共统计', I3, '个数值，样本总和为', F8.1, '，平均值为', F8.1, '，标准偏差为', F8.1)
! close (unit=1)
!
! end program name
! 2021:04:13 20:11:58 5.6.3 5-13
! program name
!
! implicit none
! integer :: timeSecond, errorLevel, HH, MM, SS
! write(*,'(1X, "Please enter the start time in second(0~86400)")')
! do
! read(*,*, iostat=errorLevel) timeSecond
! if ( errorLevel /= 0 ) then
! write(*,'(1X, "输入数值格式不正确，请输入在0~86400之间的整数")')
! else
! if ( timeSecond > 86400 .or. timeSecond < 0 ) then
! write(*,'(1X, "请在正确的范围内输入数值(0~86400)")')
! else
! exit
! end if
! end if
! end do
! SS=timeSecond-timeSecond/60*60
! MM=(timeSecond-timeSecond/(60*60)*3600)/60
! HH=timeSecond/(60*60)
! write(*,1) HH, MM, SS
! 1 format (1X, "当前的时间为：", I2.2, ":", I2.2, ":", I2.2, ' (24h)')
!
! end program name
! 2021:04:13 20:31:14 5.6.3 5-14
! program name
! implicit none
! integer :: h
! real :: G, M, R, gg=0
! G=6.672E-11
! M=5.98E24
! R=6371E3
! write(*,'(1X, "表格：高度相对于重力加速度一览表"/&
! &1X, "高度(km)", T17, "重力加速度（米/秒2）"/&
! &1x, "=========", T15, "==================")')
! do h=0,40000,500
! gg=-G*M/(R+real(h)*1000)**2
! write(*,1) h, gg
! 1 format (T3, I5, T18, F8.2)
! end do
! end program name
! 2021-04-13 21:48:55 5.6.3 5-21
! program name
! implicit none
! integer :: unit=8, errorLevel
! open (UNIT=unit, status="scratch", iostat=errorLevel)
! write(*,*) errorLevel
! end program name
! 2021-04-13 21:58:06 5.6.3 5-26
! program name
! implicit none
! integer :: i, errorLevel
! real :: max, min, value
! character(len=20) :: maxRow, minRow, str
! open (unit=1, file='content', status='old', action='read', iostat=errorLevel)
! if ( errorLevel /= 0 ) stop "Open file fatal!"
! i=0
! do
! read(1, *, iostat=errorLevel) value
! if (errorLevel /= 0) exit
! i=i+1
! if (i == 1) then
! max=value
! min=value
! write(maxRow,6) i
! write(minRow,6) i
! 6 format (I2)
! else
! if (value > max) then
! max=value
! write(maxRow,6) i
! else if (value < min) then
! min=value
! write(minRow,6) i
! else if (abs(value-max) < 1 ) then
! write(str,4) i, maxRow
! maxRow=str
! else if (abs(value-min) < 1) then
! write(str,4) i, minRow
! minRow=str
! end if
! 4 format (I2, ',', A10)
! end if
! write(*,3) i, maxRow, max, minRow, min
! 3 format (1X, "第", I2, "次读取，文件在第", A14, "行取到最大值为："&
! &, F8.1, "，在第", A14, "行取到最小值为：", F8.1)
! end do
! write(*,2) maxRow, max, minRow, min
! 2 format (1X, "文件在第", A20, "行取到最大值为：", F8.1, "，在第", A20, "行取到最小值为：", F8.1)
! end program name
! 2021:04:14 16:33:55 5.6.3 5-27
! program name
! implicit none
! ! 以只读形式打开旧文件
! ! j=1
! ! DO
! ! 读取第j行字符并赋值给字符变量1（长度小于133）
! ! IF 错误等级<0 退出循环
! ! IF 错误等级>0 停止并报错
! ! DO i从1到字符变量1长度（除去空格）
! ! 抽取字符变量1第i个字符并赋值给一个长度为1的字符变量2
! ! IF 字符变量2不是逗号或者没有到达字符串末尾
! ! 跳过
! ! ELSE
! ! IF 到达了字符串末尾
! ! 结尾位数=i
! ! ELSE
! ! 结尾位数=i-1
! ! END IF
! ! sum=sum+实数1
! ! 计数1=计数1+1
! ! 字符变量3=空
! ! END IF
! ! END DO
! ! j=j+1
! ! END DO
! ! 平均值=sum/计数1
! integer :: i, j, k, errorLevel, valueStart, valueEnd
! real :: sum, value, average
! character(len=128) :: allValue, selectValue, readValue
! open (unit=1, file='content', status='old', action='read', iostat=errorLevel)
! if (errorLevel > 0) stop "读取文件出错"
! j=1
! k=0
! valueStart=1
! do
! read(1, '(A128)', iostat=errorLevel) allValue
! ! write(*,*) allValue
! if (errorLevel < 0) exit
! if (errorLevel > 0) stop "读取第j行出错"
! ! write(*,*) "读取第", j, "行"
! do i=1, len_trim(allValue), 1
! selectValue=allValue(i:i)
! ! write(*,*) "读取第", j, "行", "第", i, "列"
! if ( .not. ( trim(selectValue) == ',' .or. i == len_trim(allValue)) ) then
! ! ! readValue=trim(readValue) // trim(selectValue)
! ! ! write(*,*) '1', readValue
! ! else if ( trim(selectValue) == ' ') then
! ! ! write(*,*) '2', readValue
! cycle
! else
! if ( i == len_trim(allValue) ) then
! valueEnd=i
! else
! valueEnd=i-1
! end if
! readValue=allValue(valueStart:valueEnd)
! read(readValue, '(F5.1)', iostat=errorLevel) value
! if (errorLevel > 0) stop "第j行第i列附件的字符非合法数值，请检查"
! sum=sum+value
! k=k+1
! ! write(*,*) '3', readValue
! readValue=''
! valueStart=i+1
! end if
! end do
! j=j+1
! end do
! average=sum/k
! write(*,2) k, sum, average
! 2 format (1X, "共计算", I3, "个数值，总和为", F5.1, "，平均值大小为", F5.1)
! close (unit=1)
! end program name
! 2021:04:14 17:31:01 一个用于读取文件中所有数值的程序案例
! program name
! ! =============================================================
! ! 目的:
! ! 遍历一个文件内的所有变量(需要全部是实数或整数)
! ! 修订记录:
! ! 日期 编程者 改动描述
! ! =================== ============= ======================
! ! 2021-04-14 17:46:57 Sola 编写源代码并校正格式
! ! =============================================================
! implicit none
! ! 数据字典
! ! 结构需要
! integer :: i ! 控制读取字符所在位置
! integer :: errorLevel ! 检查错误信息
! integer :: valueStart ! 读取数值开始位置
! integer :: valueEnd ! 读取数值结束位置
! real :: value ! 读取的数值内容
! character(len=128) :: allValue ! 所在行字符内容
! character(len=128) :: selectValue ! 读取所在行第i个字符内容
! character(len=128) :: readValue ! 读取的字符内容
! ! 使用者自定义
! ! 声明常量
! REAL, PARAMETER :: PI=3.14159265 ! PI值
! REAL, PARAMETER :: e=2.718281828459 ! 自然对数
! ! 声明变量
! ! 变量初始化
! valueStart=1
! ! 打开文件
! open (unit=1, file='content', status='old', action='read', iostat=errorLevel)
! if (errorLevel > 0) stop "读取文件出错"
! ! 遍历数值
! do
! read(1, '(A128)', iostat=errorLevel) allValue ! 读取行内容
! if (errorLevel < 0) exit ! 如果到达最后一行, 退出循环
! if (errorLevel > 0) stop "读取行出错" ! 读取行内容出错, 退出程序
! ! 遍历行内字符
! do i=1, len_trim(allValue), 1
! selectValue=allValue(i:i) ! 读取第i个字符
! if ( .not. ( trim(selectValue) == ',' .or. i == len_trim(allValue)) ) then
! cycle ! 如果不是逗号或到达末尾, 则跳过此次循环
! else ! 如果是逗号或到达末尾
! if ( i == len_trim(allValue) ) then
! valueEnd=i ! 如果是到达末尾, 则数值结束位置为i
! else
! valueEnd=i-1 ! 如果并未达到末尾, 则数值结束位置为i-1
! end if
! readValue=allValue(valueStart:valueEnd) ! 读取当前数值
! read(readValue, '(F5.1)', iostat=errorLevel) value ! 将当前数值赋值给一个实数
! if (errorLevel > 0) stop "存在非合法数值，请检查" ! 赋值存在错误, 退出程序
! valueStart=i+1 ! 下一次数值的开始位置为i+1
! end if
! end do
! valueStart=1 ! 开始新一行, 并将数值开始位置重置
! end do
! close (unit=1) ! 关闭文件
! end program name
! 2021:04:14 17:56:25 5.6.3 5-28
! program name
! ! =============================================================
! ! 目的:
! ! 遍历一个文件内的所有变量(需要全部是实数或整数)
! ! 修订记录:
! ! 日期 编程者 改动描述
! ! =================== ============= ======================
! ! 2021-04-14 17:46:57 Sola 编写源代码并校正格式
! ! 2021:04:14 17:57:21 Sola 将弧度转化为角度
! ! =============================================================
! implicit none
! ! 数据字典
! ! 结构需要
! integer :: i ! 控制读取字符所在位置
! integer :: errorLevel ! 检查错误信息
! integer :: valueStart ! 读取数值开始位置
! integer :: valueEnd ! 读取数值结束位置
! real :: value ! 读取的数值内容
! character(len=128) :: allValue ! 所在行字符内容
! character(len=128) :: selectValue ! 读取所在行第i个字符内容
! character(len=128) :: readValue ! 读取的字符内容
! ! 使用者自定义
! ! 声明常量
! REAL, PARAMETER :: PI=3.14159265 ! PI值
! REAL, PARAMETER :: e=2.718281828459 ! 自然对数
! ! 声明变量
! real :: angle ! 角度
! real :: radian ! 弧度
! integer :: angleDegree ! 度
! integer :: angleMinute ! 分
! integer :: angleSecond ! 秒
! ! 变量初始化
! valueStart=1
! ! 打开文件
! open (unit=1, file='content', status='old', action='read', iostat=errorLevel)
! if (errorLevel > 0) stop "读取文件出错"
! ! 遍历数值
! do
! read(1, '(A128)', iostat=errorLevel) allValue ! 读取行内容
! if (errorLevel < 0) exit ! 如果到达最后一行, 退出循环
! if (errorLevel > 0) stop "读取行出错" ! 读取行内容出错, 退出程序
! ! 遍历行内字符
! do i=1, len_trim(allValue), 1
! selectValue=allValue(i:i) ! 读取第i个字符
! if ( .not. ( trim(selectValue) == ',' .or. i == len_trim(allValue)) ) then
! cycle ! 如果不是逗号或到达末尾, 则跳过此次循环
! else ! 如果是逗号或到达末尾
! if ( i == len_trim(allValue) ) then
! valueEnd=i ! 如果是到达末尾, 则数值结束位置为i
! else
! valueEnd=i-1 ! 如果并未达到末尾, 则数值结束位置为i-1
! end if
! readValue=allValue(valueStart:valueEnd) ! 读取当前数值
! read(readValue, '(F10.6)', iostat=errorLevel) radian ! 将当前数值赋值给一个实数
! if (errorLevel > 0) stop "存在非合法数值，请检查" ! 赋值存在错误, 退出程序
! angle=radian/PI*360
! angleDegree=int(angle)
! angleMinute=int((angle-real(angleDegree))*60)
! angleSecond=nint((angle-real(angleDegree)-real(angleMinute)/60)*60*60)
! write(*,2) radian, angleDegree, angleMinute, angleSecond
! 2 format (1X, F10.6, " 转换为角度为", I4, "度 ", I2, "分 ", I2, "秒")
! valueStart=i+1 ! 下一次数值的开始位置为i+1
! end if
! end do
! valueStart=1 ! 开始新一行, 并将数值开始位置重置
! end do
! close (unit=1) ! 关闭文件
! end program name
! 2021:04:14 20:02:17 标准程序格式
! program name
! ! =============================================================
! ! 目的:
! !
! ! 修订记录:
! ! 日期 编程者 改动描述
! ! =================== ============= ======================
! ! =============================================================
! implicit none
! ! 数据字典
! ! 声明常量
! REAL, PARAMETER :: PI=3.14159265 ! PI值
! REAL, PARAMETER :: e=2.718281828459 ! 自然对数
! ! 声明变量
! ! 变量初始化
! end program name
! 2021:04:14 20:02:17 5.6.3 5-31
! program name
! ! =============================================================
! ! 目的:
! ! 天线放大率程式
! ! 修订记录:
! ! 日期 编程者 改动描述
! ! =================== ============= ======================
! ! 2021:04:14 20:05:37 Sola 编写源代码
! ! =============================================================
! implicit none
! ! 数据字典
! ! 声明常量
! REAL, PARAMETER :: PI=3.14159265 ! PI值
! REAL, PARAMETER :: e=2.718281828459 ! 自然对数
! ! 声明变量
! real :: G ! 天线放大率
! integer :: angle ! 角度
! real :: radian ! 弧度
! ! 变量初始化
! g=0
! radian=0
! angle=0
! write(*,1)
! 1 format (1X, "Form. 天线放大率与角度"/&
! &1X, T4, "radian", T15, "天线放大率"/&
! &1X, T2, "==========", T15, "==========")
! do angle=0,90,1
! radian=angle/360.*PI
! if ( (radian-0) < 0.01 ) then
! g=abs(1)
! else
! g=abs(sin(6*radian)/(6*radian))
! end if
! write(*,2) radian, G
! 2 format (1X, T3, F8.6, T16, F8.6)
! end do
! end program name
! 2021:04:14 22:45:42 5.6.3 5-32
! program name
! ! =============================================================
! ! 目的: 计算发动机输出功率
! !
! ! 修订记录:
! ! 日期 编程者 改动描述
! ! =================== ============= ======================
! ! 2021:04:14 22:46:13 Sola 编写源代码
! ! =============================================================
! implicit none
! ! 数据字典
! ! 声明常量
! REAL, PARAMETER :: PI=3.14159265 ! PI值
! REAL, PARAMETER :: e=2.718281828459 ! 自然对数
! ! 声明变量
! real :: p ! 功率 瓦特
! real :: t_ind ! 转矩
! real :: w_m ! 角速度 rad/s
! integer :: t ! 时间 1/4s
! ! 变量初始化
! write(*,1)
! 1 format (1X, "Form. 发动机随时间变化输出功率变化情况"/&
! &1X, T4, "Time(s)", T20, "P(w)"/&
! &1X, T1, "===========", T15, "===============")
! do t=0,40,1
! t_ind=10*e**(-0.25*0.25*t)
! w_m=377*(1-e**(-0.25*0.25*t))
! p=t_ind*w_m
! write(*,2) t*0.25, p
! 2 format (1X, T5, F5.2, T17, F10.5)
! end do
! end program name
! 2021:04:14 23:00:23 5.6.3 5-33 5-34
! program name
! ! =============================================================
! ! 目的: 计算轨道
! !
! ! 修订记录:
! ! 日期 编程者 改动描述
! ! =================== ============= ======================
! ! 2021:04:14 23:00:53 Sola 编写源代码
! ! 2021:04:14 23:50:44 Sola 增加新题目的功能
! ! =============================================================
! implicit none
! ! 数据字典
! ! 声明常量
! REAL, PARAMETER :: PI=3.14159265 ! PI值
! REAL, PARAMETER :: e=2.718281828459 ! 自然对数
! REAL, PARAMETER :: r_earth=6.371E3 ! 地球半径
! ! 声明变量
! real :: r ! 卫星距离地球中心的距离 km
! real :: p ! 确定轨道大小的参数
! real :: x ! 轨道离心率的参数
! real :: distanceMax ! 轨道最远距离 km
! real :: distanceMin ! 轨道最近距离 km
! integer :: errorLevel ! 错误参数
! integer :: i ! 循环用变量
! ! 变量初始化
! p=10000
! write(*,1)
! 1 format (1X, "Form. 卫星轨道信息一览表"/&
! &1X, " ε min(km) max(km)"/&
! &1X, "===== ========= =========")
! ! open (unit=2, status='scratch', iostat=errorLevel)
! ! write(2,'("0"/"0.25"/"0.5")')
! ! rewind (unit=2)
! ! do i = 1,3
! ! read(2,*) x
! ! distanceMax=p/(1-x)
! ! distanceMin=p/(1+x)
! ! write(*,2) x, distanceMin, distanceMax
! ! 2 format (1X, T2, F5.3, T9, F7.1, T19, F7.1)
! ! end do
! do i=0,10,1
! x=i*0.05
! distanceMax=p/(1-x)-r_earth
! distanceMin=p/(1+x)-r_earth
! write(*,2) x, distanceMin, distanceMax
! 2 format (1X, T2, F5.3, T9, F7.1, T19, F7.1)
! end do
! end program name
! 2021:04:15 00:39:05 5.6.3 5-35
! program name
! ! =============================================================
! ! 目的: 动态修改格式描述符
! !
! ! 修订记录:
! ! 日期 编程者 改动描述
! ! =================== ============= ======================
! ! 2021:04:15 00:39:50 Sola 编写源代码
! ! =============================================================
! implicit none
! ! 数据字典
! ! 声明常量
! REAL, PARAMETER :: PI=3.14159265 ! PI值
! REAL, PARAMETER :: e=2.718281828459 ! 自然对数
! ! 声明变量
! integer :: errorLevel ! 错误代码
! real :: x1, x2, x3, x4 ! 用于保存读取到的变量
! integer :: i ! 循环参数
! character(len=8) :: varType ! 输出格式
! ! 变量初始化
! open (unit=1, status="scratch", iostat=errorLevel)
! if (errorLevel /= 0) stop "Open file error!"
! write(1,1)
! 1 format("0.00012, -250., 6.02E23, -0.012"/&
! &"0.0, 12345.6, 1.6E-19, -1000.")
! rewind(unit=1)
! do i=1,2
! read(1,*) x1, x2, x3, x4
! if ( x1 == 0 .or. ( 0.01 <= abs(x1) .and. 1000.0 >= abs(x1) ) ) then
! varType='(F14.6)'
! else
! varType='(ES14.6)'
! end if
! write(*,trim(varType)) x1
! if ( x2 == 0 .or. ( 0.01 <= abs(x2) .and. 1000.0 >= abs(x2) ) ) then
! varType='(F14.6)'
! else
! varType='(ES14.6)'
! end if
! write(*,trim(varType)) x2
! if ( x3 == 0 .or. ( 0.01 <= abs(x3) .and. 1000.0 >= abs(x3) ) ) then
! varType='(F14.6)'
! else
! varType='(ES14.6)'
! end if
! write(*,trim(varType)) x3
! if ( x4 == 0 .or. ( 0.01 <= abs(x4) .and. 1000.0 >= abs(x4) ) ) then
! varType='(F14.6)'
! else
! varType='(ES14.6)'
! end if
! write(*,trim(varType)) x4
! end do
! end program name
! 2021-04-15 01:14:04 5.6.3 5-36
! program name
! ! =============================================================
! ! 目的:
! ! 最小二乘法回归，并计算相关系数，如果相关系数小于0.3，发出警告
! ! 修订记录:
! ! 日期 编程者 改动描述
! ! =================== ============= ======================
! ! 2021-04-15 01:12:35 Sola 编写源代码
! ! =============================================================
! implicit none
! ! 数据字典
! ! 声明常量
! REAL, PARAMETER :: PI=3.14159265 ! PI值
! REAL, PARAMETER :: e=2.718281828459 ! 自然对数
! ! 声明变量
! real :: x, y ! 坐标xy
! integer :: errorLevel ! 错误代码
! real :: m, b ! 拟合斜率和截距
! real :: x_bar, y_bar ! xy均值
! real :: r ! 相关系数
! real :: x_sum, y_sum ! xy总和
! real :: x2_sum, xy_sum, y2_sum ! 各种参数
! integer :: i ! 循环变量
! ! 变量初始化
! x_sum=0
! y_sum=0
! x2_sum=0
! y2_sum=0
! xy_sum=0
! i=0
! ! 输入数据
! open (unit=1, status='scratch', iostat=errorLevel)
! if (errorLevel /= 0) stop "Error!"
! write(1,1)
! 1 format("1.1, 1.01"/&
! &"2.2, 2.30"/&
! &"3.3, 3.05"/&
! &"4.4, 4.28"/&
! &"5.5, 5.75"/&
! &"6.6, 6.48"/&
! &"7.7, 7.84")
! rewind(unit=1)
! ! 计算参数
! do
! read(1,'(F10.4,F10.4)', iostat=errorLevel) x, y
! if (errorLevel<0) exit
! if (errorLevel>0) stop "Warning: Error!"
! x_sum=x_sum+x
! y_sum=y_sum+y
! x2_sum=x2_sum+x**2
! y2_sum=y2_sum+y**2
! xy_sum=xy_sum+x*y
! i=i+1
! end do
! x_bar=x_sum/real(i)
! y_bar=y_sum/real(i)
! m=(xy_sum-x_sum*y_bar)/(x2_sum-x_sum*x_bar)
! b=y_bar-m*x_bar
! r=(real(i)*xy_sum-x_sum*y_sum)/sqrt((real(i)*x2_sum-x_sum**2)*(real(i)*y2_sum-y_sum**2))
! ! 输出结果
! if (abs(r)<0.3) write(*,*) 'Warning: r is too low!'
! write(*,2) m, b, r
! 2 format(1X, "方程拟合的结果为: y = ", F5.2, " x + ( ", F5.2, " ) , 相关系数为: ", F5.3)
! end program name
! 2021-04-15 01:14:04 5.6.3 5-37
! program name
! ! =============================================================
! ! 目的: 计算飞行器旋转半径
! !
! ! 修订记录:
! ! 日期 编程者 改动描述
! ! =================== ============= ======================
! ! 2021-04-15 01:14:04 Sola 编写源代码
! ! =============================================================
! implicit none
! ! 数据字典
! ! 声明常量
! REAL, PARAMETER :: PI=3.14159265 ! PI值
! REAL, PARAMETER :: e=2.718281828459 ! 自然对数
! REAL, PARAMETER :: g=9.8 ! 重力加速度, g/s^2
! REAL, PARAMETER :: mach=340 ! 马赫, 声速, m/s
! ! 声明变量
! real :: a
! real :: v
! real :: r
! integer :: i
! ! 变量初始化
! i=0
! ! 输出数据
! write(*,1)
! 1 format(1X, "Form1. 飞行器转弯半径与飞行器速度关系表"/&
! &1X, " v(m/s) r(m) "/&
! &1X, "========== ======================")
! do i=5,20,1
! v=real(i)/10.*mach
! a=2*g
! r=v**2/a
! write(*,2) v, r
! 2 format(1X, T3, F8.1, T17, F17.3)
! end do
! write(*,3)
! 3 format(1X, "========== ======================"/&
! &/&
! &1X, "Form2. 飞行器转弯半径与向心加速度关系表"/&
! &1X, " a(m/s^2) r(m) "/&
! &1X, "========== ======================")
! do i=4,16,1
! a=real(i)*0.5*g
! v=0.85*mach
! r=v**2/a
! write(*,2) a, r
! end do
! write(*,4)
! 4 format(1X, "========== ======================")
! end program name
! ! 2021-04-15 01:14:04 测试
! program name
! implicit none
! real :: error(-3:0)
! error(-3)=0.00012
! error(-2)=0.0152
! error(-1)=0.0
! write(*,500) error
! 500 format(T6,"error = ",/,(3X,F6.4))
! end program name
! 2021-04-15 01:14:04 排序算法
! program name
! ! =============================================================
! ! 目的: 对输入数据进行排序
! ! 程序结构:
! ! 打开文件
! ! DO
! ! 读入数据赋值给数组对应位置, 并获取错误代码
! ! IF 错误代码 < 0 EXIT
! ! 记录数+1
! ! END DO
! ! DO i从1到记录数-1
! ! 最小值=数组(i)
! ! 最小值位置=i
! ! DO j从i+1到记录数
! ! IF 数组(j)<最小值 THEN
! ! 最小值=数组(j)
! ! 最小值位置=j
! ! END IF
! ! END DO
! ! IF 最小值位置/=i THEN
! ! 数组(最小值位置)=数组(i)
! ! 数组(i)=最小值
! ! END IF
! ! END DO
! ! 输出数组
! ! 修订记录:
! ! 日期 编程者 改动描述
! ! =================== ============= ======================
! ! 2021-04-15 01:14:04 Sola 编写源代码
! ! 2021-04-15 01:14:04 Sola 防止数据溢出
! ! 2021-04-15 09:48:33 Sola 避免错误数据
! ! =============================================================
! implicit none
! ! 数据字典
! ! 声明常量
! REAL, PARAMETER :: PI=3.14159265 ! PI值
! REAL, PARAMETER :: e=2.718281828459 ! 自然对数
! ! 声明变量
! integer, parameter :: arrayLength = 20 ! 数组长度
! real, dimension(arrayLength) :: array ! 定义数组
! integer :: errorLevel ! 错误代码
! integer :: i, j, k ! 循环参数
! integer :: minLocate ! 最小值位置
! real :: min ! 最小值
! logical :: excess ! 数据溢出判断参数
! real :: temp ! 储存临时数值
! ! 变量初始化
! k=0
! i=0
! excess=.FALSE.
! open(unit=1, status='scratch')
! write(1,1)
! 1 format(1X, "123.5"/&
! &1X, "563"/&
! &1X, "586.3"/&
! &1X, "12"/&
! &1X, "0"/&
! &1X, "-l99"/&
! &1X, "67"/&
! &1X, "24"/&
! &1X, "51"/&
! &1X, "999"/&
! &1X, "30"/&
! &1X, "-1a11"/&
! &1X, "666"/&
! &1X, "787"/&
! &1X, "720"/&
! &1X, "98u0"/&
! &1X, "985")
! rewind(unit=1)
! do
! read(1,*,iostat=errorLevel) temp
! if (errorLevel < 0) exit
! i=i+1
! if (errorLevel > 0) then
! write(*,3) i
! 3 format(1X, "程序在输入数据的第", I3, "行读取到非法输入，&
! &请检查数据源，已跳过该数据")
! ! 3 format(1X, I3)
! cycle
! end if
! if (k < arrayLength) then
! k=k+1
! array(k)=temp
! else
! excess=.TRUE.
! exit ! 从程序一般只有一个出口来看，这边最好不要有exit，，，
! end if
! end do
! if ( .not. excess ) then
! do i=1,k-1
! minLocate=i
! do j=i+1,k
! if (array(j) < array(minLocate)) then
! minLocate=j
! end if
! end do
! if (minLocate /= i) then
! min=array(minLocate)
! array(minLocate)=array(i)
! array(i)=min
! end if
! end do
! write(*,2) array
! 2 format(10(F7.2, 1X))
! else
! write(*,*) '输入参数过多！'
! end if
! close(unit=1)
! end program name

350
第6章习题.f90 Normal file
View File

@ -0,0 +1,350 @@
! 2021-04-15 01:14:04 6.7.3 6-5(c)
! program name
! !
! ! 目的:
! ! 测试数组之间比较会输出什么，最后确认会一个一个比较，然后输出一个数组
! !
! ! 修订记录:
! ! 日期 编程者 改动描述
! ! =================== ============= ======================
! ! 2021-04-15 01:14:04 Sola 编写源代码
! !
! ! 程序结构:
! !
! implicit none
! ! 数据字典
! ! 声明常量
! REAL, PARAMETER :: PI=3.14159265 ! PI值
! REAL, PARAMETER :: e=2.718281828459 ! 自然对数
! INTEGER, PARAMETER :: arrayLength=6 ! 数组基准长度
! ! 声明变量
! integer, dimension(arrayLength) :: a, b ! 使用的数组
! ! 变量初始化
! a = (/1,-3,0,-5,-9,3/)
! b = (/-6,6,0,5,2,-1/)
! write(*,*) a > b
! ! 数据输入
! ! 运算过程
! ! 结果输出
! end program name
! 2021-04-15 01:14:04 6.7.3 6-10 6-11
! program name
! !
! ! 目的:
! ! 极坐标转换为直角坐标; 直角坐标转化为极坐标
! !
! ! 修订记录:
! ! 日期 编程者 改动描述
! ! =================== ============= ======================
! ! 2021-04-15 01:14:04 Sola 编写源代码
! ! 2021-04-15 01:14:04 Sola 增加反向转换功能
! !
! ! 程序结构:
! !
! implicit none
! ! 数据字典
! ! 声明常量
! REAL, PARAMETER :: PI=3.14159265 ! PI值
! REAL, PARAMETER :: e=2.718281828459 ! 自然对数
! INTEGER, PARAMETER :: arrayLength=2 ! 数组基准长度
! ! 声明变量
! integer :: errorLevel
! real, dimension(arrayLength) :: polar, reat ! 极坐标数组、直角坐标数组
! ! 变量初始化
! open(unit=1, status='scratch')
! write(1,1)
! 1 format(1X, "5, -36.87"/&
! &1X, "10, 45"/&
! &1X, "25, 233.13")
! rewind(unit=1)
! ! 数据输入
! write(*,3)
! 3 format(1X, " Table of 6-10 "/&
! &1X, " x y "/&
! &1X, "======= =======")
! do
! read(1,*,iostat=errorLevel) polar(1), polar(2)
! if (errorLevel/=0) exit
! reat(1)=polar(1)*cos(polar(2)/360.*PI)
! reat(2)=polar(1)*sin(polar(2)/360.*PI)
! write(*,2) reat(1), reat(2)
! 2 format(1X, T2, F6.2, T10, F6.2)
! end do
! rewind(unit=1)
! write(1,4)
! 4 format(1X, "3, -4"/&
! &1X, "5, 5"/&
! &1X, "-5, 12")
! rewind(unit=1)
! write(*,5)
! 5 format(1X/&
! &1X, " Table of 6-11 "/&
! &1X, " V θ "/&
! &1X, "======= =======")
! do
! read(1,*,iostat=errorLevel) reat(1), reat(2)
! if (errorLevel/=0) exit
! polar(1)=sqrt(reat(1)**2+reat(2)**2)
! polar(2)=atan(reat(2)/reat(1))
! write(*,2) polar(1), polar(2)
! ! write(*,*) atan2(reat(2),reat(1))
! end do
! ! 运算过程
! ! 结果输出
! end program name
! 2021-04-15 01:14:04 6.7.3 6-12
! program name
! !
! ! 目的:
! ! 计算一组数据中正数、负数和0的个数
! !
! ! 修订记录:
! ! 日期 编程者 改动描述
! ! =================== ============= ======================
! ! 2021-04-15 01:14:04 Sola 编写源代码
! !
! ! 程序结构:
! !
! implicit none
! ! 数据字典
! ! 声明常量
! REAL, PARAMETER :: PI=3.14159265 ! PI值
! REAL, PARAMETER :: e=2.718281828459 ! 自然对数
! INTEGER, PARAMETER :: arrayLength=20 ! 数组基准长度
! ! 声明变量
! real, dimension(-50:50) :: values
! integer :: positiveSum, zeroSum, negativeSum ! 正数、零、负数的个数
! integer :: i ! 循环参数
! ! 变量初始化
! positiveSum=0
! zeroSum=0
! negativeSum=0
! values=[(i, i=-50,50)]
! do i=-50,50
! if (values(i) > 0) then
! positiveSum=positiveSum+1
! else if (values(i) < 0) then
! negativeSum=negativeSum+1
! else
! zeroSum=zeroSum+1
! end if
! end do
! write(*,1) positiveSum, negativeSum, zeroSum
! 1 format(1X, "统计结果：输入数组中共有正数", I2, "个，负数", I2, "个，零", I2, "个")
! ! 数据输入
! ! 运算过程
! ! 结果输出
! end program name
! 2021-04-15 01:14:04 6.7.3 6-14
! program name
! !
! ! 目的:
! ! 6-14 计算点积
! ! 6-15 作用于物体的功率
! !
! ! 修订记录:
! ! 日期 编程者 改动描述
! ! =================== ============= ======================
! ! 2021-04-15 01:14:04 Sola 编写源代码
! ! 2021-04-15 01:14:04 Sola 计算作用于物体的功率
! !
! ! 程序结构:
! !
! implicit none
! ! 数据字典
! ! 声明常量
! REAL, PARAMETER :: PI=3.14159265 ! PI值
! REAL, PARAMETER :: e=2.718281828459 ! 自然对数
! INTEGER, PARAMETER :: arrayLength=3 ! 数组基准长度
! ! 声明变量
! real, dimension(arrayLength) :: array1, array2 ! 点积的两个矢量
! real, dimension(arrayLength) :: arrayResult ! 点积结果矢量
! real :: result ! 点积结果
! integer :: i ! 循环参数
! ! 变量初始化
! array1 = [4, 3, -2]
! array2 = [4, -2, 1]
! result=0
! arrayResult = array1*array2
! do i=1,arrayLength
! result=result+arrayResult(i)
! end do
! write(*,1) result
! ! 1 format(1X, "两矢量的点积结果为 ", F6.2)
! 1 format(1X, "作用于物体的功率为 ", F6.2)
! ! 数据输入
! ! 运算过程
! ! 结果输出
! end program name
! program name
! !
! ! 目的:
! ! 6.7.3 6-16 计算差积
! ! 6.7.3 6-17 计算绕轨道运行物体的速度
! !
! ! 修订记录:
! ! 日期 编程者 改动描述
! ! =================== ============= ======================
! ! 2021-04-15 01:14:04 Sola 编写源代码
! ! 2021-04-15 09:28:26 Sola 计算绕轨道运行物体的速度
! !
! ! 程序结构:
! !
! implicit none
! ! 数据字典
! ! 声明常量
! REAL, PARAMETER :: PI=3.14159265 ! PI值
! REAL, PARAMETER :: e=2.718281828459 ! 自然对数
! INTEGER, PARAMETER :: arrayLength=3 ! 数组基准长度
! ! 声明变量
! real, dimension(arrayLength) :: array1 ! 矢量1
! real, dimension(arrayLength) :: array2 ! 矢量2
! real, dimension(arrayLength) :: arrayResult ! 结果矢量
! real :: v ! 运行速度
! ! 变量初始化
! array1 = [5,-3,2]
! array2 = [2,3,4]
! arrayResult = array1((/2,3,1/))*array2((/3,1,2/))-array2((/2,3,1/))*array1((/3,1,2/))
! write(*,1) arrayResult
! 1 format(1X, "矢量V1与矢量V2的差积为：", 3(1X, F6.2))
! array1 = [300000,400000,50000]
! array2 = [-6E-3,2E-3,9E-4]
! arrayResult = array1((/2,3,1/))*array2((/3,1,2/))-array2((/2,3,1/))*array1((/3,1,2/))
! v=(arrayResult(1)**2+arrayResult(2)**2+arrayResult(3)**2)**1./3.
! write(*,2) v
! 2 format(1X, "绕轨道运行物体的速度为：", F11.2, " m/s")
! ! 数据输入
! ! 运算过程
! ! 结果输出
! end program name
! program name
! !
! ! 目的:
! ! 集合的交集与并集运算
! !
! ! 修订记录:
! ! 日期 编程者 改动描述
! ! =================== ============= ======================
! ! 2021-04-15 10:05:11 Sola 编写源代码
! !
! ! 程序结构:
! !
! implicit none
! ! 数据字典
! ! 声明常量
! REAL, PARAMETER :: PI=3.14159265 ! PI值
! REAL, PARAMETER :: e=2.718281828459 ! 自然对数
! INTEGER, PARAMETER :: arrayLength=20 ! 数组基准长度
! ! 声明变量
! character(len=8), dimension(arrayLength) :: aggregateA! 集合A
! character(len=8), dimension(arrayLength) :: aggregateB! 集合B
! character(len=8), dimension(arrayLength) :: aggregateC! 集合C，交集
! character(len=8), dimension(arrayLength) :: aggregateD! 集合D，并集
! integer :: i, j, k ! 循环参数
! integer :: errorLevel ! 错误代码
! character(len=40) :: temp ! 临时保存
! ! 变量初始化
! i=0
! j=0
! k=0
! aggregateA='NaN'
! aggregateB='NaN'
! open(unit=1, status='scratch')
! open(unit=2, status='scratch')
! write(1,*) ' 0,1,-3,5,-11,6,8,11,17,15'
! write(2,*) ' 0,-1,3,6,-6,16,5,12,21'
! rewind(unit=1)
! rewind(unit=2)
! read(1,*,iostat=errorLevel) aggregateA
! read(2,*,iostat=errorLevel) aggregateB
! do i=1,arrayLength
! if (aggregateA(i) /= 'NaN') then
! if (any(aggregateA(i)==aggregateB)) then
! k=k+1
! aggregateC(k)=aggregateA(i)
! end if
! else
! exit
! end if
! end do
! write(*,'(1X, "集合A与集合B的交集为：", 20(A3))') aggregateC(1:k)
! k=0
! do i=1,arrayLength
! if (aggregateA(i) /= 'NaN') then
! if (any(aggregateA(i) /= aggregateD)) then
! k=k+1
! aggregateD(k)=aggregateA(i)
! end if
! else
! exit
! end if
! end do
! do i=1,arrayLength
! if (aggregateB(i) /= 'NaN') then
! if (.not. any(aggregateB(i)==aggregateD(1:k))) then
! k=k+1
! aggregateD(k)=aggregateB(i)
! end if
! else
! exit
! end if
! end do
! write(*,'(1X, "集合A与集合B的并集为：", 20(A4))') aggregateD(1:k)
! ! 数据输入
! ! 运算过程
! ! 结果输出
! end program name
! program name
! !
! ! 目的:
! ! 计算三维空间中两点间距离
! !
! ! 修订记录:
! ! 日期 编程者 改动描述
! ! =================== ============= ======================
! ! 2021-04-15 11:08:39 Sola 编写源代码
! !
! ! 程序结构:
! !
! implicit none
! ! 数据字典
! ! 声明常量
! REAL, PARAMETER :: PI=3.14159265 ! PI值
! REAL, PARAMETER :: e=2.718281828459 ! 自然对数
! INTEGER, PARAMETER :: arrayLength=3 ! 数组基准长度
! ! 声明变量
! real, dimension(arrayLength) :: pointA ! 点A坐标
! real, dimension(arrayLength) :: pointB ! 点B坐标
! real, dimension(arrayLength) :: arrayTemp ! 临时数组
! real :: distance ! 两点间距离
! real :: temp ! 临时变量
! integer :: i ! 循环参数
! ! 变量初始化
! pointA=[-1,4,6]
! pointB=[1,5,-2]
! temp=0
! arrayTemp=(pointA-pointB)**2
! do i=1,arrayLength
! temp=temp+arrayTemp(i)
! end do
! distance=sqrt(temp)
! write(*,1) distance
! 1 format(1X, "两点间距离为：", F6.2)
! ! 数据输入
! ! 运算过程
! ! 结果输出
! end program name

932
第7章习题.f90 Normal file
View File

@ -0,0 +1,932 @@
! ==============================================================================
! 通过 gfortran ./test.f90 -o ./run && ./run 运行
! 程序名：
! 习题
! 目的:
!
! 修订记录:
! 日期 编程者 改动描述
! =================== ============= =====================================
! 2021-04-16 19:59:35 Sola 7.3 1~4 编写源代码
! 2021-04-16 20:30:45 Sola 修改7.3 4的代码（直接比较赋值不就好了）
! 2021-04-16 21:28:46 Sola 测试下external语句的使用
! 2021-04-17 16:10:12 Sola 习题7-9b
! 2021-04-17 16:22:35 Sola 习题7-10
! 2021-04-17 16:51:53 Sola 习题7-14 随机数程序
! 2021-04-17 16:57:46 Sola 习题7-15 掷色子程序
! 2021-04-17 17:39:09 Sola 习题7-16 泊松分布
! 2021-04-17 18:01:03 Sola 习题7-18 计算双曲正弦值、余弦值、正切值
! 2021-04-17 18:49:40 Sola 习题7-19 向量叉积（3维向量）
! 2021-04-17 20:16:43 Sola 习题7-20 数组排序
! 2021-04-17 21:11:06 Sola 习题7-21 函数的最大值和最小值
! 2021-04-17 21:45:25 Sola 习题7-22 代入函数计算
! 2021-04-17 21:54:08 Sola 习题7-23 微分函数
! 2021-04-18 00:54:09 Sola 习题7-24 噪声值微分
! 2021-04-18 11:50:23 Sola 习题7-25 二进制运算(加减及进制转换)
! 2021-04-25 15:23:51 Sola 习题7-26 线性最小二乘拟合
! 2021-04-25 16:00:28 Sola 习题7-27 最小二乘拟合的相关系数
! 2021-04-25 16:07:05 Sola 习题7-28 生日问题
! 2021-04-25 17:42:55 Sola 习题7-29 经时计算
! 2021-04-25 21:04:53 Sola 习题7-30 使用计时器子程序
! 2021-04-25 21:49:32 Sola 习题7-31 估算无限序列
! 2021-04-25 22:45:24 Sola 习题7-32 使用子程序计算随机分布
! 2021-04-26 00:20:22 Sola 习题7-33 高斯(正态)分布
! 2021-04-26 01:43:23 Sola 习题7-34 引力
! 2021-04-26 01:54:59 Sola 习题7-35 堆排序, 了解有这么个玩意就成
! 程序结构:
!
! ==============================================================================
! 模块：
module MouName
implicit none
! 数据字典
! 声明常数
REAL, PARAMETER :: PI=3.14159265 ! PI值
REAL, PARAMETER :: e=2.718281828459 ! 自然对数
INTEGER, PARAMETER :: arrayLength=20 ! 数组基准长度
REAL, PARAMETER :: criticalZero=1.0E-30 ! 0的临界值
! 声明变量
! real function Function1(x)
! real function Function2(x)
! integer function Function3(n)
! logical function Function4(x,y)
real :: x, y
integer :: n
! 创建显式接口
contains
! 习题7.3 2
real function Function2(x)
implicit none
real, intent(in) :: x
Function2=(exp(x)-exp(-x))/(exp(x)+exp(-x))
end function Function2
! 习题7.3 3 计算阶乘
integer function Function3(n)
implicit none
! external :: Function3
integer, intent(in) :: n
integer :: i
Function3 = 1
do i=2,n
Function3 = Function3 * i
end do
end function Function3
! 习题7.3 4
logical function Function4(x, y)
implicit none
real, intent(in) :: x, y
! if ( x**2+y**2 > 1.0 ) then
! Function4 = .TRUE.
! else
! Function4 = .FALSE.
! end if
Function4 = x**2+y**2 > 1.0
end function Function4
! 测试用
subroutine Subroutine1(fun, x, result, errorLevel)
implicit none
real :: fun
! external :: fun
real, intent(in) :: x
real, intent(out) :: result
integer, intent(out) :: errorLevel
result = fun(x)
end subroutine Subroutine1
! 习题7-9 b
subroutine max_char(string, big)
implicit none
character(len=10), intent(in) :: string
character, intent(out) :: big
integer :: i
big = string(1:1)
do i = 2,10
if ( string(i:i) > big ) then
big = string(i:i)
end if
end do
end subroutine max_char
! 叉积运算函数
function VectorProduct_3(vectorX, vectorY)
implicit none
real, dimension(3) :: VectorProduct_3
real, dimension(3), intent(in) :: vectorX, vectorY
VectorProduct_3 = vectorX((/2,3,1/))*vectorY((/3,1,2/))-vectorY((/2,3,1/))*vectorX((/3,1,2/))
end function VectorProduct_3
! function VectorProduct_3(vectorX, vectorY)
! implicit none
! real, dimension(3) :: VectorProduct_3
! real, dimension(3), intent(in) :: vectorX, vectorY
! ! write(*,*) vectorX, vectorY
! ! VectorProduct_3=[1,1,1]
! VectorProduct_3 = vectorX((/2,3,1/))*vectorY((/3,1,2/))-vectorY((/2,3,1/))*vectorX((/3,1,2/))
! end function VectorProduct_3
! 随机数子程序
! subroutine random(ran, iseed)
! implicit none
! real, intent(in) :: iseed
! real, intent(out) :: ran
! real :: n
! if ( iseed = '' ) then
! iseed = 12345
! end if
! n = abs(iseed)
! n = mod(8121*n+28411,134456)
! ran = real(n)/134456
! end subroutine random
! 字符串二进制加法运算
function BinaryAddition(strInput1, strInput2, strLength)
implicit none
integer, intent(in) :: strLength
character(len=strLength), intent(in) :: strInput1, strInput2
character(len=strLength) :: BinaryAddition
integer :: i, j
j = 0
do i = 1, strLength
if ( (strInput1(i:i) /= '0' .and. strInput1(i:i) /= '1') &
&.or. (strInput2(i:i) /= '0' .and. strInput2(i:i) /= '1') ) stop "输入数据包含非法字符"
end do
do i = strLength, 1, -1
select case ( iachar(strInput1(i:i)) + iachar(strInput2(i:i)) + j )
case ( 96:96 )
BinaryAddition(i:i) = '0' ! 0+0
j = 0
case ( 97:97 )
BinaryAddition(i:i) = '1' ! 0+1, 1+0, 0+0+1
j = 0
case ( 98:98 )
BinaryAddition(i:i) = '0' ! 1+1, 1+0+1, 0+1+1
j = 1
case ( 99:99 )
BinaryAddition(i:i) = '1' ! 1+1+1
j = 1
end select
end do
end function BinaryAddition
! 字符串二进制减法运算
function BinarySubtraction(strInput1, strInput2, strLength)
implicit none
integer, intent(in) :: strLength
character(len=strLength), intent(in) :: strInput1, strInput2
character(len=strLength) :: BinarySubtraction
integer :: i, j
j = 0
do i = 1, strLength
if ( (strInput1(i:i) /= '0' .and. strInput1(i:i) /= '1') &
&.or. (strInput2(i:i) /= '0' .and. strInput2(i:i) /= '1') ) stop "输入数据包含非法字符"
end do
do i = strLength, 1, -1
select case ( iachar(strInput1(i:i)) - iachar(strInput2(i:i)) + j )
case ( 0:0 )
BinarySubtraction(i:i) = '0' ! 0-0, 1-1, 1-0-1
j = 0
case ( 1:1 )
BinarySubtraction(i:i) = '1' ! 1-0
j = 0
case ( -1:-1 )
BinarySubtraction(i:i) = '1' ! 0-1, 0-0-1, 1-1-1
j = -1
case ( -2:-2 )
BinarySubtraction(i:i) = '0' ! 0-1-1
j = -1
end select
end do
end function BinarySubtraction
! 字符串二进制转整型十进制
integer function BaseConversion_2To10(Base2Str, strLength)
implicit none
integer, intent(in) :: strLength
character(len=strLength), intent(in) :: Base2Str
integer :: i, value
BaseConversion_2To10 = 0
do i = 2, strLength
read(Base2Str(i:i),*) value
BaseConversion_2To10 = BaseConversion_2To10 + value*2**(strLength-i)
end do
if ( Base2Str(1:1) == '1' ) BaseConversion_2To10 = BaseConversion_2To10 - 2**(strLength-1)
end function BaseConversion_2To10
! 整数型十进制转字符串二进制
function BaseConversion_10To2(Base10Int, strLength)
implicit none
integer, intent(in) :: Base10Int, strLength
character(len=strLength) :: BaseConversion_10To2, oneBase2
integer :: i, value
value = abs(Base10Int)
if ( value > 2**(strLength-1) ) stop "数值越界"
do i = strLength, 1, -1
if ( mod(value, 2) == 1 ) then
BaseConversion_10To2(i:i) = '1'
else
BaseConversion_10To2(i:i) = '0'
end if
value = value / 2
end do
if ( Base10Int < 0 ) then
do i = 1, strLength
if ( BaseConversion_10To2(i:i) == '1' ) then
BaseConversion_10To2(i:i) = '0'
else
BaseConversion_10To2(i:i) = '1'
end if
end do
do i = 1, strLength-1
oneBase2(i:i) = '0'
end do
oneBase2(strLength:strLength) = '1'
BaseConversion_10To2 = BinaryAddition(BaseConversion_10To2, oneBase2, strLength)
end if
end function BaseConversion_10To2
end module MouName
! ==============================================================================
! 主程序：
program ProName
use MouName
implicit none
! 数据字典
! 声明常量
! 声明变量
! real, external :: Function1
real :: Function1
real :: result
integer :: errorLevel
! 变量初始化
! write(*,*) '1. 输入x=2，则f(x)= ', Function1(2.)
! write(*,*) '2. 输入x=3，则tanh(x)= ', Function2(3.)
! write(*,*) '3. 11的阶乘为 ', Function3(11)
! write(*,*) '4. 输入x=3，y=4，则其平方和是否大于1.0？结果为：', Function4(3., 4.)
! call Subroutine1(Function1, 3., result, errorLevel)
! write(*,*) result
! call Exercises7_9
! call Exercises7_10
! call Exercises7_15
! call Exercises7_16
! call Exercises7_18
! call Exercises7_19
! call Exercises7_20
! call Exercises7_21
! call Exercises7_23
! call Exercises7_25
! call Exercises7_26
! call Exercises7_28
! call Exercises7_29
! call Exercises7_31
! call Exercises7_32
! call Exercises7_33
! call Exercises7_34
end program ProName
! ==============================================================================
! 子程序
! subroutine SubName(varName1,varName2)
! use MouName
! implicit none
! Type, intent(inout) :: varName
! end subroutine SubName
! ==============================================================================
! 函数
! function FunName(varName1,varName2)
! use MouName
! implicit none
! end function FunName
! ==============================================================================
real function Function1(x)
implicit none
! 数据字典
real, intent(in) :: x
Function1 = (x-1)/(x+1)
end function Function1
! 习题7-9 b 最终结果会出现警告，但可以运行，结果也是正确的，不知道是不是巧合
subroutine Exercises7_9
use MouName
implicit none
character(len=10) :: str = '1AbHz05Z'
character :: largest
call max_char (str, largest)
write(*,100) str, largest
100 format(' The largest character in ', A, ' is ', A)
end subroutine Exercises7_9
! 习题7-10
module my_constants
implicit none
real, parameter :: PI_1 = 3.141593
real, parameter :: G_1 = 9.81
end module my_constants
subroutine Exercises7_10
! implicit none
use my_constants
write(*,*) 'SIN(2*PI) = ', sin(2.*PI_1)
! G_1 = 17.
end subroutine Exercises7_10
! 习题7-14
module ran001
implicit none
integer :: n = 12345
end module ran001
subroutine seed0(iseed)
use ran001
implicit none
real, intent(in) :: iseed
n = abs(iseed)
end subroutine seed0
subroutine random(ran)
use ran001
implicit none
real, intent(inout) :: ran
n = mod(8121*n+28411,134456)
ran = real(n)/134456
end subroutine random
subroutine Exercises7_14
implicit none
real :: randomSeed = 123456
real :: randomValue
integer :: i
call seed0(randomSeed)
do i = 1,10
call random(randomValue)
randomValue = randomValue*2.-1
write(*,*) randomValue
end do
end subroutine Exercises7_14
! 习题7-15
subroutine Exercises7_15
implicit none
real :: randomSeed = 123456
real :: randomValue, sum = 0
integer :: i, point
integer, dimension(6) :: pointSum
call seed0(randomSeed)
pointSum = 0
do i = 1,1000000
call random(randomValue)
point = int(randomValue*6+1)
! write(*,*) '你掷到了数字', point
pointSum(point) = pointSum(point) + 1
end do
write(*,*) '各点数计数分别为：', (pointSum(i), ',', i = 1, 6)
end subroutine
! 习题7-16
subroutine Exercises7_16
implicit none
real :: countPerMinute, time, probability, PoissonDistribution
integer :: k
countPerMinute=1.6
time=1.
do k = 0, 5
probability = PoissonDistribution(k, time, countPerMinute)
write(*,*) '一分钟内有', k, '辆车经过的可能性为', probability
end do
end subroutine Exercises7_16
! 泊松分布函数
real function PoissonDistribution(k, t, countBar)
implicit none
integer, intent(in) :: k
real, intent(in) :: t, countBar
integer :: i, kFactorial
kFactorial = 1
do i = 2, k
kFactorial = kFactorial*i
end do
PoissonDistribution = exp(-countBar*t)*(countBar*t)**k/real(kFactorial)
end function PoissonDistribution
! 习题7-18
subroutine Exercises7_18
implicit none
real :: x, FunSinh, FunCosh, FunTanh
integer :: i
real, dimension(11) :: numList=[-2.0,-1.5,-1.0,-0.5,-0.25,0.0,0.25,0.5,1.0,1.5,2.0]
x = 1.2
write(*,*) '双曲正弦值：计算结果为：', FunSinh(x), '验证值为：', sinh(x)
write(*,*) '双曲余弦值：计算结果为：', FunCosh(x), '验证值为：', cosh(x)
write(*,*) '双曲正切值：计算结果为：', FunTanh(x), '验证值为：', tanh(x)
write(*,*)
write(*,1) 'Num ', numList
write(*,*) '==== ======== ======== ======== ======== ======== &
&======== ======== ======== ======== ======== ========'
write(*,1) 'Sinh', (FunSinh(numList(i)), i = 1, 11)
write(*,1) 'CosH', (FunCosh(numList(i)), i = 1, 11)
write(*,1) 'Tanh', (FunTanh(numList(i)), i = 1, 11)
1 format(1X, A4, 11(1X, F8.5))
end subroutine Exercises7_18
! 双曲正弦
real function FunSinh(x)
implicit none
real, intent(in) :: x
FunSinh = (exp(x)-exp(-x))/2
end function FunSinh
! 双曲余弦
real function FunCosh(x)
implicit none
real, intent(in) :: x
FunCosh = (exp(x)+exp(-x))/2
end function FunCosh
! 双曲正切
real function FunTanh(x)
implicit none
real, intent(in) :: x
FunTanh = (exp(x)-exp(-x))/(exp(x)+exp(-x))
end function FunTanh
! 习题7-19 向量叉积（三维向量）
subroutine Exercises7_19
use MouName
implicit none
real, dimension(3) :: array1 ! 矢量1
real, dimension(3) :: array2 ! 矢量2
real, dimension(3) :: arrayResult ! 结果矢量
array1 = [-2.,4.,0.5]
array2 = [0.5,3.,2.]
write(*,1) VectorProduct_3(array1, array2)
1 format(1X, "矢量V1与矢量V2的差积为：", 3(1X, F6.2))
end subroutine Exercises7_19
! 叉积运算子程序，为啥子程序能运行，函数不可以，一定要放到模组里，，，是真的恶心，不然就会被当作调用数组而不是调用函数
! subroutine VectorProduct_3(vectorX, vectorY, arrayResult, n)
! implicit none
! integer :: n
! real, intent(in), dimension(n) :: vectorX, vectorY
! real, intent(out), dimension(n) :: arrayResult
! arrayResult = vectorX((/2,3,1/))*vectorY((/3,1,2/))-vectorY((/2,3,1/))*vectorX((/3,1,2/))
! end subroutine VectorProduct_3
! 习题7-20 数组排序
subroutine Exercises7_20
implicit none
integer, parameter :: arrayLength = 9
real, dimension(arrayLength) :: arr1, arr2
arr1 = (/1.,11.,-6.,17.,-23.,0.,5.,1.,-1./)
arr2 = (/31.,101.,36.,-17.,0.,10.,-8.,-1.,-1./)
call ArraySort(arr1, arr2, arrayLength)
write(*,1) 'arr1：', arr1
write(*,1) 'arr2：', arr2
1 format(1X, A, 9(F7.2, 1X))
end subroutine Exercises7_20
! 习题7-20 数组排序
subroutine ArraySort(arrayBase, arrayEntourage, n)
implicit none
integer :: n
real, intent(inout), dimension(n) :: arrayBase, arrayEntourage
integer :: i, j, maxPosition
real :: maxValue
do i = 1, n - 1
maxPosition = i
do j = i + 1, n
if ( arrayBase(maxPosition) < arrayBase(j) ) then
maxPosition = j
end if
end do
if ( i /= maxPosition ) then
maxValue = arrayBase(maxPosition)
arrayBase(maxPosition) = arrayBase(i)
arrayBase(i) = maxValue
maxValue = arrayEntourage(maxPosition)
arrayEntourage(maxPosition) = arrayEntourage(i)
arrayEntourage(i) = maxValue
end if
end do
end subroutine ArraySort
! 习题7-21 函数的最大值和最小值测试驱动程序
subroutine Exercises7_21
implicit none
real :: xStart, xEnd, xInc, minPosition, maxPosition, minValue, maxValue
real, external :: Exercises7_21_fun
call SearchFunctionExtermeValue(-1., 3., 200, Exercises7_21_fun, minPosition, minValue, maxPosition, maxValue)
write(*,1) 'Exercises7_21_fun 在 x = ', maxPosition, ' 处取到最大值 ',&
& maxValue, '，在 x = ', minPosition, ' 处取到最小值 ', minValue
1 format(1X, A, F5.2, A, F5.2, A, F5.2, A, F5.2)
end subroutine Exercises7_21
! 习题7-21 求取函数的最大值和最小值
subroutine SearchFunctionExtermeValue(firstValue, lastValue, numSteps, func, xmin, minValue, xmax, maxValue)
implicit none
real, intent(in) :: firstValue, lastValue
real, intent(out) :: xmin, xmax, minValue, maxValue
integer, intent(in) :: numSteps
real :: xInc
real, external :: func
real :: value, temp
value = firstValue
xmin = value
xmax = value
temp = func(value)
minValue = temp
maxValue = temp
do
value = value + (lastValue-firstValue)/numSteps
if ( value > lastValue ) exit
temp = func(value)
if ( temp > maxValue ) then
xmax = value
else if ( temp < minValue ) then
xmin = value
end if
end do
maxValue = func(xmax)
minValue = func(xmin)
end subroutine SearchFunctionExtermeValue
! 习题7-22 自定义函数给7-21
real function Exercises7_21_fun(x)
implicit none
real :: x
Exercises7_21_fun = x**3-5*x**2+5*x+2
end function Exercises7_21_fun
! 习题7-23 微分函数测试驱动程序 + 习题7-24 噪声值微分
! 程序结构：
! x = 0
! dx = 0.05
! 输入向量 = (sin(0+i*dx), i = 0,99)
! 调用子程序, 输入: 输入向量(100) 个数 dx 输出向量(99)
! 验证向量 = (cos(0+i*dx), i = 0,98)
! write 计算结果于实际值的接近程度判断结果为: abs(输出向量-验证向量) <= 临界值
! 子程序(输入向量(向量长度), 向量长度, 步长, 输出向量(向量长度-1))
! if abs(步长) <= 临界值 then
! write error!
! exit
! else
! 输出向量(i) = ((输入向量(i+1)-输入向量(i))/步长, i = 1, 99)
! end if
subroutine Exercises7_23
use MouName
implicit none
integer, parameter :: numSteps = 100
real, dimension(numSteps) :: arrayInput
real, dimension(numSteps-1) :: arrayResult, arrayCheck
real, dimension(numSteps-1) :: arrayNoise
integer :: i
real :: stepsLength
stepsLength = 0.05
arrayInput = [(sin(0+i*stepsLength), i = 0, numSteps-1)]
call Differential(arrayInput, numSteps, stepsLength, arrayResult)
arrayCheck = [(cos(0+i*stepsLength), i = 0, numSteps-2)]
write(*,*) '计算结果符合程度判断:', all((abs(arrayCheck-arrayResult) <= 0.05) .eqv. .TRUE.)
call RandomArrayCreator(numSteps-1, arrayNoise)
! arrayResult = arrayResult + arrayNoise * 0.04 - 0.02
write(*,'(10F6.2)') arrayResult - arrayCheck
end subroutine Exercises7_23
! 习题7-23 微分计算子程序
subroutine Differential(arrayInput, numSteps, stepsLength, arrayOutput)
use MouName
integer, intent(in) :: numSteps
real, dimension(numSteps), intent(in) :: arrayInput
real, dimension(numSteps-1), intent(out) :: arrayOutput
real, intent(in) :: stepsLength
if ( abs(stepsLength) <= criticalZero ) then
stop '步长过小, 请检查后再编译执行'
else
arrayOutput = [((arrayInput(i+1)-arrayInput(i))/stepsLength, i = 1, numSteps-1)]
end if
end subroutine Differential
! 噪声值产生(产生指定数目0~1的随机数)
subroutine RandomArrayCreator(randomNum, arrayOutput)
implicit none
real :: randomSeed = 207333
integer, intent(in) :: randomNum
real, dimension(randomNum), intent(out) :: arrayOutput
integer :: i
call seed0(randomSeed)
! arrayOutput = (/(call random(randomValue), i = 1, randomNum)/) ! call不返回值!
do i = 1, randomNum
call random(arrayOutput(i))
end do
end subroutine RandomArrayCreator
! 习题7-25 二进制补运算测试驱动程序
subroutine Exercises7_25
use MouName
implicit none
integer, parameter :: strLength = 8
character(len=strLength) :: str1, str2, strResult
integer :: intAdd, intSub
str1 = '11111111'
str2 = '00000001'
! strResult = BinaryAddition(str1, str2, strLength)
intAdd = BaseConversion_2To10(BinaryAddition(str1, str2, strLength), strLength)
intSub = BaseConversion_2To10(BinarySubtraction(str1, str2, strLength), strLength)
write(*,*) str1, ' + ', str2, ' 的结果为 ', BaseConversion_10To2(intAdd, strLength)
write(*,*) str1, ' - ', str2, ' 的结果为 ', BaseConversion_10To2(intSub, strLength)
write(*,*) BaseConversion_2To10(str1, strLength), ' + ', BaseConversion_2To10(str2, strLength), ' 的结果为 ', intAdd
write(*,*) BaseConversion_2To10(str1, strLength), ' - ', BaseConversion_2To10(str2, strLength), ' 的结果为 ', intSub
end subroutine Exercises7_25
! 习题7-26 线性最小二乘拟合 习题7-27 最小二乘拟合的相关系数 测试驱动程序
subroutine Exercises7_26
implicit none
integer, parameter :: arrayLength=20
real, dimension(arrayLength) :: arrayX, arrayY
real :: m, b, r
arrayX = (/-4.91, -3.84, -2.41, -2.62, -3.78, -0.52, -1.83, -2.01, +0.28, +1.08&
&, -0.94, +0.59, +0.69, +3.04, +1.01, +3.60, +4.53, +5.12, +4.43, +4.12/)
arrayY = (/-8.18, -7.49, -7.11, -6.15, -5.62, -3.30, -2.05, -2.83, -1.16, +0.52&
&, +0.21, +1.73, +3.96, +4.26, +5.75, +6.67, +7.70, +7.31, +9.05, 10.95/)
call LeastSquaresMethod(arrayX, arrayY, arrayLength, m, b, r)
write(*,1) m, b, r
1 format(1X, '计算得到的拟合方程为: y = ', F5.2, ' * x + ', F5.2, ' , 相关系数r为: ', F5.3)
end subroutine Exercises7_26
! 习题7-26 最小二乘法计算各参数（斜率、截距、相关系数）
subroutine LeastSquaresMethod(arrayX, arrayY, arrayLength, slope, intercept, correlationCoefficient)
implicit none
integer, intent(in) :: arrayLength ! 设定数组长度
real, dimension(arrayLength),intent(in) :: arrayX, arrayY ! 设定输入X、Y坐标数组
real, intent(out) :: slope, intercept, correlationCoefficient ! 设定输出斜率、截距和相关系数
integer :: i ! 循环变量
real :: x_bar, y_bar ! xy均值
real :: r ! 相关系数
real :: x_sum, y_sum ! xy总和
real :: x2_sum, xy_sum, y2_sum ! 各种参数
! 变量初始化
x_sum = 0
y_sum = 0
x2_sum = 0
y2_sum = 0
xy_sum = 0
i = 0
do i = 1, arrayLength ! 循环计算各参数
x_sum = x_sum + arrayX(i) ! x总和
y_sum = y_sum + arrayY(i) ! y总和
x2_sum = x2_sum + arrayX(i)**2 ! x方总和
y2_sum = y2_sum + arrayY(i)**2 ! y方总和
xy_sum = xy_sum + arrayX(i)*arrayY(i) ! xy总和
end do
x_bar = x_sum/real(i) ! x均值
y_bar = y_sum/real(i) ! y均值
slope = ( xy_sum - x_sum*y_bar )/( x2_sum - x_sum*x_bar ) ! 斜率
intercept = y_bar - slope*x_bar ! 截距
correlationCoefficient = ( real(i)*xy_sum - x_sum*y_sum )/& ! 相关系数
&sqrt( (real(i)*x2_sum - x_sum**2 )*( real(i)*y2_sum - y_sum**2 ) )
end subroutine LeastSquaresMethod
! 习题7-28 生日问题
subroutine Exercises7_28
implicit none
integer :: numPerson ! 房间内人数
real :: CompletelyDifferentProbability ! 调用理论值计算函数
real :: DifferentProbabilityTest ! 测试概率值计算
do numPerson = 2, 40
write(*,*) numPerson, '个人生日不同的理论概率为', CompletelyDifferentProbability(numPerson, 365)
write(*,*) numPerson, '个人生日不同的测试概率为', DifferentProbabilityTest(numPerson, 365)
end do
end subroutine Exercises7_28
! n个特定范围内的整数, 彼此之间完全不同的概率
real function CompletelyDifferentProbability(num, total)
implicit none
integer, intent(in) :: num ! 样本个数
integer, intent(in) :: total ! 可能的样本值总数
integer :: i ! 循环参数
CompletelyDifferentProbability = 1. ! 初始化输出
do i = 1, num - 1
CompletelyDifferentProbability = CompletelyDifferentProbability * real(total - i) / real(total)
end do
end function CompletelyDifferentProbability
! 从随机数中求n个特定范围内的整数, 彼此之间完全不同的概率
real function DifferentProbabilityTest(num, total)
implicit none
integer, intent(in) :: num ! 样本个数
integer, intent(in) :: total ! 样本值可能情况总数
integer, dimension(num) :: arrayTemp ! 样本值临时数组
integer, parameter :: numTest=90000 ! 测试次数
real :: randomValue
integer :: i, j ! 循环参数
integer :: temp ! 用于保存生成的随机数的临时值
call seed0(111111.) ! 获取初始随机参数
DifferentProbabilityTest = real(numTest) ! 初始化输出为测试次数
do i = 1, numTest ! 测试循环开始
arrayTemp = -1 ! 初始化随机数组
check: do j = 1, num ! 检查是否存在相同值循环
call random(randomValue) ! 获取一个1~0随机数
temp = floor(randomValue*total) ! 将随机数转化为1~总数之间的整数值
if ( any(arrayTemp==temp) ) then ! 如果存在相同数字
DifferentProbabilityTest = DifferentProbabilityTest - 1.! 中间值--
exit check ! 退出给随机数组赋值
end if ! 如果结束
arrayTemp(j) = temp ! 给随机数组当前位赋值
end do check ! 该次测试结束
end do ! 所有测试结束
DifferentProbabilityTest = DifferentProbabilityTest/real(numTest) ! 生成输出值(概率)
end function DifferentProbabilityTest
! 习题7-29 经时计算 习题公共模块
module ModuleExercises7_29 ! 定义模块
implicit none ! 声明显示表达
! 数据字典
integer, dimension(8) :: timeNow ! 当前时间数组
integer, dimension(8) :: timeOld ! 上一个时间数组
contains ! 所包含函数和子程序
! 习题7-29 经时计算 子程序1
subroutine set_timer ! 创建子程序1
implicit none ! 声明显示表达
call DATE_AND_TIME(values=timeNow) ! 调用当前时间子程序
end subroutine set_timer ! 结束子程序1
! 习题7-29 经时计算 子程序2
subroutine elapsed_time(timePast) ! 创建子程序2
implicit none ! 声明显示表达
real, intent(out) :: timePast ! 定义输出变量
timeOld = timeNow ! 传递值
call set_timer ! 调用子程序1
timePast = ((real(timeNow(3)-timeOld(3))*24 + real(timeNow(5)-timeOld(5)))&
&*60 + real(timeNow(6)-timeOld(6)))*60 + real(timeNow(7)-timeOld(7)) + &
&real(timeNow(8)-timeOld(8))/1000 ! 计算经历时间(秒)
end subroutine elapsed_time ! 结束子程序2
end module ModuleExercises7_29 ! 结束模块
! 习题7-29 经时计算 测试驱动程序 习题7-30 子程序计算
subroutine Exercises7_29 ! 定义测试驱动程序
use ModuleExercises7_29 ! 读取模块
implicit none ! 显式声明
integer, parameter :: arrayLength=100 ! 定义数组基础长度
real :: array1(arrayLength), array2(arrayLength*10), array3(arrayLength*100) ! 定义使用的随机数数组
real :: timePast ! 定义经历时间长度变量
real :: time1, time2, time3 ! 每次排序所消耗的时间
integer :: i, j ! 循环参数
! 变量初始化
time1 = 0
time2 = 0
time3 = 0
! 多次循环计算时间, 统计循环次数与用时总和
do j = 1, 10
call seed0(111111.) ! 随机数种子
do i = 1, 100 ! 给array1赋值
call random(array1(i))
end do
do i = 1, 1000 ! 给array2赋值
call random(array2(i))
end do
do i = 1, 10000 ! 给array3赋值
call random(array3(i))
end do
call set_timer ! 计算array1排序所需时间
call Sort(array1, arrayLength)
call elapsed_time(timePast)
time1 = time1 + timePast ! array1排序时间总计
call set_timer ! 计算array2排序所需时间
call Sort(array2, arrayLength*10)
call elapsed_time(timePast)
time2 = time2 + timePast ! array2排序时间总计
call set_timer ! 计算array3排序所需时间
call Sort(array3, arrayLength*100)
call elapsed_time(timePast)
time3 = time3 + timePast ! array3排序时间总计
end do
! 计算排序所需时间均值
time1 = time1/real(i)
time2 = time2/real(i)
time3 = time3/real(i)
write(*,1) time1, time2, time3 ! 打印排序时间信息
1 format(1X, '排序三个数组分别经历了', /&
&1X, '1. ', F10.8, ' s', /&
&1X, '2. ', F10.8, ' s', /&
&1X, '3. ', F10.8, ' s')
end subroutine Exercises7_29
! 习题7-30 排序子程序
subroutine Sort(array, n)
implicit none
integer :: n ! 数组长度
real, intent(inout), dimension(n) :: array ! 定义输入输出数组
integer :: i, j, maxPosition ! 循环参数和最大值位置
real :: maxValue ! 最大值的值
! 对数组进行排序
do i = 1, n - 1
maxPosition = i
do j = i + 1, n
if ( array(maxPosition) < array(j) ) then
maxPosition = j
end if
end do
if ( i /= maxPosition ) then
maxValue = array(maxPosition)
array(maxPosition) = array(i)
array(i) = maxValue
end if
end do
end subroutine Sort
! 习题7-31 估算无限序列 测试驱动程序
subroutine Exercises7_31
implicit none
integer, parameter :: arrayLength=8 ! 数组长度
real, dimension(arrayLength) :: arrayX, arrayY ! 输入数组X与输出数组Y
real :: ExEstimation ! 定义函数返回值类型
integer :: i ! 循环参数
arrayX = (/-10., -5., -1., 0., 1., 5., 10., 15./) ! 赋值输入数组X
! arrayY = (/((ExEstimation(arrayX(i)), i = 1, arrayLength))/) ! 好像不能这样用隐式循环
do i = 1, arrayLength ! 循环求输出数组Y的值
arrayY(i) = ExEstimation(arrayX(i)) ! 调用函数赋值
end do
write(*,1) arrayX, arrayY, exp(arrayX) ! 输出结果表格
1 format(1X, 'Form. e^x value estimation'/&
&1X, 'Input ', 8(1X, F9.2)/&
&1X, 'Output ', 8(1X, ES9.2)/&
&1X, 'Real ', 8(1X, ES9.2))
end subroutine Exercises7_31
! 习题7-31 EXP(X)
real function ExEstimation(x)
implicit none
real, intent(in) :: x ! 定义输入变量指数值
integer :: n ! 循环参数n
integer :: nFactorial ! n的阶乘
! 初始化变量
ExEstimation = 0
nFactorial = 1
do n = 0, 11 ! 取无限序列前12项
ExEstimation = ExEstimation + x**n/nFactorial ! 加和趋近结果值
nFactorial = nFactorial*(n+1) ! 计算下一次循环需要的阶乘值
end do
end function ExEstimation
! 习题7-32 使用子程序计算随机分布情况
subroutine Exercises7_32
implicit none
integer, parameter :: arrayLength=10000 ! 定义数组长为10000
real, dimension(arrayLength) :: array ! 定义随机数组
real :: Average, StandardDeviation ! 定义平均值和标准差为实型
integer :: i ! 循环参数
call seed0(111111.) ! 初始化随机数
do i = 1, arrayLength ! 循环给随机数组赋值
call random(array(i))
end do
! 输出结果
write(*,*) '随机数组平均值为: ', Average(array, arrayLength)
write(*,*) '随机数组标准差为: ', StandardDeviation(array, arrayLength)
write(*,*) '理论的平均值是0.5, 理论的标准偏差是', 1/sqrt(12.)
end subroutine Exercises7_32
! 习题7-33 计算数列平均值与标准偏差
real function Average(arrayInput, arrayLength)
implicit none
integer, intent(in) :: arrayLength ! 定义数组长度
real, dimension(arrayLength), intent(in) :: arrayInput ! 定义输入数组
integer :: i ! 循环参数
Average = 0 ! 初始化输出
do i = 1, arrayLength ! 循环加和数组值
Average = Average + arrayInput(i)
end do
Average = Average/real(i) ! 计算平均值
end function Average
real function StandardDeviation(arrayInput, arrayLength)
implicit none
integer, intent(in) :: arrayLength ! 定义数组长度
real, dimension(arrayLength), intent(in) :: arrayInput ! 定义输入数组
integer :: i ! 循环参数
real :: average ! 定义平均值
average = 0 ! 初始化平均值
StandardDeviation = 0 ! 初始化标准差
do i = 1, arrayLength ! 循环加和数组值
average = average + arrayInput(i)
end do
average = average/i ! 计算平均值
do i = 1, arrayLength ! 循环加和平均值与数组值的平方差
StandardDeviation = StandardDeviation + (average - arrayInput(i))**2
end do
StandardDeviation = sqrt(StandardDeviation/(i - 1)) ! 计算标准偏差
end function StandardDeviation
! 习题7-33 高斯(正态)分布
subroutine Exercises7_33
implicit none
integer, parameter :: arrayLength=1000 ! 定义数组长度
real, dimension(arrayLength) :: arrayNormal ! 定义随机正态分布数组
integer :: i ! 循环参数
real :: StandardDeviation, Average ! 定义函数返回值类型
call seed0(111111.) ! 初始化随机数
! do i = 1, int(arrayLength/2) ! 按照书上方法生成正态分布随机值
! call NormallyDistributedRandomValue(arrayNormal(2*i-1), arrayNormal(2*i))
! end do
do i = 1, arrayLength ! 使用Box–Muller变换得到正态分布随机值
call NormallyDistributedRandomValue1(arrayNormal(i))
end do
! write(*,'(25(F5.2, 1X))') arrayNormal ! 显示计算得到的正态分布数据
write(*,*) '标准的正态分布标准偏差为1.0, 而计算得到的随机数列标准偏差为',&
& StandardDeviation(arrayNormal, arrayLength), '平均值为',&
& Average(arrayNormal, arrayLength) ! 显示数据集的标准偏差与平均值
end subroutine
! 习题7-33 高斯分布(书上方法)
subroutine NormallyDistributedRandomValue(outputValue1, outputValue2)
implicit none
real, intent(out) :: outputValue1, outputValue2 ! 定义输出数据
real :: r ! 定义r值
do ! 循环获取x1,x2并判断
call random(outputValue1)
call random(outputValue2)
if ( outputValue1**2 + outputValue2**2 - 1. <= 0 ) exit ! 如果平方和小于1, 那么结束循环
end do
r = outputValue1**2 + outputValue2**2 ! 计算平方和
! write(*,*) r
outputValue1 = sqrt(-2.*log(r)/r)*outputValue1 ! 计算y1(输出值1)
outputValue2 = sqrt(-2.*log(r)/r)*outputValue2 ! 计算y2(输出值2)
end subroutine NormallyDistributedRandomValue
! 习题7-33 高斯分布(Box–Muller变换)
subroutine NormallyDistributedRandomValue1(outputValue)
implicit none
real, parameter :: PI = 3.14159265 ! 定义常数PI
real, intent(out) :: outputValue ! 定义输出值(符合正态分布的)
real :: outputValue1 ! 另一个需要的变量,但是不输出
call random(outputValue1) ! 获取均匀分布的随机数第一个数值
call random(outputValue) ! 获取均匀分布的随机数第二个数值
outputValue = sqrt(-2.*log(outputValue1))*cos(2*PI*outputValue) ! Box–Muller变换, 并输出结果
end subroutine NormallyDistributedRandomValue1
! 习题7-34 引力
subroutine Exercises7_34
implicit none
real, parameter :: mEarth=5.98E24 ! 地球质量(kg)
real :: m ! 卫星质量(kg)
real :: r ! 地心与卫星距离(m)
real :: Gravity ! 定义函数返回类型为实型
m = 1000. ! 设定卫星质量(kg)
r = 38000.*1000. ! 设定地卫距离(m)
write(*,*) '地球与卫星之间的引力大小为', Gravity(m, mEarth, r), ' N'
end subroutine Exercises7_34
! 引力计算
real function Gravity(m1, m2, r)
implicit none
real, parameter :: G=6.672E-11 ! 万有引力常数
real, intent(in) :: m1, m2, r ! 输入实型质量1,质量2,间距
Gravity = G*m1*m2/r**2 ! 输出两物体间引力值
end function Gravity
! 习题7-35 堆排序
! 了解有这么个玩意就成

517
第8章习题.f90 Normal file
View File

@ -0,0 +1,517 @@
! ==============================================================================
! 通过 gfortran ./test.f90 -o ./run && ./run 运行
! 程序名：
! 习题
! 目的:
! 练习用
! 修订记录:
! 日期 编程者 改动描述
! =================== ============= =====================================
! 2021-04-26 16:53:03 Sola 测验8-1 7 测试数组调用
! 2021-04-30 18:03:39 Sola 习题8-7 输出数组中正负数和0的个数
! 2021-04-30 18:49:30 Sola 习题8-8 可分配数组输入数据定义并计算行列和
! 2021-04-30 19:26:59 Sola 习题8-10 没看懂啥意思, 跳过
! 2021-04-30 19:27:16 Sola 习题8-11 在赋值中修改数组范围，太长了，跳过
! 2021-04-30 19:30:55 Sola 习题8-12 DO循环和WHERE结构比较
! 2021-04-30 20:10:23 Sola 习题8-13 计算年平均温度
! 2021-04-30 20:46:31 Sola 习题8-14 矩阵乘法 8-15 8-16
! 2021-05-01 00:32:18 Sola 习题8-17 相对极大(鞍点)
! 2021-05-01 02:01:58 Sola 习题8-18 金属盘温度分布
! 程序结构:
!
! ==============================================================================
! 模块：
module Module_8
implicit none
! 数据字典
! 声明常数
REAL, PARAMETER :: PI=3.14159265 ! PI值
REAL, PARAMETER :: e=2.718281828459 ! 自然对数
INTEGER, PARAMETER :: arrayLength=20 ! 数组基准长度
! 声明变量
! 创建显式接口
contains
! subroutine SubName(varName1,varName2)
! implicit none
! ! 数据字典
! end subroutine SubName
end module Module_8
! ==============================================================================
! 主程序：
program ProName
implicit none
! call Exercises8_1_7
! call Exercises8_7
! call Exercises8_8
! call Exercises8_9
! call Exercises8_10
! call Exercises8_11
! call Exercises8_12
! call Exercises8_13
! call Exercises8_14
! call Exercises8_17
call Exercises8_18
! 数据字典
! 声明常量
! 声明变量
! 变量初始化
! 数据输入
! 运算过程
! 结果输出
end program ProName
! ==============================================================================
! 子程序
! subroutine SubName(varName1,varName2)
! use MouName
! implicit none
! Type, intent(inout) :: varName
! end subroutine SubName
! ==============================================================================
! 函数
! function FunName(varName1,varName2)
! use MouName
! implicit none
! end function FunName
! ==============================================================================
! 测试8-1.7 使用数组从数组中调取元素
subroutine Exercises8_1_7
implicit none
integer, dimension(4) :: list1=(/1,4,2,2/) ! 定义数组1
integer, dimension(3) :: list2=(/1,2,3/) ! 定义数组2
integer, dimension(5, 5) :: array ! 定义数组3
integer :: i, j ! 循环参数
do i = 1, 5
do j = 1, 5
array(i, j) = i + 10*j ! 数组3赋值
end do
end do
write (*,'(1X, 4I4)') array(list1, list2) ! 测试通过数组调用数组
end subroutine Exercises8_1_7
! 习题8-7 统计数组中正负数和0的个数
subroutine Exercises8_7
implicit none
real, dimension(-50:50, 0:100) :: values ! 定义随机数组
integer :: i, j ! 循环参数
integer :: numPositive, numNegative, numZero ! 统计参数
! 初始化变量
numPositive = 0
numNegative = 0
numZero = 0
! FORALL方式随机赋值(好像不能这么用, 所以注释)
! forall (i=-50:50, j=0:100)
! call random_seed()
! call random_number(values(i, j))
! end forall
! 嵌套循环赋值
do i = -50, 50
do j = 0, 100
call random_seed() ! 根据日期, 时间获取随机数种子
call random_number(values(i, j)) ! 调用随机数子程序给数组赋值
end do
end do
values = values * 200. - 100. ! 调整数组范围
! 循环计算正负数和0的个数
do i = -50, 50
do j = 0, 100
if (values(i, j) > 0) then
numPositive = numPositive + 1
elseif (values(i, j) < 0) then
numNegative = numNegative + 1
else
numZero = numZero + 1
end if
end do
end do
! 输出结果
write(*,1) ' 测试组', numPositive, numNegative, numZero
write(*,1) ' 对照组', count(values > 0.), count(values < 0.), count(values == 0.)
1 format(1X, A/&
&1X, '数组中有正数 ', I5, '个'/&
&1X, '数组中有负数 ', I5, '个'/&
&1X, '数组中有0 ', I5, '个')
end subroutine Exercises8_7
! 习题8-8 可分配数组输入数据定义并计算行列和, 注意IO操作的返回值参数和数组分配不同
subroutine Exercises8_8
implicit none
real, dimension(:, :), allocatable :: array ! 定义可分配数组
integer :: errorLevel ! 错误码
integer :: a, b ! 数组范围
integer :: i ! 循环参数
character(len=20) :: inforError ! 错误信息
! 打开一个临时文件
open(unit=1, status='scratch', iostat=errorLevel, iomsg=inforError)
if (errorLevel /= 0) stop inforError ! 检测打开文件是否成功
! 输入参数 8-8
! write(1, *) 2, 4
! write(1, *) -24., -1121., 812.1, 11.1
! write(1, *) 35.6, 8.1E3, 135.23, -17.3
! 输入参数 8-9
write(1, *) 4, 5
write(1, *) 33., -12., 16., 0.5, -1.9
write(1, *) -6., -14., 3.5, 11., 2.1
write(1, *) 4.4, 1.1, -7.1, 9.3, -16.1
write(1, *) 0.3, 6.2, -9.9, -12., 6.8
! write(1, *) , , , ,
rewind(unit=1) ! 回到文件开头
read(1,*) a, b ! 读取数组范围
! 检查数组范围
if (a > 100) a = 100
if (b > 100) b = 100
allocate(array(a, b), stat=errorLevel, errmsg=inforError) ! 分配数组
if (errorLevel /= 0) stop inforError ! 检测数组分配是否成功
do i = 1, a
read(1, *) array(i, :) ! 数组赋值
end do
! 输出统计结果
1 format(1X, 'Sum of ', A, ' ', I3, ' = ', F10.3)
do i = 1, a
write(*, 1) 'row', i, sum(array(i, :))
end do
do i = 1, b
write(*, 1) 'col', i, sum(array(:, i))
end do
if (allocated(array)) deallocate(array, stat=errorLevel)
if (errorLevel /= 0) print *, "array: Deallocation request denied"
close(unit=1)
end subroutine Exercises8_8
! 习题8-10 没看懂啥意思, 跳过
! 习题8-11 在赋值中修改数组范围，太长了，跳过, 写了个简化版的，利用F03的特性实现
! 不过有一点需要注意，好像不可以用allocate语句多次定义，有点理解无缝是什么意思了
subroutine Exercises8_11
implicit none
real, dimension(:), allocatable :: array ! 定义可分配数组
integer :: i ! 循环变量
integer :: errorLevel ! 错误码
character(len=20) :: inforError ! 错误信息
real :: temp ! 临时变量
allocate(array(1), stat=errorLevel, errmsg=inforError) ! 分配数组
if (errorLevel /= 0) stop inforError ! 检测数组分配状态
call random_seed() ! 根据日期时间产生随机数种子
call random_number(array(1)) ! 用随机数给数组赋值
do i = 2, 50 ! 循环产生随机数, 并给数组赋值
call random_seed()
call random_number(temp)
array = (/array, temp/) ! 利用F03特性扩展数组
end do
write(*,'(1X, 10F6.3, " ")') array ! 10个一行输出数组内容
if (allocated(array)) deallocate(array, stat=errorLevel)
if (errorLevel /= 0) print *, "array: Deallocation request denied"
end subroutine Exercises8_11
! 习题8-12 DO循环和WHERE结构比较
subroutine Exercises8_12
implicit none
integer, parameter :: arrayLength=10 ! 设置数组基本长度
real, dimension(100*arrayLength, arrayLength, 3*arrayLength) :: arr, arrayTemp ! 定义数组
integer :: i, j, k ! 循环参数
! Where结构中也不可调用子程序
! real :: temp
! arr = 0.
! where(arr == 0.)
! call random_seed()
! call random_number(temp)
! arr = temp
! end where
do i = 1, 100*arrayLength
do j = 1, arrayLength
do k = 1, 3*arrayLength
call random_seed()
call random_number(arr(i, j, k)) ! 对数组进行循环赋值
end do
end do
end do
arr = arr*1300 ! 调整数组范围
arrayTemp = arr ! 拷贝数组
write(*, *) 'Do循环判断开始, 数组总和为', sum(arr) ! 参照
do i = 1, 100*arrayLength
do j = 1, arrayLength
do k = 1, 3*arrayLength
if (arr(i, j, k) > 1000.) arr(i, j, k) = 1000. ! DO判断
end do
end do
end do
write(*, *) 'Do循环判断结束, 数组总和为', sum(arr) ! 输出结果
write(*, *) 'Where结构开始' ! 参照
where(arrayTemp > 1000.)
arrayTemp = 1000. ! WHERE判断, Where结构真的方便...
end where
write(*, *) 'Where结构结束, 数组总和为', sum(arrayTemp) ! 输出结果
end subroutine Exercises8_12
! 习题8-13 计算年平均温度
subroutine Exercises8_13
implicit none
real, dimension(6, 6) :: array ! 定义数组
integer :: i ! 循环参数
integer :: errorLevel ! 错误码
character(len=20) :: inforError ! 错误信息
open(unit=1, status='scratch', iostat=errorLevel, iomsg=inforError) ! 打开临时文件
if (errorLevel /= 0) stop inforError ! 判断打开成功与否
write(1, 1) 68.2, 72.1, 72.5, 74.1, 74.4, 74.2, & ! 输入统计数据
&69.4, 71.1, 71.1, 71.9, 73.1, 73.6, &
&68.9, 70.5, 70.9, 71.5, 72.8, 73.0, &
&68.6, 69.9, 70.4, 70.8, 71.5, 72.2, &
&68.1, 69.3, 69.8, 70.2, 70.9, 71.2, &
&68.3, 68.8, 69.6, 70.0, 70.5, 70.9
1 format(6F5.1) ! 设定统计数据输入格式
rewind(unit=1) ! 回到文件开头
read(1,*) (array(i, :), i = 1, 6) ! 给数组赋值
2 format(1X, F4.1, A8, ' 的平均气温为 ', F4.1, ' ℃') ! 设定结果输出格式
do i = 1, 6
write(*, 2) 29.5 + real(i)*0.5, '°N lat ', sum(array(i, :))/6. ! 输出纬度平均气温
end do
do i = 1, 6
write(*, 2) 89.5 + real(i)*0.5, '°W long', sum(array(:, i))/6. ! 输出经度平均气温
end do
write(*, 3) '所有统计地点年平均温度为 ', sum(array)/36., ' ℃' ! 输出所有地区平均气温
3 format(1X, A, F4.1, A) ! 设定结果输出格式
close(unit=1) ! 关闭文件, 此句可忽略
end subroutine Exercises8_13
! 习题8-14 矩阵乘法, 注意, F03虽然可以自动分配大小, 但是还是得先给他分配一个大小
subroutine Exercises8_14
implicit none
! real, dimension(:,:), allocatable :: MatrixMultplication
real, dimension(:, :), allocatable :: array1, array2, array3
integer :: i, j, k
integer :: a, b
integer :: errorLevel ! 错误码
character(len=20) :: inforError ! 错误信息
open(unit=1, status='scratch', iostat=errorLevel, iomsg=inforError) ! 打开临时文件
if (errorLevel /= 0) stop inforError ! 判断打开成功与否
open(unit=2, status='scratch', iostat=errorLevel, iomsg=inforError) ! 打开临时文件
if (errorLevel /= 0) stop inforError ! 判断打开成功与否
! 习题8-14使用
! 匹配的, 输入矩阵1
! write (1, '(A)') " 2, 2",&
! &" 3.0, -1.0",&
! &" 1.0, 2.0"
! ! 不匹配的, 输入矩阵1
! ! write (1, '(A)') " 2, 2, 3",&
! ! &" 3.0, -1.0, 1.0",&
! ! &" 1.0, 2.0, 1.0"
! ! 输入矩阵2
! write (2, '(A)') " 2, 2",&
! &" 1.0, 4.0",&
! &" 2.0, -3.0"
! 习题8-15使用
write (1, '(A)') " 2, 4",&
&" 1.0, -5.0, 4.0, 2.0",&
&" -6.0, -4.0, 2.0, 2.0"
write (2, '(A)') " 4, 3",&
&" 1.0, -2.0, -1.0",&
&" 2.0, 3.0, 4.0",&
&" 0.0, -1.0, 2.0",&
&" 0.0, -3.0, 1.0"
rewind(unit=1) ! 回到文件1第一行
rewind(unit=2) ! 回到文件2第一行
read(1, *) a, b ! 读取矩阵1大小
allocate(array1(a, b), stat=errorLevel) ! 分配矩阵1
if (errorLevel /= 0) print *, "array1: Allocation request denied"
read(1, *) (array1(i, :), i = 1, a) ! 给矩阵1赋值
read(2, *) a, b ! 读取矩阵2大小
allocate(array2(a, b), stat=errorLevel) ! 分配矩阵2
if (errorLevel /= 0) print *, "array2: Allocation request denied"
read(2, *) (array2(i, :), i = 1, a) ! 给矩阵2赋值
! 关闭打开的临时文件(实际上一般可以不管)
close(unit=1)
close(unit=2)
if (size(array1, 2) /= size(array2, 1)) stop "警告! 数组维度不匹配!"! 检测是否可进行矩阵乘法
allocate(array3(size(array1, 1), size(array2, 2)), stat=errorLevel) ! 分配矩阵3
if (errorLevel /= 0) print *, "array3: Allocation request denied"
! array3 = MatrixMultplication(array1, array2)
array3 = 0. ! 初始化矩阵3
! 习题8-14, 8-15使用
! FORALL结构给矩阵3赋值, 注意这里会警告重复计算, 别管他, 设计就是这样
! forall(i = 1:size(array1, 1), j = 1:size(array1, 2), k = 1:size(array2, 2))
! array3(i, k) = array1(i, j)*array2(j, k) + array3(i, k)
! end forall
! 习题8-16 使用(改写后的)
array3 = matmul(array1, array2)
! 关闭数组, 释放资源
if (allocated(array2)) deallocate(array2, stat=errorLevel)
if (errorLevel /= 0) print *, "array2: Deallocation request denied"
if (allocated(array1)) deallocate(array1, stat=errorLevel)
if (errorLevel /= 0) print *, "array1: Deallocation request denied"
write(*, 2) (array3(i, :), i = 1, size(array3, 1)) ! 输出矩阵乘法计算结果
2 format(2(1X, F7.2, 1X))
if (allocated(array3)) deallocate(array3, stat=errorLevel)
if (errorLevel /= 0) print *, "array3: Deallocation request denied"
! contains
! function MatrixMultplication(arrayInput1, arrayInput2)
! implicit none
! real, dimension(:,:), allocatable, intent(in) :: arrayInput1, arrayInput2
! real, dimension(:,:), allocatable :: MatrixMultplication
! integer :: i, j, k
! if (size(arrayInput1, 2) /= size(arrayInput2, 1)) stop "警告! 数组维度不匹配!"
! MatrixMultplication = 0.
! forall(i = 1:size(arrayInput1, 1), j = 1:size(arrayInput1, 2), k = 1:size(arrayInput2, 2))
! MatrixMultplication(i, k) = arrayInput1(i, j)*arrayInput2(j, k) + MatrixMultplication(i, k)
! end forall
! end function MatrixMultplication
end subroutine Exercises8_14
! 习题8-17 相对极大(鞍点)
! 根据鞍点的定义, 可以直接遍历程序中每个点,,, 不过这样好像效率不太高的样子
! 1. 鞍点比上一行的值都大, 比下一行的值都大, 比左一列的值都大, 比右一列的值都大
! 2. 检测筛选之后的值
! 所以, 需要有一个输入矩阵, 有一个标定矩阵, 确定其位置的, i, j, 以及坐标数组(可扩展)
subroutine Exercises8_17
implicit none
real, dimension(:, :), allocatable :: arrayInput ! 输入矩阵
logical, dimension(:, :), allocatable :: arrayCheck ! 检测矩阵
integer :: i, j ! 循环参数
integer, dimension(:, :), allocatable :: arrayPoint ! 鞍点坐标
integer :: sizeX, sizeY ! 矩阵大小
integer :: errorLevel ! 错误码
integer :: num ! 鞍点个数
character(len=20) :: inforError ! 错误信息
! 变量初始化
num = 0
open(unit=1, status='scratch', iostat=errorLevel, iomsg=inforError) ! 打开临时文件
if (errorLevel /= 0) stop inforError ! 确认临时文件成功打开
write (1, '(A)') " 8, 8",& ! 向临时文件写入矩阵
&" 2.0, -1.0, -2.0, 1.0, 3.0, -5.0, 2.0, 1.0",&
&" -2.0, 0.0, -2.5, 5.0, -2.0, 2.0, 1.0, 0.0",&
&" -3.0, -3.0, -3.0, 3.0, 0.0, 0.0, -1.0, -2.0",&
&" -4.5, -4.0, -7.0, 6.0, 1.0, -3.0, 0.0, 5.0",&
&" -3.5, -3.0, -5.0, 0.0, 4.0, 17.0, 11.0, 5.0",&
&" -9.0, -6.0, -5.0, -3.0, 1.0, 2.0, 0.0, 0.5",&
&" -7.0, -4.0, -5.0, -3.0, 2.0, 4.0, 3.0, -1.0",&
&" -6.0, -5.0, -5.0, -2.0, 0.0, 1.0, 2.0, 5.0"
rewind(unit=1) ! 返回初始行
read(1, *) sizeY, sizeX ! 获得矩阵大小
allocate(arrayInput(sizeX, sizeY), stat=errorLevel) ! 定义输入矩阵
if (errorLevel /= 0) print *, "arrayInput: Allocation request denied"
allocate(arrayCheck(sizeX, sizeY), stat=errorLevel) ! 定义检测矩阵
if (errorLevel /= 0) print *, "arrayCheck: Allocation request denied"
allocate(arrayPoint(2, 1), stat=errorLevel) ! 定义鞍点坐标数组
if (errorLevel /= 0) print *, "arrayPoint: Allocation request denied"
read(1, *) (arrayInput(i, :), i = 1, sizeY) ! 给输入矩阵赋值
close(unit=1, iostat=errorLevel, iomsg=inforError) ! 关闭临时文件
if (errorLevel /= 0) stop inforError ! 检测是否关闭成功
arrayCheck = .FALSE. ! 初始化检测矩阵
do i = 2, sizeX - 1 ! 标记行间最大值
arrayCheck(i, 2:sizeY-1) = (arrayInput(i, 2:sizeY-1) > arrayInput(i-1, 2:sizeY-1)) .and. &
&(arrayInput(i, 2:sizeY-1) > arrayInput(i+1, 2:sizeY-1))
end do
do j = 2, sizeY - 1 ! 标记行列间最大值
arrayCheck(2:sizeX-1, j) = (arrayInput(2:sizeX-1, j) > arrayInput(2:sizeX-1, j-1)) .and. &
&(arrayInput(2:sizeX-1, j) > arrayInput(2:sizeX-1, j+1)) .and. &
& arrayCheck(2:sizeX-1, j)
end do
forall (i=2:sizeX-1, j=2:sizeY-1, arrayCheck(i, j)) ! 标记点与左上比较并迭代
arrayCheck(i, j) = (arrayInput(i, j) > arrayInput(i-1, j-1))
end forall
forall (i=2:sizeX-1, j=2:sizeY-1, arrayCheck(i, j)) ! 标记点与左下比较并迭代
arrayCheck(i, j) = (arrayInput(i, j) > arrayInput(i+1, j-1))
end forall
forall (i=2:sizeX-1, j=2:sizeY-1, arrayCheck(i, j)) ! 标记点与右下比较并迭代
arrayCheck(i, j) = (arrayInput(i, j) > arrayInput(i+1, j+1))
end forall
forall (i=2:sizeX-1, j=2:sizeY-1, arrayCheck(i, j)) ! 标记点与右上得到鞍点
arrayCheck(i, j) = (arrayInput(i, j) > arrayInput(i-1, j+1))
end forall
if (allocated(arrayInput)) deallocate(arrayInput, stat=errorLevel) ! 关闭输入矩阵
if (errorLevel /= 0) print *, "arrayInput: Deallocation request denied"
do i = 2, sizeX - 1
do j = 2, sizeY - 1
if (arrayCheck(j, i) .eqv. .TRUE.) then
num = num + 1
arrayPoint(:, num) = (/i, j/) ! 遍历检测矩阵, 得到鞍点坐标
end if
end do
end do
if (allocated(arrayCheck)) deallocate(arrayCheck, stat=errorLevel) ! 关闭检测矩阵
if (errorLevel /= 0) print *, "arrayCheck: Deallocation request denied"
write(*, 1) '矩阵中的鞍点坐标如下:', (arrayPoint(:, i), i = 1, num) ! 输出结果
1 format(1X, A/&
&6('(', I2, ',', I2, ') ')) ! 定义输出格式
if (allocated(arrayPoint)) deallocate(arrayPoint, stat=errorLevel) ! 关闭坐标数组
if (errorLevel /= 0) print *, "arrayPoint: Deallocation request denied"
end subroutine Exercises8_17
! 习题8-18 金属盘温度分布, 总感觉这题好像有点难度(如果要优化算法的话, 直接穷举确实容易倒是, 就是浪费计算资源, 模仿自然温度扩散写个循环吧)
! 基本路线原则如下:
! 1. 计算前进方向一格周围的格子情况, 以确定下一次前进方向, 并累计前进次数
! 1.1 当前进次数为0时, 朝方向1前进1格, 前进次数+1,
! 1.2 当前进次数大于1时:
! 1.2.1 检测前进方向格子状态
! 1.2.1.1 如果为0(未计算), 前进一格, 并检测 优先侧方向 格子状态
! 1.2.1.1.1 如果为0(未计算), 则下次前进方向为 优先侧方向
! 1.2.1.1.2 如果为1(已计算)或-1(固定值), 检测 前进方向 格子状态
! 1.2.1.1.2.1 如果为0(未计算), 则下次前进方向为 当前方向
! 1.2.1.1.2.2 如果为1(已计算)或-1(固定值). 检测 非优先侧方向
! 1.2.1.1.2.2.1 如果为0(未计算), 则下次前进方向为 非优先侧方向
! 1.2.1.1.2.2.2 如果为1(已计算)或-1(固定值), 这时候无路可走, 检测所有格子状态
! 1.2.1.1.2.2.2.1 所有格子为1, 检测此次迭代计算结果
! 1.2.1.1.2.2.2.1.1 符合条件, 退出
! 1.2.1.1.2.2.2.1.1 不符合条件, 初始化检测状态, 进行下一次循环
! 1.2.1.1.2.2.2.2 存在格子不为1, 选定可选位置中
! 1.2.1.2 如果为1(已计算或固定值)
! 突然发现越来越复杂了, 舍弃这种思路
! 按照距离优先计算, 优先计算离热源近的方块, 但问题是这样只能适应单热源的部分, 无法计算多热源(说得好像之前那种就能计算多热源了)
! 为了处理多热源的问题, 引入时序步进的想法, 假定热量传递速度相同
! 这样就是多热源画同样的同心圆, 在此范围内未被计算过的方块会被标记为2
! 对标记为2的方块进行统计, 周围被标记为0的格子数为2的, 被标记为3
! 优先计算标记为2的方块, 再计算标记为3的方块
! 步进计算, 直到无方块被标记
! 从距离的角度, 选取欧式距离似乎最为合适, 选取曼哈顿距离则计算最为简单, 最终还是选取了欧式距离
! 有时候感觉自己就是个ZZ, 直接算出来每个点的距离, 然后排序计算不就好了, 干嘛费那么大劲还去考虑步进每次包括的点位和点位计算顺序
subroutine Exercises8_18
implicit none
real, dimension(10, 10) :: metalPlate, metalPlateOld ! 金属盘表面温度, 及对照组
integer, dimension(63, 2) :: pointList ! 优化后的计算顺序
integer :: i, j, k ! 循环参数(什么都干的那种)
real :: temp, distense ! 用于判断是否符合要求
! 初始化计算顺序用数组
metalPlate = 0.
metalPlate(2:9, 2:9) = 1.
metalPlate(3, 8) = 0.
! 计算需要计算温度处距离热源的距离
forall (i = 2: 9, j = 2: 9, metalPlate(i, j) == 1.)
metalPlate(i, j) = (i-3)**2 + (j-8)**2
end forall
i = 0
! 输出计算顺序
do
i = i + 1
pointList(i, :) = minloc(metalPlate, mask=metalPlate>0.)
metalPlate(pointList(i, 1), pointList(i, 2)) = 0.
if (all(metalPlate == 0.)) exit
end do
! 初始化金属盘表面温度
metalPlate = 20.
metalPlate(2:9, 2:9) = 50.
metalPlate(3, 8) = 100.
j = 0
! 开始迭代计算金属盘表面温度
do
distense = 0.
do i = 1, size(pointList, 1)
temp = metalPlate(pointList(i, 1), pointList(i, 2))
metalPlate(pointList(i, 1), pointList(i, 2)) = (metalPlate(pointList(i, 1)+1, pointList(i, 2)) + &
&metalPlate(pointList(i, 1), pointList(i, 2)+1) + metalPlate(pointList(i, 1)-1, pointList(i, 2)) &
&+ metalPlate(pointList(i, 1), pointList(i, 2)-1))/4.
if (abs(temp-metalPlate(pointList(i, 1), pointList(i, 2))) > distense)&
& distense = abs(temp-metalPlate(pointList(i, 1), pointList(i, 2)))
end do
if (distense < 0.01) exit
j = j + 1
end do
write(*, '(" 共经历", I3, "次迭代计算")') j
write(*, *) '节点(5, 5)处稳定状态下温度为', metalPlate(5, 5)
write(*, '(" ", 10F7.2)') (metalPlate(i, :), i = 1, 10)
! 初始化金属盘表明温度
metalPlate = 20.
metalPlate(2:9, 2:9) = 50.
metalPlate(3, 8) = 100.
k = 0
! 开始迭代计算金属盘表面温度
do
metalPlateOld = metalPlate
forall(i = 1:10, j = 1:10, metalPlate(i, j) /= 20. .and. metalPlate(i, j) /= 100.)
metalPlate(i, j) = (metalPlate(i+1, j) + metalPlate(i, j+1) + metalPlate(i-1, j) + metalPlate(i, j-1))/4.
end forall
k = k + 1
if (all(abs(metalPlate-metalPlateOld) < 0.01)) exit
end do
write(*, '(" 共经历", I3, "次迭代计算")') k
write(*, *) '节点(5, 5)处稳定状态下温度为', metalPlate(5, 5)
write(*, '(" ", 10F7.2)') (metalPlate(i, :), i = 1, 10)
end subroutine Exercises8_18

796
第9章习题.f90 Normal file
View File

@ -0,0 +1,796 @@
! ==============================================================================
! 通过 gfortran ./test.f90 -o ./run && ./run 运行
! 程序名：
! 第9章习题，及书上例题
! 目的:
!
! 修订记录:
! 日期 编程者 改动描述
! =================== ============= =====================================
! 2021-05-06 18:56:24 Sola 例9-1 模仿正常的上三角解法
! 2021-05-07 00:20:30 Sola 例9-1 高斯-亚当消元法(书上解法确实好)
! 2021-05-07 17:48:03 Sola 习题9-4 判断程序正误
! 2021-05-07 18:00:54 Sola 习题9-5 判断输出结果，跳过
! 2021-05-07 19:17:23 Sola 习题9-6 矩阵乘法子程序, 显式结构
! 2021-05-07 19:17:53 Sola 习题9-7 矩阵乘法子程序, 显式接口不定结构
! 2021-05-07 19:20:11 Sola 习题9-8 用不定结构形参数组修改例9-1
! 2021-05-07 20:22:22 Sola 习题9-9 测试图9-6的子程序
! 2021-05-07 21:42:49 Sola 习题9-11 测试程序运行
! 2021-05-07 21:59:54 Sola 习题9-12 修改测试程序
! 2021-05-07 22:16:18 Sola 习题9-13 模拟掷色子
! 2021-05-08 13:02:55 Sola 习题9-14 创建逐元过程运算
! 2021-05-08 14:59:48 Sola 习题9-15 将9-14换成pure纯函数
! 2021-05-09 00:52:48 Sola 习题9-16 高阶最小二乘回归
! 2021-05-09 13:49:16 Sola 习题9-17 噪声值对拟合结果的影响
! 2021-05-09 14:36:52 Sola 习题9-18 任意高阶最小二乘回归（9-16直接写了，跳过）
! 2021-05-09 14:38:55 Sola 习题9-19 4阶最小二乘回归噪声影响
! 2021-05-09 15:12:56 Sola 习题9-20 利用高阶最小二乘回归进行插值处理
! 2021-05-09 15:24:01 Sola 习题9-21 推理，推理范围外的值
! 程序结构:
!
! ==============================================================================
! 模块：
module Chapter9
implicit none
! 数据字典
! 声明常数
REAL, PARAMETER :: PI=3.14159265 ! PI值
REAL, PARAMETER :: e=2.718281828459 ! 自然对数
INTEGER, PARAMETER :: arrayLength=20 ! 数组基准长度
! Example 9-1
! real, dimension(:), allocatable :: arrayX
! read, dimension(:, :), allocatable :: N
integer :: m, n
! 声明变量
! 创建显式接口
contains
! subroutine SubName(varName1,varName2)
! implicit none
! ! 数据字典
! end subroutine SubName
! 上三角消元法
! subroutine UpperTriangleElimination(matrixInput, arrayX, m, n)
! implicit none
! integer, intent(in) :: m, n ! 矩阵大小与X解向量长度
! real, dimension(m, m+1), intent(inout) :: matrixInput ! 输入矩阵(输入)
! real, dimension(n), intent(inout) :: arrayX ! 解向量(输入输出)
! real, dimension(m+1) :: matrixTemp ! 临时向量, 用于矩阵行交换
! integer :: i ! 局部变量: 循环参数
! if ( m /= 1 ) then ! 如果矩阵行数不为1
! if ( abs(matrixInput(1, 1)) < 1.0E-30 ) then ! 如果矩阵首位为0
! do i = 2, m ! 从其余行选择不为0的交换
! if ( abs(matrixInput(i, 1)) >= 1.0E-30 ) then
! matrixTemp = matrixInput(i, :)
! matrixInput(i, :) = matrixInput(1, :)
! matrixInput(1, :) = matrixTemp
! exit
! end if
! end do
! end if
! matrixInput(1, :) = matrixInput(1, :)/matrixInput(1, 1) ! 单位化矩阵第一行
! do i = 2, m ! 消去其他行所有第一列的系数
! matrixInput(i, :) = matrixInput(i, :) - matrixInput(1, :)*matrixInput(i, 1)
! end do
! if ( all(matrixInput(2:m, 2) == 0) ) then ! 检查第二列第二行到最后一行不为0
! stop "输入矩阵不满秩，无法求解" ! 如果为0, 则输入矩阵不满秩, 无解
! else
! call GaussAdamElimination(matrixInput(2:m, 2:m+1), arrayX, m-1, n) ! 递归调用自身
! end if
! arrayX(n-m+1) = matrixInput(1, m+1) - matrixInput(1, 2:m)*arrayX(n-m+2:n) ! 计算当前位X值
! else
! arrayX(n) = matrixInput(1, m+1)/matrixInput(1, 1) ! 如果矩阵行数为1, 直接计算当前位X值
! end if
! end subroutine UpperTriangleElimination
! 高斯亚当消元法 会破坏输入数组
subroutine GaussAdamElimination(matrixInput, m, arrayX, maxLimit, error)
implicit none
integer, intent(in) :: m ! 输入的方程组数量
integer, intent(in) :: maxLimit ! 矩阵大小与X解向量长度
real, dimension(maxLimit, maxLimit), intent(inout) :: matrixInput ! 输入矩阵(输入)
real, dimension(maxLimit), intent(inout) :: arrayX ! 输入常数向量, 输出X解向量
integer, intent(out) :: error ! 错误值
real :: temp ! 临时值, 用于数值交换
integer :: maxLocate ! 最大值所在行
integer :: i, n ! 局部变量: 循环参数
do n = 1, m
maxLocate = n ! 初始化绝对值最大的位置
do i = n+1, m ! 执行最大支点技术，减少舍入误差
if ( abs(matrixInput(i, n)) > abs(matrixInput(maxLocate, n)) ) then
maxLocate = i
end if
end do
if ( abs(matrixInput(maxLocate, n)) < 1.0E-30 ) then
error = 1 ! 如果绝对值最大为0, 则矩阵不满秩, 无解
return ! 退出运算
end if
if ( maxLocate /= n ) then ! 如果绝对值最大值位置发生了变化, 则交换
do i = 1, m
temp = matrixInput(maxLocate, i)
matrixInput(maxLocate, i) = matrixInput(n, i)
matrixInput(n, i) = temp
end do
temp = arrayX(maxLocate)
arrayX(maxLocate) = arrayX(n)
arrayX(n) = temp
end if
do i = 1, m ! 消去其他行所有第n列的系数
if ( i /= n ) then
temp = -matrixInput(i, n)/matrixInput(n, n) ! 这里务必要设置一个临时值保存数值, 不然会被修改
matrixInput(i, :) = matrixInput(i, :) + matrixInput(n, :)*temp
arrayX(i) = arrayX(i) + arrayX(n)*temp
end if
end do
end do
do i = 1, m ! 产生X的解向量
arrayX(i) = arrayX(i)/matrixInput(i, i)
matrixInput(i, i) = 1.
end do
error = 0
end subroutine GaussAdamElimination
end module Chapter9
! ==============================================================================
! 主程序：
program ProName
! use ModName
implicit none
! 数据字典
! 声明常量
! 声明变量
! 变量初始化
! 数据输入
! 运算过程
! 结果输出
! call Exercises9_4
! call Exercises9_6
! call Exercises9_8
! call Exercises9_9
! call Exercises9_11
! call Exercises9_12
! call Exercises9_13
! call Exercises9_14
! call Exercises9_15
! call Exercises9_16
end program ProName
! ==============================================================================
! 子程序
! subroutine SubName(varName1,varName2)
! use MouName
! implicit none
! Type, intent(inout) :: varName
! end subroutine SubName
! ==============================================================================
! 函数
! function FunName(varName1,varName2)
! use MouName
! implicit none
! end function FunName
! ==============================================================================
! 习题9-4 判断程序正误
subroutine Exercises9_4
implicit none
real :: a=3., b=4., output
integer :: i=0
call sub1(a, I, output)
write(*,*) 'The output is', output
contains
subroutine sub1(x, j, junk)
real, intent(in) :: x
integer, intent(in) :: j
real, intent(out) :: junk
junk = (x-j)/b
end subroutine sub1
end subroutine Exercises9_4
subroutine Exercises9_6
implicit none
real, dimension(:, :), allocatable :: arrayInput1, arrayInput2, arrayResult ! 输入输出矩阵
integer :: errorLevel ! 错误码
integer :: i ! 循环参数
! 9-6 a
allocate(arrayInput1(3, 3), stat=errorLevel) ! 分配数组
if (errorLevel /= 0) print *, "arrayInput1: Allocation request denied"
allocate(arrayInput2(3, 3), stat=errorLevel)
if (errorLevel /= 0) print *, "arrayInput2: Allocation request denied"
allocate(arrayResult(3, 3), stat=errorLevel)
if (errorLevel /= 0) print *, "arrayResult: Allocation request denied"
arrayInput1(1, :) = (/ 2., -1., 2./) ! 定义数组
arrayInput1(2, :) = (/-1., -3., 4./)
arrayInput1(3, :) = (/ 2., 4., 2./)
arrayInput2(1, :) = (/ 1., 2., 3./)
arrayInput2(2, :) = (/ 2., 1., 2./)
arrayInput2(3, :) = (/ 3., 2., 1./)
call MatrixMultplication(arrayInput1, 3, 3, arrayInput2, 3, 3, arrayResult, errorLevel) ! 调用子程序计算矩阵乘积
if (errorLevel /= 0) print *, "无法进行矩阵乘法"
write(*,'(3F8.2)') (arrayResult(i, :), i = 1, 3) ! 输出计算结果
arrayResult(:,:) = matmul(arrayInput1, arrayInput2) ! 调用内部函数计算矩阵乘积
write(*,'(3F8.2)') (arrayResult(i, :), i = 1, 3) ! 输出计算结果
call MatrixMul(arrayInput1, arrayInput2, arrayResult, errorLevel) ! 调用子程序计算矩阵乘积
if (errorLevel /= 0) print *, "无法进行矩阵乘法"
write(*,'(3F8.2)') (arrayResult(i, :), i = 1, 3) ! 输出计算结果
if (allocated(arrayResult)) deallocate(arrayResult, stat=errorLevel) ! 释放数组
if (errorLevel /= 0) print *, "arrayResult: Deallocation request denied"
if (allocated(arrayInput2)) deallocate(arrayInput2, stat=errorLevel)
if (errorLevel /= 0) print *, "arrayInput2: Deallocation request denied"
if (allocated(arrayInput1)) deallocate(arrayInput1, stat=errorLevel)
if (errorLevel /= 0) print *, "arrayInput1: Deallocation request denied"
! 9-6 b
allocate(arrayInput1(4, 3), stat=errorLevel) ! 分配数组
if (errorLevel /= 0) print *, "arrayInput1: Allocation request denied"
allocate(arrayInput2(3, 1), stat=errorLevel)
if (errorLevel /= 0) print *, "arrayInput2: Allocation request denied"
allocate(arrayResult(4, 1), stat=errorLevel)
if (errorLevel /= 0) print *, "arrayResult: Allocation request denied"
arrayInput1(1, :) = (/ 1., -1., -2./) ! 定义数组
arrayInput1(2, :) = (/ 2., 2., 0./)
arrayInput1(3, :) = (/ 3., 3., 3./)
arrayInput1(4, :) = (/ 5., 4., 4./)
arrayInput2(:, 1) = (/-2., 5., 2./)
call MatrixMultplication(arrayInput1, 4, 3, arrayInput2, 3, 1, arrayResult, errorLevel) ! 调用子程序计算矩阵乘积
if (errorLevel /= 0) print *, "无法进行矩阵乘法"
write(*,'(F8.2)') (arrayResult(i, :), i = 1, 4) ! 输出计算结果
arrayResult(:,:) = matmul(arrayInput1, arrayInput2) ! 调用内部函数计算矩阵乘积
write(*,'(F8.2)') (arrayResult(i, :), i = 1, 4) ! 输出计算结果
call MatrixMul(arrayInput1, arrayInput2, arrayResult, errorLevel) ! 调用子程序计算矩阵乘积
if (errorLevel /= 0) print *, "无法进行矩阵乘法"
write(*,'(F8.2)') (arrayResult(i, :), i = 1, 4) ! 输出计算结果
if (allocated(arrayResult)) deallocate(arrayResult, stat=errorLevel) ! 释放数组
if (errorLevel /= 0) print *, "arrayResult: Deallocation request denied"
if (allocated(arrayInput2)) deallocate(arrayInput2, stat=errorLevel)
if (errorLevel /= 0) print *, "arrayInput2: Deallocation request denied"
if (allocated(arrayInput1)) deallocate(arrayInput1, stat=errorLevel)
if (errorLevel /= 0) print *, "arrayInput1: Deallocation request denied"
contains
! 矩阵乘法子程序, 显式结构
subroutine MatrixMultplication(array1, x1, y1, array2, x2, y2, array3, errorLevel)
integer, intent(in) :: x1, y1, x2, y2 ! 矩阵大小
real, dimension(x1, y1), intent(in) :: array1 ! 矩阵1
real, dimension(x2, y2), intent(in) :: array2 ! 矩阵2
real, dimension(x1, y2), intent(out) :: array3 ! 输出矩阵
integer, intent(out) :: errorLevel ! 错误代码
integer :: i, j, k ! 循环参数
if ( y1 /= x2 ) then ! 判断乘法是否可行
errorLevel = 1 ! 不可行, 错误码=1
return ! 退出
end if
array3 = 0. ! 初始化输出矩阵
! forall(i = 1:x1, j = 1:y1, k = 1:y2) ! forall结构计算
! array3(i, k) = array1(i, j)*array2(j, k) + array3(i, k)
! end forall
do i = 1, x1 ! do嵌套计算
do j = 1, y1
do k = 1, y2
array3(i, k) = array1(i, j)*array2(j, k) + array3(i, k)
end do
end do
end do
errorLevel = 0 ! 运算完成, 错误码=0
end subroutine MatrixMultplication
! 矩阵乘法子程序, 显式接口不定结构
subroutine MatrixMul(array1, array2, array3, errorLevel)
real, dimension(:, :), intent(in) :: array1 ! 矩阵1
real, dimension(:, :), intent(in) :: array2 ! 矩阵2
real, dimension(:, :), intent(out) :: array3 ! 输出矩阵
integer, intent(out) :: errorLevel ! 错误代码
integer :: i, j, k ! 循环参数
if ( size(array1, 2) /= size(array2, 1) ) then ! 判断乘法是否可行
errorLevel = 1 ! 不可行, 错误码=1
return ! 退出
end if
array3 = 0. ! 初始化输出矩阵
! forall(i = 1:x1, j = 1:y1, k = 1:y2) ! forall结构计算
! array3(i, k) = array1(i, j)*array2(j, k) + array3(i, k)
! end forall
do i = 1, size(array1, 1) ! do嵌套计算
do j = 1, size(array1, 2)
do k = 1, size(array2, 2)
array3(i, k) = array1(i, j)*array2(j, k) + array3(i, k)
end do
end do
end do
errorLevel = 0 ! 运算完成, 错误码=0
end subroutine MatrixMul
end subroutine Exercises9_6
! 习题9-8
subroutine Exercises9_8
implicit none
real, dimension(3, 3) :: arrayInput1, arrayInput2 ! 输入矩阵
real, dimension(3) :: arrayX1, arrayX2 ! 常数向量
integer :: errorLevel ! 错误码
integer :: i ! 循环参数
arrayInput1(1, :) = (/ 1.0, 1.0, 1.0/) ! 输入数据1
arrayInput1(2, :) = (/ 2.0, 1.0, 1.0/)
arrayInput1(3, :) = (/ 1.0, 3.0, 2.0/)
arrayX1(:) = (/ 1.0, 2.0, 4.0/)
arrayInput2(1, :) = (/ 1.0, 1.0, 1.0/) ! 输入数据2
arrayInput2(2, :) = (/ 2.0, 6.0, 4.0/)
arrayInput2(3, :) = (/ 1.0, 3.0, 2.0/)
arrayX2(:) = (/ 1.0, 8.0, 4.0/)
call GAEli(arrayInput1, arrayX1, errorLevel) ! 调用子程序解方程组
if (errorLevel /= 0) then
write(*,*) 'Error!' ! 如果无解, 输出错误
else
write(*,'(4F8.2)') (arrayInput1(i, :), arrayX1(i), i = 1, 3) ! 如果有解, 输出计算后的矩阵
end if
call GAEli(arrayInput2, arrayX2, errorLevel) ! 调用子程序解方程组
if (errorLevel /= 0) then
write(*,*) 'Error!' ! 如果无解, 输出错误
else
write(*,'(4F8.2)') (arrayInput2(i, :), arrayX2(i), i = 1, 3) ! 如果有解, 输出计算后的矩阵
end if
contains
! 高斯亚当消元法, 不定结构, 破坏输入矩阵
subroutine GAEli(matrixInput, arrayX, errorLevel)
implicit none
real, dimension(:, :), intent(inout) :: matrixInput ! 输入矩阵(输入)
real, dimension(:), intent(inout) :: arrayX ! 输入常数向量, 输出X解向量
integer, intent(out) :: errorLevel ! 错误值
real :: temp ! 临时值, 用于数值交换
integer :: maxLocate ! 最大值所在行
integer :: i, n, m ! 局部变量: 循环参数
m = size(matrixInput, 1)
do n = 1, m
maxLocate = n ! 初始化绝对值最大的位置
do i = n+1, m ! 执行最大支点技术，减少舍入误差
if ( abs(matrixInput(i, n)) > abs(matrixInput(maxLocate, n)) ) then
maxLocate = i
end if
end do
if ( abs(matrixInput(maxLocate, n)) < 1.0E-30 ) then
errorLevel = 1 ! 如果绝对值最大为0, 则矩阵不满秩, 无解
return ! 退出运算
end if
if ( maxLocate /= n ) then ! 如果绝对值最大值位置发生了变化, 则交换
do i = 1, m
temp = matrixInput(maxLocate, i)
matrixInput(maxLocate, i) = matrixInput(n, i)
matrixInput(n, i) = temp
end do
temp = arrayX(maxLocate)
arrayX(maxLocate) = arrayX(n)
arrayX(n) = temp
end if
do i = 1, m ! 消去其他行所有第n列的系数
if ( i /= n ) then
temp = -matrixInput(i, n)/matrixInput(n, n) ! 这里务必要设置一个临时值保存数值, 不然会被修改
matrixInput(i, :) = matrixInput(i, :) + matrixInput(n, :)*temp
arrayX(i) = arrayX(i) + arrayX(n)*temp
end if
end do
end do
do i = 1, m ! 产生X的解向量
arrayX(i) = arrayX(i)/matrixInput(i, i)
matrixInput(i, i) = 1.
end do
errorLevel = 0
end subroutine GAEli
end subroutine Exercises9_8
! 习题9-8
subroutine Exercises9_9
implicit none
real, dimension(3, 3) :: arrayInput1, arrayInput2 ! 输入矩阵
real, dimension(3) :: arrayX1, arrayX2 ! 常数向量
integer :: errorLevel ! 错误码
integer :: i ! 循环参数
arrayInput1(1, :) = (/ 1.0, 1.0, 1.0/) ! 输入数据1
arrayInput1(2, :) = (/ 2.0, 1.0, 1.0/)
arrayInput1(3, :) = (/ 1.0, 3.0, 2.0/)
arrayX1(:) = (/ 1.0, 2.0, 4.0/)
arrayInput2(1, :) = (/ 1.0, 1.0, 1.0/) ! 输入数据2
arrayInput2(2, :) = (/ 2.0, 6.0, 4.0/)
arrayInput2(3, :) = (/ 1.0, 3.0, 2.0/)
arrayX2(:) = (/ 1.0, 8.0, 4.0/)
call GAEli1(arrayInput1, arrayX1, errorLevel) ! 调用子程序解方程组
if (errorLevel /= 0) then
write(*,*) 'Error!' ! 如果无解, 输出错误
else
write(*,'(A, I1, A, F6.2)') ('x', i, ' = ', arrayX1(i), i = 1, 3) ! 如果有解, 输出各解
end if
call GAEli1(arrayInput2, arrayX2, errorLevel) ! 调用子程序解方程组
if (errorLevel /= 0) then
write(*,*) 'Error!' ! 如果无解, 输出错误
else
write(*,'(A, I1, F6.2)') ('x', i, ' = ', arrayX2(i), i = 1, 3) ! 如果有解, 输出各解
end if
contains
! 高斯-亚当消元法，不破坏输入矩阵
subroutine GAEli1(matrixInput1, arrayX, errorLevel)
implicit none
real, dimension(:, :), intent(inout) :: matrixInput1 ! 输入矩阵(输入)
real, dimension(size(matrixInput1, 1), size(matrixInput1, 2)) :: matrixInput
! 运算矩阵
real, dimension(:), intent(inout) :: arrayX ! 输入常数向量, 输出X解向量
integer, intent(out) :: errorLevel ! 错误值
real :: temp ! 临时值, 用于数值交换
integer :: maxLocate ! 最大值所在行
integer :: i, n, m ! 局部变量: 循环参数
matrixInput = matrixInput1
m = size(matrixInput, 1)
do n = 1, m
maxLocate = n ! 初始化绝对值最大的位置
do i = n+1, m ! 执行最大支点技术，减少舍入误差
if ( abs(matrixInput(i, n)) > abs(matrixInput(maxLocate, n)) ) then
maxLocate = i
end if
end do
if ( abs(matrixInput(maxLocate, n)) < 1.0E-30 ) then
errorLevel = 1 ! 如果绝对值最大为0, 则矩阵不满秩, 无解
return ! 退出运算
end if
if ( maxLocate /= n ) then ! 如果绝对值最大值位置发生了变化, 则交换
do i = 1, m
temp = matrixInput(maxLocate, i)
matrixInput(maxLocate, i) = matrixInput(n, i)
matrixInput(n, i) = temp
end do
temp = arrayX(maxLocate)
arrayX(maxLocate) = arrayX(n)
arrayX(n) = temp
end if
do i = 1, m ! 消去其他行所有第n列的系数
if ( i /= n ) then
temp = -matrixInput(i, n)/matrixInput(n, n) ! 这里务必要设置一个临时值保存数值, 不然会被修改
matrixInput(i, :) = matrixInput(i, :) + matrixInput(n, :)*temp
arrayX(i) = arrayX(i) + arrayX(n)*temp
end if
end do
end do
do i = 1, m ! 产生X的解向量
arrayX(i) = arrayX(i)/matrixInput(i, i)
matrixInput(i, i) = 1.
end do
errorLevel = 0
end subroutine GAEli1
end subroutine Exercises9_9
! 习题9-11 9-12
subroutine Exercises9_11
implicit none
real, allocatable, dimension(:) :: a
integer :: istat
allocate(a(6), stat=istat)
a = (/ 1., 2., 3., 4., 5., 6./)
write(*,'(A, 6F4.1)') 'Main: Array a before call = ', a
call test_alloc(a)
write(*,'(A, 6F4.1)') 'Main: Array a after call = ', a
contains
subroutine test_alloc(array)
real, dimension(:), allocatable, intent(inout) :: array
integer :: i
integer :: istat
if (allocated(array)) then
write(*,'(A)') 'Sub: the array is allocated'
write(*,'(A, 6F4.1)') 'Sub: Array on entry = ', array
else
write(*,*) 'In sub: the array is not allocated'
end if
if (allocated(array)) then
deallocate(array, stat=istat)
end if
allocate(array(5), stat=istat)
do i = 1, 5
array(i) = 6 - i
end do
write(*,'(A, 6F4.1)') 'Sub: Array on exit = ', array
end subroutine test_alloc
end subroutine Exercises9_11
! 习题9-13 掷色子
subroutine Exercises9_13
implicit none
integer :: x, y ! 定义俩变量
call throw(x, y) ! 获取俩随机值
write(*,*) x, y ! 打印
contains
subroutine throw(random1, random2) ! out属性形参可以作为参数传递给过程
integer, intent(out) :: random1, random2 ! 定义俩变量储存随机数
call die(random1) ! 获取第一个随机数
call die(random2) ! 获取第二个随机数
end subroutine throw
subroutine die(random)
integer, intent(out) :: random ! 定义随机整数
real :: temp ! 随机数临时值
call random_seed() ! 根据时间日期获取随机数种子
call random_number(temp) ! 获取一个[0,1)的随机数给临时值
random = int(temp*6) + 1 ! 变化其区间为[1,7), 并向下取整
end subroutine die
end subroutine Exercises9_13
! 创建逐元过程运算, 这种过程内函数, 直接在函数体写定义, 调用部分可以不考虑
subroutine Exercises9_14
implicit none
real, parameter :: PI=3.14159265 ! PI值
real, dimension(2, 3) :: array1, array2, array3 ! 计算用数组
integer :: i ! 循环参数
array1(1, :) = (/ 10.0, 20.0, 30.0/) ! 定义输入数组
array1(2, :) = (/ 40.0, 50.0, 60.0/)
array2 = FunSin(array1) ! 计算值
write(*,1) '计算得到正弦值为:', (array2(i, :), i = 1, 2) ! 输出计算值, 以下相同
array3 = FunAsin(array2)
write(*,1) '计算得到反正弦值为:', (array3(i, :), i = 1, 2)
array2 = FunCos(array1)
write(*,1) '计算得到余弦值为:', (array2(i, :), i = 1, 2)
array3 = FunAcos(array2)
write(*,1) '计算得到反余弦值为:', (array3(i, :), i = 1, 2)
array2 = FunTan(array1)
write(*,1) '计算得到正切为:', (array2(i, :), i = 1, 2)
array3 = FunAtan(array2)
write(*,1) '计算得到反正切为:', (array3(i, :), i = 1, 2)
1 format(1X, A,/& ! 输出格式
&1X, 3F8.2,/&
&1X, 3F8.2)
contains
elemental function FunSin(degree) ! 定义函数
real, intent(in) :: degree ! 定义输入变量
real :: FunSin ! 定义函数输出类型
FunSin = sin(degree/360.*2*PI) ! 计算输出值, 以下相同
end function FunSin
elemental function FunCos(degree)
real, intent(in) :: degree
real :: FunCos
FunCos = cos(degree/360.*2*PI)
end function FunCos
elemental function FunTan(degree)
real, intent(in) :: degree
real :: FunTan
FunTan = tan(degree/360.*2*PI)
end function FunTan
elemental function FunAsin(value)
real, intent(in) :: value
real :: FunAsin
FunAsin = asin(value)*360./(2.*PI)
end function FunAsin
elemental function FunAcos(value)
real, intent(in) :: value
real :: FunAcos
FunAcos = acos(value)*360./(2.*PI)
end function FunAcos
elemental function FunAtan(value)
real, intent(in) :: value
real :: FunAtan
FunAtan = atan(value)*360./(2.*PI)
end function FunAtan
end subroutine Exercises9_14
! 习题9-15 将9-14的内容修改为纯函数
subroutine Exercises9_15
implicit none
real, parameter :: PI=3.14159265 ! PI值
real, dimension(2, 3) :: array1, array2, array3 ! 计算用数组
integer :: i ! 循环参数
array1(1, :) = (/ 10.0, 20.0, 30.0/) ! 定义输入数组
array1(2, :) = (/ 40.0, 50.0, 60.0/)
array2 = FunSin(array1) ! 计算值
write(*,1) '计算得到正弦值为:', (array2(i, :), i = 1, 2) ! 输出计算值, 以下相同
array3 = FunAsin(array2)
write(*,1) '计算得到反正弦值为:', (array3(i, :), i = 1, 2)
array2 = FunCos(array1)
write(*,1) '计算得到余弦值为:', (array2(i, :), i = 1, 2)
array3 = FunAcos(array2)
write(*,1) '计算得到反余弦值为:', (array3(i, :), i = 1, 2)
array2 = FunTan(array1)
write(*,1) '计算得到正切为:', (array2(i, :), i = 1, 2)
array3 = FunAtan(array2)
write(*,1) '计算得到反正切为:', (array3(i, :), i = 1, 2)
1 format(1X, A,/& ! 输出格式
&1X, 3F8.2,/&
&1X, 3F8.2)
contains
pure function FunSin(degree)
real, intent(in), dimension(:, :) :: degree
real, dimension(size(degree, 1), size(degree, 2)) :: FunSin
FunSin = sin(degree/360.*2*PI)
end function FunSin
pure function FunCos(degree)
real, intent(in), dimension(:, :) :: degree
real, dimension(size(degree, 1), size(degree, 2)) :: FunCos
FunCos = cos(degree/360.*2*PI)
end function FunCos
pure function FunTan(degree)
real, intent(in), dimension(:, :) :: degree
real, dimension(size(degree, 1), size(degree, 2)) :: FunTan
FunTan = tan(degree/360.*2*PI)
end function FunTan
pure function FunAsin(value)
real, intent(in), dimension(:, :) :: value
real, dimension(size(value, 1), size(value, 2)) :: FunAsin
FunAsin = asin(value)*360./(2.*PI)
end function FunAsin
pure function FunAcos(value)
real, intent(in), dimension(:, :) :: value
real, dimension(size(value, 1), size(value, 2)) :: FunAcos
FunAcos = acos(value)*360./(2.*PI)
end function FunAcos
pure function FunAtan(value)
real, intent(in), dimension(:, :) :: value
real, dimension(size(value, 1), size(value, 2)) :: FunAtan
FunAtan = atan(value)*360./(2.*PI)
end function FunAtan
end subroutine Exercises9_15
! 习题9-16 高阶最小二乘回归 首先第一个，发现了解多元一次方程组程序的错误，第二，发现了总之，很多很多错误，很有意义的一道题
subroutine Exercises9_16
implicit none
real, dimension(:), allocatable :: pointX, pointY ! 坐标(x, y)
real, dimension(:), allocatable :: arrayCoefficient ! 系数向量
integer :: errorLevel ! 错误码
integer :: i ! 循环参数
real :: temp
open(unit=1, status='scratch', iostat=errorLevel) ! 打开临时文件
if ( errorLevel /= 0 ) stop "打开临时文件失败" ! 判断打开状态
write(1, '(A)') & ! 输入数据
&' 0.167, 0.333, 0.500, 0.667, 0.833, 1.000, 1.167, 1.333, 1.500&
&, 1.667, 1.833, 2.000, 2.167, 2.333, 2.500, 2.667, 2.833, 3.000',&
&' 49.9, 52.2, 50.6, 47.0, 47.7, 42.3, 37.9, 38.2, 38.0, 33.8, 26.7, 24.8, 22.0, 16.5, 14.0, 5.6, 2.9, 0.8',&
&' -5.1,-12.9,-15.1, -6.8,-12.3,-18.0, -5.7, -6.3,-12.7,-13.7,-26.7,-31.3,-22.9,-25.6,-25.7,-25.2,-35.0,-27.9'
rewind(unit=1, iostat=errorLevel) ! 回到初始行
if ( errorLevel /= 0 ) stop "读取临时文件失败" ! 判断执行状态
allocate(pointX(18), stat=errorLevel) ! 分配数组
if (errorLevel /= 0) print *, "pointX: Allocation request denied" ! 判断分配结果, 下同
allocate(pointY(18), stat=errorLevel)
if (errorLevel /= 0) print *, "pointY: Allocation request denied"
allocate(arrayCoefficient(3), stat=errorLevel)
if (errorLevel /= 0) print *, "arrayCoefficient: Allocation request denied"
read(1, *) pointX, pointY ! 读取数据
close(unit=1, iostat=errorLevel) ! 关闭临时文件
if ( errorLevel /= 0 ) stop "关闭临时文件失败" ! 判断关闭状态
! write(*,'(18(F8.2, 1X))') pointX, pointY ! 输出读入值(供检验, 可注释)
call MultipleRegression(pointX, pointY, arrayCoefficient, 2, errorLevel) ! 计算参数值
write(*,*) '习题9-16'
write(*,1) arrayCoefficient ! 输出结果
1 format(1X, '(?) 计算得到的方程为：h = ', F8.2, ' + ', F8.2, ' t + ', F8.2, ' t^2')
! 习题9-17
write(*,*) '习题9-17'
call ShowNoise2( 0.0, 0.0, '(a)')
call ShowNoise2(-0.1, 0.1, '(b)')
call ShowNoise2(-0.5, 0.5, '(c)')
call ShowNoise2(-1.0, 1.0, '(d)')
! 习题9-19
write(*,*) '习题9-19'
arrayCoefficient = (/0.0, 0.0, 0.0, 0.0, 0.0/) ! 重定义系数向量长度
call ShowNoise4( 0.0, 0.0, '(a)')
call ShowNoise4(-0.1, 0.1, '(b)')
call ShowNoise4(-0.5, 0.5, '(c)')
call ShowNoise4(-1.0, 1.0, '(d)')
! 习题9-20
write(*,*) '习题9-20'
open(unit=1, status='scratch', iostat=errorLevel) ! 打开临时文件
if ( errorLevel /= 0 ) stop "打开临时文件失败" ! 判断打开状态
write(1, '(A)') & ! 输入数据
&' 0.00, 1.00, 2.00, 3.00, 4.00, 5.00, 6.00, 7.00, 8.00, 9.00, 10.00',&
&'-23.22,-13.54, -4.14, -0.04, 3.92, 4.97, 3.96, -0.07, -5.67,-12.28,-20.25'
rewind(unit=1, iostat=errorLevel) ! 回到初始行
if ( errorLevel /= 0 ) stop "关闭临时文件失败" ! 判断关闭状态
pointX = (/(i, i = 1, 10)/) ! 重定义坐标x向量长度
pointY = pointX ! 重定义坐标y向量长度
read(1,*) pointX, pointY ! 赋值坐标(x, y)
close(unit=1, iostat=errorLevel) ! 关闭临时文件
arrayCoefficient = (/0.0, 0.0, 0.0/) ! 重定义系数向量长度
call MultipleRegression(pointX, pointY, arrayCoefficient, 2, errorLevel) ! 计算参数值
write(*,4) arrayCoefficient ! 输出结果
4 format(1X, '(?) 计算得到的方程为：y = ', F8.2, ' + ', F8.2, ' x + ', F8.2, ' x^2')
write(*,*) ' 当x0取3.5时，得到y0 = ', arrayCoefficient(1) + arrayCoefficient(2)*3.5 + arrayCoefficient(3)*3.5**2
! 习题9-21
write(*,*) '习题9-21'
open(unit=1, status='scratch', iostat=errorLevel) ! 打开临时文件
if ( errorLevel /= 0 ) stop "打开临时文件失败" ! 判断打开状态
write(1, '(A)') & ! 输入数据
&' 0.00, 1.00, 2.00, 3.00, 4.00, 5.00, 6.00, 7.00, 8.00, 9.00, 10.00',&
&'-14.22,-10.54, -5.09, -3.12, 0.92, 3.79, 6.99, 8.95, 11.33, 14.71, 18.75'
rewind(unit=1, iostat=errorLevel) ! 回到初始行
if ( errorLevel /= 0 ) stop "关闭临时文件失败" ! 判断关闭状态
pointX = (/(i, i = 1, 10)/) ! 重定义坐标x向量长度
pointY = pointX ! 重定义坐标y向量长度
read(1,*) pointX, pointY ! 赋值坐标(x, y)
close(unit=1, iostat=errorLevel) ! 关闭临时文件
arrayCoefficient = (/0.0, 0.0, 0.0/) ! 重定义系数向量长度
call MultipleRegression(pointX, pointY, arrayCoefficient, 2, errorLevel) ! 计算参数值
write(*,4) arrayCoefficient ! 输出结果
write(*,*) ' 当x0取14.0时，得到y0 = ', arrayCoefficient(1) + arrayCoefficient(2)*14.0 + arrayCoefficient(3)*14.0**2
if ( errorLevel /= 0 ) stop "读取临时文件失败" ! 判断执行状态
if (allocated(arrayCoefficient)) deallocate(arrayCoefficient, stat=errorLevel) ! 释放数组
if (errorLevel /= 0) print *, "arrayCoefficient: Deallocation request denied" ! 判断释放结果, 下同
if (allocated(pointY)) deallocate(pointY, stat=errorLevel)
if (errorLevel /= 0) print *, "pointY: Deallocation request denied"
if (allocated(pointX)) deallocate(pointX, stat=errorLevel)
if (errorLevel /= 0) print *, "pointX: Deallocation request denied"
contains
! 构建输入方程和解向量
subroutine MultipleRegression(arrayX, arrayY, arrayResult, order, errorLevel)
real, dimension(:), intent(in) :: arrayX, arrayY ! 输入坐标(x, y)
integer, intent(in) :: order ! 拟合阶数
real, dimension(order+1), intent(out) :: arrayResult ! 系数向量(同时也充当了常数向量)
real, dimension(order+1, order+1) :: matrixCoefficient ! 系数矩阵
integer, intent(out) :: errorLevel ! 错误码(虽然主程序中没有做错误校验就是)
integer :: i, j ! 循环参数
if ( order < 1 ) then ! 判断阶数是否符合要求
errorLevel = 1
return
else
do i = 1, order+1 ! 各参数的偏导方程
do j = 1, order+1 ! 某一参数偏导数取0时, 各系数
matrixCoefficient(i, j) = sum(arrayX**(i+j-2)) ! 给各系数赋值
end do
arrayResult(i) = sum(arrayX**(i-1)*arrayY) ! 给常数向量赋值
end do
! write(*,'(3(F8.2, 1X))') matrixCoefficient, arrayResult ! 打印系数矩阵和常数向量(共检验, 可注释)
call GAEli1(matrixCoefficient, arrayResult, errorLevel) ! 计算系数值
end if
end subroutine MultipleRegression
! 调用方程组求解子程序，高斯-亚当消元法（不破坏输入数组）
subroutine GAEli1(matrixInput1, arrayX, errorLevel)
implicit none
real, dimension(:, :), intent(inout) :: matrixInput1 ! 输入矩阵(输入)
real, dimension(size(matrixInput1, 1), size(matrixInput1, 2)) :: matrixInput
! 运算矩阵
real, dimension(:), intent(inout) :: arrayX ! 输入常数向量, 输出X解向量
integer, intent(out) :: errorLevel ! 错误值
real :: temp ! 临时值, 用于数值交换
integer :: maxLocate ! 最大值所在行
integer :: i, n, m ! 局部变量: 循环参数
matrixInput = matrixInput1
m = size(matrixInput, 1)
do n = 1, m
maxLocate = n ! 初始化绝对值最大的位置
do i = n+1, m ! 执行最大支点技术，减少舍入误差
if ( abs(matrixInput(i, n)) > abs(matrixInput(maxLocate, n)) ) then
maxLocate = i
end if
end do
if ( abs(matrixInput(maxLocate, n)) < 1.0E-30 ) then
errorLevel = 1 ! 如果绝对值最大为0, 则矩阵不满秩, 无解
return ! 退出运算
end if
if ( maxLocate /= n ) then ! 如果绝对值最大值位置发生了变化, 则交换
do i = 1, m
temp = matrixInput(maxLocate, i)
matrixInput(maxLocate, i) = matrixInput(n, i)
matrixInput(n, i) = temp
end do
temp = arrayX(maxLocate)
arrayX(maxLocate) = arrayX(n)
arrayX(n) = temp
end if
do i = 1, m ! 消去其他行所有第n列的系数
if ( i /= n ) then
temp = -matrixInput(i, n)/matrixInput(n, n) ! 这里务必要设置一个临时值保存数值, 不然会被修改
matrixInput(i, :) = matrixInput(i, :) + matrixInput(n, :)*temp
arrayX(i) = arrayX(i) + arrayX(n)*temp
end if
end do
end do
do i = 1, m ! 产生X的解向量
arrayX(i) = arrayX(i)/matrixInput(i, i)
matrixInput(i, i) = 1.
end do
errorLevel = 0
end subroutine GAEli1
! 用于产生噪声值
subroutine Noise(value, lowerBound, upperBound)
real, intent(out) :: value ! 输出的随机数值
real, intent(in) :: lowerBound, upperBound ! 输出随机数值的上下界, 范围是[lowerBound, upperBound)
call random_seed() ! 根据当前时间日期计算随机数种子
call random_number(value) ! 计算随机数
value = lowerBound + value*( upperBound - lowerBound ) ! 重分布以适应范围
end subroutine Noise
! 用于计算习题9-17, 这里采用的是二阶回归
subroutine ShowNoise2(lowerBound, upperBound, tag)
real, intent(in) :: lowerBound, upperBound ! 噪声值上下界
character(len=3), intent(in) :: tag ! 当前题目标识符
pointX = (/0.0, 1.0, 2.0, 3.0, 4.0, 5.0/) ! 赋值坐标x
do i = 1, 6
call Noise(temp, lowerBound, upperBound) ! 产生噪声值
pointY(i) = pointX(i)**2 - 4*pointX(i) + 3 + temp ! 赋值坐标y
end do
call MultipleRegression(pointX, pointY, arrayCoefficient, 2, errorLevel)! 计算参数值
write(*,2) trim(tag), arrayCoefficient ! 输出结果
2 format(1X, A,' 计算得到的方程为：h = ', F8.2, ' + ', F8.2, ' t + ', F8.2, ' t^2')
end subroutine ShowNoise2
! 用于计算习题9-19, 这里采用的是四阶回归
subroutine ShowNoise4(lowerBound, upperBound, tag)
real, intent(in) :: lowerBound, upperBound ! 噪声值上下界
character(len=3), intent(in) :: tag ! 当前题目标识符
pointX = (/0.0, 1.0, 2.0, 3.0, 4.0, 5.0/) ! 赋值坐标x
do i = 1, 6
call Noise(temp, lowerBound, upperBound) ! 产生噪声值
pointY(i) = pointX(i)**4 - 3*pointX(i)**3 - 4*pointX(i)**2 + 2*pointX(i) + 3 + temp
end do ! 赋值坐标y
call MultipleRegression(pointX, pointY, arrayCoefficient, 4, errorLevel)! 计算参数值
write(*,3) trim(tag), arrayCoefficient ! 输出结果
3 format(1X, A,' 计算得到的方程为：h = ', F8.2, ' + ', F8.2, ' t + ', F8.2,&
& ' t^2 + ', F8.2, ' t^3 + ', F8.2, ' t^4')
end subroutine ShowNoise4
end subroutine Exercises9_16