commit 88fdb762e0afb8b02805fa45498d637df0764aae Author: SolaSUSTech Date: Thu Sep 25 16:33:13 2025 +0800 init diff --git a/指针测试.f90 b/指针测试.f90 new file mode 100644 index 0000000..2266181 --- /dev/null +++ b/指针测试.f90 @@ -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 \ No newline at end of file diff --git a/程序模板.f90 b/程序模板.f90 new file mode 100644 index 0000000..2b83fe2 --- /dev/null +++ b/程序模板.f90 @@ -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 +! ============================================================================== \ No newline at end of file diff --git a/第10章习题.f90 b/第10章习题.f90 new file mode 100644 index 0000000..ccc0f38 --- /dev/null +++ b/第10章习题.f90 @@ -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 \ No newline at end of file diff --git a/第11章习题.f90 b/第11章习题.f90 new file mode 100644 index 0000000..434b954 --- /dev/null +++ b/第11章习题.f90 @@ -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 \ No newline at end of file diff --git a/第12章习题.f90 b/第12章习题.f90 new file mode 100644 index 0000000..ae9ec29 --- /dev/null +++ b/第12章习题.f90 @@ -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 \ No newline at end of file diff --git a/第13章习题.f90 b/第13章习题.f90 new file mode 100644 index 0000000..176f4f3 --- /dev/null +++ b/第13章习题.f90 @@ -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 \ No newline at end of file diff --git a/第14章习题.f90 b/第14章习题.f90 new file mode 100644 index 0000000..42beb68 --- /dev/null +++ b/第14章习题.f90 @@ -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 \ No newline at end of file diff --git a/第15章习题.f90 b/第15章习题.f90 new file mode 100644 index 0000000..b5649e4 --- /dev/null +++ b/第15章习题.f90 @@ -0,0 +1,1016 @@ +! ============================================================================== +! 通过 gfortran ./test.f90 -o ./run && ./run 运行 +! 程序名： +! 第15章习题 +! 目的: +! +! 修订记录: +! 日期 编程者 改动描述 +! =================== ============= ===================================== +! 2021-05-25 15:25:35 Sola 习题15-1 ~ 习题15-2 跳过 +! 2021-05-25 15:28:00 Sola 习题15-3 指向非同类型地址以及赋值操作空格测试 +! 2021-05-25 15:35:37 Sola 习题15-4 跳过 +! 2021-05-25 15:35:50 Sola 习题15-5 测试未定义的ASSOCIATED值 +! 2021-05-25 15:42:41 Sola 习题15-6 跳过 +! 2021-05-25 15:42:53 Sola 习题15-7 指向数组及数组元素的指针 +! 2021-05-25 15:53:19 Sola 习题15-8 指向数组的指针的上下界 +! 2021-05-25 16:24:28 Sola 习题15-7 ~ 习题15-10 跳过 +! 2021-05-25 16:24:56 Sola 习题15-11 测试子程序中指针的分配 +! 2021-05-25 16:41:56 Sola 习题15-12 跳过 +! 2021-05-25 16:42:06 Sola 习题15-13 插入排序程序（链表） +! 2021-05-25 19:19:01 Sola 习题15-14 插入排序程序（二叉树） +! 2021-05-26 04:39:20 Sola 习题15-15 ~ 习题15-16 跳过 +! 2021-05-26 04:41:43 Sola 习题15-17 返回数组最大值指针 +! 2021-05-26 11:45:56 Sola 习题15-18 返回数组类型指针最大值指针 +! 2021-05-26 11:52:23 Sola 习题15-19 线性最小二乘拟合 +! 2021-05-26 17:44:42 Sola 习题15-20 双向链表 +! 程序结构: +! +! ============================================================================== +! 主程序： +program Chapter15 + implicit none + ! 数据字典 + ! 声明常量 + ! 声明变量 + ! 变量初始化 + ! 数据输入 + ! 运算过程 + ! 结果输出 + ! call Test15_1 + ! call Exercises15_3 + ! call Exercises15_5 + ! call Exercises15_7 + ! call Exercises15_8 + ! call Exercises15_11 + ! call Exercises15_13 + ! call Exercises15_14 + ! call Exercises15_17 + ! call Exercises15_18 + ! call Exercises15_19 + ! call Exercises15_20 + ! call Exercises15_21 + ! call Test + ! call Exercises15_22 + call Exercises15_21new +end program Chapter15 +! ============================================================================== +! 习题15-3 指向非同类型地址以及赋值操作空格测试 +subroutine Exercises15_3 + implicit none + real, pointer :: p1 + real, target :: x1=11. + integer, pointer :: p2 + integer, target :: x2=12 + p1=>x1 + p2 => x2 + write(*, '(A, 4G8.2)') ' p1, p2, x1, x2 = ', p1, p2, x1, x2 + ! p1=>p2 + ! p2=>x1 + ! write(*, '(A, 4G8.2)') ' p1, p2, x1, x2 = ', p1, p2, x1, x2 +end subroutine Exercises15_3 +! 习题15-5 测试未定义的ASSOCIATED值，未定义的值还真是随机的。。。 +subroutine Exercises15_5 + implicit none + real, pointer :: p1, p2 + real, target :: x1=11.1, x2=-3.2 + p1 => x1 + write(*, *) associated(p1), associated(p2), associated(p1, x2) +end subroutine Exercises15_5 +! 习题15-7 指向数组及数组元素的指针 +subroutine Exercises15_7 + implicit none + integer, dimension(:), pointer :: p1 => null() + integer, pointer :: p2 => null() + integer, dimension(1000), target :: array=1 + p1 => array + p2 => array(10) + write(*, '(100I1)') p1 + write(*, *) p2 +end subroutine Exercises15_7 +! 习题15-8 指向数组的指针的上下界 +subroutine Exercises15_8 + implicit none + integer :: i + real, dimension(-25: 25), target :: info=(/ (2.1*i, i = -25, 25) /) + real, dimension(:), pointer :: ptr1, ptr2, ptr3, ptr4 + ptr4 => info + ptr1 => info(-25: 25: 5) + ptr2 => ptr1(1:: 2) + ptr3 => ptr2(3: 5) + write(*, '(A, 11F6.1)') ' ptr1 = ', ptr1 + ! write(*, *) lbound(ptr4), ubound(ptr4) + write(*, '(A, 11F6.1)') ' ptr2 = ', ptr2 + write(*, '(A, 11F6.1)') ' ptr3 = ', ptr3 + write(*, '(A, 11F6.1)') ' ave of ptr3 = ', sum(ptr3)/size(ptr3) +end subroutine Exercises15_8 +! 习题15-11 测试子程序中指针的分配 +module my_sub + implicit none +contains + subroutine running_sum(sum, value) + implicit none + real, pointer :: sum, value + ! allocate(sum) + sum = sum + value + end subroutine running_sum +end module my_sub +subroutine Exercises15_11 + use my_sub + implicit none + integer :: istat + real, pointer :: sum, value + allocate(sum, value, stat=istat) + write(*, *) 'Enter values to add: ' + do + read (*, *, iostat=istat) value + if ( istat /= 0 ) exit + call running_sum(sum, value) + write(*, *) ' The sum is ', sum + end do +! contains +! subroutine running_sum(sum, value) +! implicit none +! real, pointer :: sum, value +! ! allocate(sum, value) +! sum = sum + value +! end subroutine running_sum +end subroutine Exercises15_11 +! 习题15-13 插入排序程序（链表） +module Linked_List + implicit none + private ! 数据隐藏 + public :: linkedList, LinkedListAdd, ShowLinkedList, strLength ! 显示指定数据 + integer, parameter :: strLength=12 ! 声明字符串基本长度 + type :: linkedList ! 链表结点数据类型 + character(len=strLength) :: value ! 结点值 + type(linkedList), pointer :: next ! 下一个结点地址 + end type linkedList +contains + ! recursive subroutine LinkedListAdd(value, ptr) ! 向链表中添加结点 + ! implicit none + ! character(len=strLength), intent(in) :: value ! 声明输入数据 + ! type(linkedList), pointer, intent(inout) :: ptr ! 声明当前检测的结点 + ! type(linkedList), pointer :: temp => null() ! 声明临时结点 + ! if ( .not. associated(ptr) ) then ! 如果检测结点不存在 + ! allocate(ptr) ! 创建一个新结点 + ! ptr%value = value ! 该结点的值为输入数据 + ! ptr%next => null() ! 该节点的下一个结点为空 + ! else ! 如果检测结点存在 + ! if ( LGT(Ucase(value), Ucase(ptr%value)) ) then ! 如果输入数据大于结点值 + ! call LinkedListAdd(value, ptr%next) ! 递归调用 + ! else ! 如果输入数据小于结点值 + ! allocate(temp) ! 给temp分配内存 + ! temp%value = value ! 定义temp值 + ! temp%next => ptr ! 定义temp下一个结点为当前结点 + ! ptr => temp ! 将当前结点指针指向temp, 完成结点插入 + ! end if + ! end if + ! end subroutine LinkedListAdd + recursive subroutine LinkedListAdd(newNode, ptr) ! 向链表中添加结点 + implicit none + type(linkedList), pointer, intent(inout) :: newNode ! 声明插入结点 + type(linkedList), pointer, intent(inout) :: ptr ! 声明当前检测的结点 + if ( .not. associated(ptr) ) then ! 如果检测结点不存在 + ptr => newNode + else ! 如果检测结点存在 + if ( LGT(Ucase(newNode%value), Ucase(ptr%value)) ) then ! 如果输入数据大于结点值 + call LinkedListAdd(newNode, ptr%next) ! 递归调用 + else ! 如果输入数据小于结点值 + newNode%next => ptr ! 定义插入结点下一个结点为当前结点 + ptr => newNode ! 将当前结点指针指向插入结点 + end if + end if + end subroutine LinkedListAdd + recursive subroutine ShowLinkedList(head) + implicit none + type(linkedList), pointer, intent(in) :: head ! 声明输入结点 + if ( associated(head%next) ) then ! 如果下一个结点存在 + write(*, '(1X, 2A)', advance='no') trim(head%value), ',' ! 输出结果 + call ShowLinkedList(head%next) ! 递归调用 + else ! 如果下一个结点不存在 + write(*, '(1X, A)', advance='yes') trim(head%value) ! 输出结果 + end if + end subroutine ShowLinkedList + 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 module Linked_List +subroutine Exercises15_13 + use Linked_List, only: linkedList, LinkedListAdd, ShowLinkedList, strLength + implicit none + character(len=strLength) :: inputValue ! 声明输入 + integer :: errorLevel ! 声明错误状态值 + integer :: i=0 ! 循环参数 + type(linkedList), pointer :: head => null() ! 声明链表头 + type(linkedList), pointer :: newNode => null() ! 声明插入结点 + write(*, *) 'Please enter 5 string, the max length is', strLength ! 提示信息 + do i = 1, 5 ! 输入五个数据 + write(*, '(1X, A)', advance='no') 'Please enter the value: ' ! 提示信息 + read(*, *, iostat=errorLevel) inputValue ! 读取输入信息 + if ( errorLevel /= 0 ) stop "" ! 检测读取状态 + allocate(newNode, stat=errorLevel) ! 分配插入结点内存 + if ( errorLevel /= 0 ) stop "" ! 检测分配状态 + newNode%value = inputValue ! 给结点赋值 + newNode%next => null() ! 定义结点指向地址为空 + call LinkedListAdd(newNode, head) ! 插入结点 + end do + write(*, '(1X, A)') 'Input ending, show the result:' ! 提示信息 + call ShowLinkedList(head) ! 打印链表(截尾) +end subroutine Exercises15_13 +! 习题15-14 插入排序程序（二叉树） +! 模块-二叉树 +module Binary_Tree + implicit none + private + public :: binaryTreeName, BinaryTreeNameAdd, BinaryTreeNamePrint + type :: binaryTreeName ! 二叉树结点类型数据 + real :: var1 ! 二叉树结点值 + type(binaryTreeName), pointer :: before ! 该节点前一个结点 + type(binaryTreeName), pointer :: next ! 该结点后一个结点 + end type binaryTreeName + interface operator(>) + module procedure BinaryTreeNameGreater ! 结点大于比较 + end interface + interface operator(<) + module procedure BinaryTreeNameLess ! 结点小于比较 + end interface +contains + function BinaryTreeNameGreater(input1, input2) result(result) ! 结点大于比较函数 + implicit none + logical :: result ! 输出结果类为布尔 + type(binaryTreeName), intent(in) :: input1, input2 ! 输入两个二叉树结点 + if ( input1%var1 > input2%var1 ) then + result = .TRUE. ! 如果结点1大于结点2, 则返回TURE + else + result = .FALSE. ! 如果结点1不大于结点2, 返回FALSE + end if + end function BinaryTreeNameGreater + function BinaryTreeNameLess(input1, input2) result(result) ! 结点小于比较函数 + implicit none + logical :: result ! 输出结果类为布尔 + type(binaryTreeName), intent(in) :: input1, input2 ! 输入两个二叉树结点 + if ( input1%var1 < input2%var1 ) then + result = .TRUE. ! 如果结点1小于结点2, 则返回TURE + else + result = .FALSE. ! 如果结点1不小于结点2, 则返回FALSE + end if + end function BinaryTreeNameLess + recursive subroutine BinaryTreeNameAdd(newNode, ptr) ! 向二叉树中添加结点 + implicit none + type(binaryTreeName), pointer, intent(inout) :: ptr ! 声明当前检测的结点 + type(binaryTreeName), pointer, intent(inout) :: newNode ! 声明临时结点 + if ( .not. associated(ptr) ) then ! 如果检测结点不存在 + ptr => newNode ! 则将检测结点指向新节点 + else ! 如果检测结点存在 + if ( newNode > ptr ) then ! 如果输入数据大于结点值 + call BinaryTreeNameAdd(newNode, ptr%next) ! 对检测结点后一个递归调用 + else ! 如果输入数据小于结点值 + call BinaryTreeNameAdd(newNode, ptr%before) ! 对检测结点前一个递归调用 + end if + end if + end subroutine BinaryTreeNameAdd + recursive subroutine BinaryTreeNamePrint(root) ! 由小到大打印当前根结点下的所有值 + implicit none + type(binaryTreeName), pointer, intent(in) :: root ! 输入指针root + if ( .not. associated(root) ) then + stop "" ! 如果该指针未关联, 停止并报错 + else ! 如果该指针已关联 + if ( associated(root%before) ) then + call BinaryTreeNamePrint(root%before) ! 如果该指针前一结点存在, 对前一结点递归调用 + end if + write(*, '(1X, F10.8)') root%var1 ! 输出当前结点的值 + if ( associated(root%next) ) then + call BinaryTreeNamePrint(root%next) ! 如果该指针后一结点存在, 对后一结点递归调用 + end if + end if + end subroutine BinaryTreeNamePrint +end module Binary_Tree +! 模块-链表 +module Linked_List_real + implicit none + private ! 数据隐藏 + public :: linkedList, LinkedListAdd ! 显示指定数据 + type :: linkedList ! 链表结点数据类型 + real :: value ! 结点值 + type(linkedList), pointer :: next ! 下一个结点地址 + end type linkedList +contains + recursive subroutine LinkedListAdd(newNode, ptr) ! 向链表中添加结点 + implicit none + type(linkedList), pointer, intent(inout) :: newNode ! 声明插入结点 + type(linkedList), pointer, intent(inout) :: ptr ! 声明当前检测的结点 + if ( .not. associated(ptr) ) then ! 如果检测结点不存在 + ptr => newNode ! 则将检测结点指向新节点 + else ! 如果检测结点存在 + if ( newNode%value > ptr%value ) then ! 如果输入数据大于结点值 + call LinkedListAdd(newNode, ptr%next) ! 递归调用 + else ! 如果输入数据小于结点值 + newNode%next => ptr ! 定义插入结点下一个结点为当前结点 + ptr => newNode ! 将当前结点指针指向插入结点 + end if + end if + end subroutine LinkedListAdd +end module Linked_List_real +module ModTimePast + implicit none + private + public :: set_timer, elapsed_time + integer, parameter :: sgl=selected_real_kind(p=1) ! 单精度类型数 + integer, dimension(8) :: timeNow ! 计算时间用 + integer, dimension(8) :: timeOld ! 计算时间用 +contains + subroutine set_timer ! 创建子程序1 + call DATE_AND_TIME(values=timeNow) ! 调用当前时间子程序 + ! write(*, *) 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 module ModTimePast +subroutine Exercises15_14 + use Binary_Tree, only: binaryTreeName, BinaryTreeNameAdd, BinaryTreeNamePrint + use Linked_List_real, only: linkedList, LinkedListAdd + use ModTimePast, only: set_timer, elapsed_time + implicit none + integer, parameter :: sgl=selected_real_kind(p=1) ! 单精度类型数 + real(sgl) :: timeBTree, timeLLink, timeArray ! 声明各部分运行时间 + type(binaryTreeName), pointer :: bTreeNode => null() ! 声明二叉树插入结点 + type(binaryTreeName), pointer :: bTreeRoot => null() ! 声明二叉树根结点 + type(linkedList), pointer :: lLinkNode => null() ! 声明链表插入结点 + type(linkedList), pointer :: lLinkHead => null() ! 声明链表根节点 + integer :: i ! 循环参数 + integer :: errorLevel ! 错误状态码 + real(sgl), dimension(50000) :: randomArray ! 随机数组 + call set_timer ! 统计创造随机数组所需时间 + do i = 1, 50000 + call random_number(randomArray(i)) ! 给随机数组赋值 + end do + call elapsed_time(timeArray) + call set_timer ! 统计二叉树排序所需时间 + do i = 1, 50000 + allocate(bTreeNode, stat=errorLevel) ! 创建插入结点 + if ( errorLevel /= 0 ) stop "" ! 创建失败, 报错并退出 + bTreeNode%var1 = randomArray(i) ! 给结点赋值 + bTreeNode%before => null() ! 令插入结点前一结点为空 + bTreeNode%next => null() ! 令插入结点后一结点为空 + call BinaryTreeNameAdd(bTreeNode, bTreeRoot) ! 插入该结点 + end do + call elapsed_time(timeBTree) + call set_timer ! 统计链表排序所需时间 + do i = 1, 50000 + allocate(lLinkNode, stat=errorLevel) ! 创建插入结点 + if ( errorLevel /= 0 ) stop "" ! 创建失败, 报错并退出 + lLinkNode%value = randomArray(i) ! 给结点赋值 + lLinkNode%next => null() ! 令插入结点后一结点为空 + call LinkedListAdd(lLinkNode, lLinkHead) ! 插入该结点 + end do + call elapsed_time(timeLLink) + write(*, '(A, ES12.5, A)') & + &'创建数组共花费时间: ', timeArray, 's', & + &'排序二叉树共花费时间: ', timeBTree, 's', & + &'排序链表共花费时间: ', timeLLink, 's' ! 输出结果 + ! bTreeRoot => null() + ! do i = 1, 50 + ! allocate(bTreeNode, stat=errorLevel) + ! if ( errorLevel /= 0 ) stop "" + ! bTreeNode%var1 = randomArray(i) + ! bTreeNode%before => null() + ! bTreeNode%next => null() + ! call BinaryTreeNameAdd(bTreeNode, bTreeRoot) + ! end do + ! call BinaryTreeNamePrint(bTreeRoot) +end subroutine Exercises15_14 +! 习题15-17 返回数组最大值指针 +subroutine Exercises15_17 + implicit none + interface ! 函数接口块 + function MaxPtr(arrayInput) result(result) + implicit none + integer, parameter :: sgl=selected_real_kind(p=1) + real(sgl), intent(in), dimension(:), target :: arrayInput + integer :: i + integer :: maxLocate=1 + real(sgl), pointer :: result + real(sgl) :: maxValue + end function MaxPtr + end interface + integer, parameter :: sgl=selected_real_kind(p=1) ! 单精度类型 + integer :: i ! 循环参数 + real(sgl), dimension(10), target :: randomArray ! 随机数组 + real(sgl), pointer :: maxLocPtr => null() ! 最大值指针 + do i = 1, 10 + call random_number(randomArray(i)) ! 给随机数组赋值 + end do + maxLocPtr => MaxPtr(randomArray) ! 计算最大值指针位置 + write(*, *) 'The max value is ', maxLocPtr ! 输出结果 +end subroutine Exercises15_17 +function MaxPtr(arrayInput) result(result) + implicit none + integer, parameter :: sgl=selected_real_kind(p=1) ! 单精度类型 + real(sgl), intent(in), dimension(:), target :: arrayInput ! 输入数组 + integer :: i ! 循环参数 + integer :: maxLocate=1 ! 最大值位置 + real(sgl), pointer :: result ! 最大值指针(返回值) + do i = 2, ubound(arrayInput, 1) - lbound(arrayInput, 1) + 1 + if ( arrayInput(maxLocate) < arrayInput(i) ) then + maxLocate = i ! 如果当前值比已有的最大值大, 那么最大值位置为当前位置 + end if + end do + result => arrayInput(maxLocate) ! 将最大值指针指向输入数组最大值位置 +end function MaxPtr +! 习题15-18 返回数组类型指针的最大值指针 +subroutine Exercises15_18 + implicit none + interface ! 函数接口块 + function MaxPtr1(arrayInput) result(result) + implicit none + integer, parameter :: sgl=selected_real_kind(p=1) + real(sgl), intent(in), dimension(:), pointer :: arrayInput + integer :: i + integer :: maxLocate=1 + real(sgl), pointer :: result + real(sgl) :: maxValue + end function MaxPtr1 + end interface + integer, parameter :: sgl=selected_real_kind(p=1) ! 单精度类型 + integer :: i ! 循环参数 + real(sgl), dimension(:), pointer :: randomArray => null() ! 随机数组 + real(sgl), pointer :: maxLocPtr => null() ! 最大值指针 + integer :: errorLevel + allocate(randomArray(10), stat=errorLevel) + if ( errorLevel /= 0 ) stop + do i = 1, 10 + call random_number(randomArray(i)) ! 给随机数组赋值 + end do + maxLocPtr => MaxPtr1(randomArray) ! 计算最大值指针位置 + write(*, *) 'The max value is ', maxLocPtr ! 输出结果 +end subroutine Exercises15_18 +function MaxPtr1(arrayInput) result(result) + implicit none + integer, parameter :: sgl=selected_real_kind(p=1) ! 单精度类型 + real(sgl), intent(in), dimension(:), pointer :: arrayInput ! 输入数组 + integer :: i ! 循环参数 + integer :: maxLocate=1 ! 最大值位置 + real(sgl), pointer :: result ! 最大值指针(返回值) + do i = 2, ubound(arrayInput, 1) - lbound(arrayInput, 1) + 1 + if ( arrayInput(maxLocate) < arrayInput(i) ) then + maxLocate = i ! 如果当前值比已有的最大值大, 那么最大值位置为当前位置 + end if + end do + result => arrayInput(maxLocate) ! 将最大值指针指向输入数组最大值位置 +end function MaxPtr1 +! 习题15-19 线性最小二乘拟合 +! 程序过程: +! 1.打开一个临时文件, 并向其中写入数据 +! 2.读取数据, 并将其添入链表 +! 3.传递链表头指针给子程序, 子程序返回相应数值 +module ModPoint + implicit none + integer, parameter :: sgl=selected_real_kind(p=1) + type :: point + real(sgl) :: x + real(sgl) :: y + type(point), pointer :: next + end type +end module ModPoint +subroutine Exercises15_19 + use ModPoint + implicit none + interface ! 定义接口块 + subroutine LeastSquaresMethodPtr(head, slope, intercept, correlationCoefficient) + use ModPoint + implicit none + type(point), intent(in), pointer :: head + real(sgl), intent(out) :: slope + real(sgl), intent(out) :: intercept + real(sgl), intent(out) :: correlationCoefficient + end subroutine LeastSquaresMethodPtr + end interface + type(point), pointer :: temp => null() ! 储存插入结点的临时值 + type(point), pointer :: ptr => null() ! 操作结点 + type(point), pointer :: head => null() ! 首结点 + integer :: errorLevel ! 错误状态码 + real :: m, b, r ! 最小二乘拟合参数 + open(unit=1, status='scratch', iostat=errorLevel) ! 打开一个临时文件 + if ( errorLevel /= 0 ) stop "" ! 打开失败, 报错退出 + write(1, '(A)') & ! 输入文件值 + &" -4.91, -8.18", & + &" -3.84, -7.49", & + &" -2.41, -7.11", & + &" -2.62, -6.15", & + &" -3.78, -5.62", & + &" -0.52, -3.30", & + &" -1.83, -2.05", & + &" -2.01, -2.83", & + &" -0.28, -1.16", & + &" +1.08, +0.52" + rewind(unit=1, iostat=errorLevel) ! 回到文件开头 + if ( errorLevel /= 0 ) stop "" ! 操作失败, 报错退出 + do + allocate(temp, stat=errorLevel) ! 给了临时结点分配内存 + if ( errorLevel /= 0 ) stop "" ! 分配失败, 报错退出 + temp%next => null() ! 临时节点的下一节点为空 + read(1, *, iostat=errorLevel) temp%x, temp%y ! 给临时结点赋值 + if ( errorLevel /= 0 ) then ! 如果没有输入值 + deallocate(temp, stat=errorLevel) ! 释放临时结点的内存 + if ( errorLevel /= 0 ) stop "" ! 释放内存失败, 报错退出 + exit ! 释放内粗成功, 结束循环 + end if + if ( .not. associated(head) ) then + head => temp ! 如果没有首结点, 则首结点指向临时节点 + end if + if ( .not. associated(ptr) ) then + ptr => temp ! 如果操作结点不存在, 则操作结点指向临时节点 + else + ptr%next => temp ! 如果操作结点存在, 则操作结点的下一个结点指向临时节点 + ptr => ptr%next ! 操作结点指向临时节点 + end if + end do + call LeastSquaresMethodPtr(head, 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/) + write(*,1) m, b, r ! 输出结果 + 1 format(1X, '计算得到的拟合方程为: y = ', F5.2, ' * x + ', F5.2, ' , 相关系数r为: ', F5.3) +end subroutine Exercises15_19 +subroutine LeastSquaresMethodPtr(head, slope, intercept, correlationCoefficient) + use ModPoint + implicit none + type(point), intent(in), pointer :: head ! 首结点 + real(sgl), intent(out) :: slope ! 斜率 + real(sgl), intent(out) :: intercept ! 截距 + real(sgl), intent(out) :: correlationCoefficient ! 相关系数 + type(point), pointer :: ptr ! 操作结点 + integer :: num=0 ! 结点总数 + real :: x_bar, y_bar ! xy均值 + real :: x_sum=0, y_sum=0 ! xy总和 + real :: x2_sum=0, xy_sum=0, y2_sum=0 ! 各种参数 + ptr => head ! 操作结点指向首结点 + do + if ( associated(ptr) ) then ! 如果操作结点已关联 + num = num + 1 ! 结点总数递增 + x_sum = x_sum + ptr%x ! 计算各类参数 + y_sum = y_sum + ptr%y + x2_sum = x2_sum + ptr%x**2 + y2_sum = y2_sum + ptr%y**2 + xy_sum = xy_sum + ptr%x*ptr%y + ptr => ptr%next ! 操作结点指向当前操作结点的下一个结点 + else + exit ! 如果操作结点未关联, 则结束循环 + end if + end do + x_bar = x_sum/real(num) ! x均值 + y_bar = y_sum/real(num) ! y均值 + slope = ( xy_sum - x_sum*y_bar )/( x2_sum - x_sum*x_bar ) ! 斜率 + intercept = y_bar - slope*x_bar ! 截距 + correlationCoefficient = ( real(num)*xy_sum - x_sum*y_sum )/& ! 相关系数 + &sqrt( (real(num)*x2_sum - x_sum**2 )*( real(num)*y2_sum - y_sum**2 ) ) +end subroutine LeastSquaresMethodPtr +! 习题15-20 双向链表 +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 + recursive subroutine DoNodeSort(ptr) ! 排序链表 + implicit none + type(doNode), intent(inout), pointer :: ptr ! 操作指针 + type(doNode), pointer :: newNode ! 需要变更的指针 + type(doNode), pointer :: temp + integer :: errorLevel + write(*, '(A)', advance='no') ' 3' + if ( associated(ptr) .and. associated(ptr%next) ) then ! 如果操作指针及操作指针的下一个指针已关联 + if ( ptr%var1 > ptr%next%var1 ) then ! 如果操作结点值大于下一个结点值 + ! allocate(newNode, stat=errorLevel) + ! if ( errorLevel /= 0 ) stop "" + newNode => ptr%next ! 将变更指针 => 下一个结点 + if ( associated(ptr%next%next) ) then ! 如果下一个结点不是最后一个结点 + newNode%next%before => ptr ! 将变更结点的下一个结点的前指针 => 操作结点 + ptr%next => newNode%next ! 操作结点的后指针 => 变更结点的下一个结点 + else ! 如果下一个结点是最后一个结点 + ptr%next => null() ! 操作结点的后指针 => 空 + end if + newNode%before => null() ! 变更结点的前指针 => 空 + newNode%next => null() ! 变更结点的后指针 => 空 + write(*, '(A)', advance='no') '4' + ! temp => ptr + call DoNodeSortForword(newNode, ptr%before) ! 将变更结点排序插入操作结点之前的链表 + ! ptr => temp + write(*, '(A)', advance='no') '5' + end if + write(*, '(A)', advance='no') '6' + if ( associated(ptr%next) ) then + call DoNodeSort(ptr%next) ! 对操作结点的下一个结点递归调用 + end if + write(*, '(A)', advance='no') '7' + end if + end subroutine DoNodeSort + recursive subroutine DoNodeSortBackword(newNode, ptr) + implicit none + type(doNode), intent(in), pointer :: newNode + type(doNode), intent(inout), pointer :: ptr + if ( .not. associated(newNode) ) then + stop "" + else + if ( .not. associated(ptr) ) then + ptr => newNode + else + if ( newNode%var1 > ptr%var1 ) then + call DoNodeSortBackword(newNode, ptr%next) + else + newNode%before => ptr%before + ptr%before%next => newNode + newNode%next => ptr + ptr%before => newNode + end if + end if + end if + end subroutine DoNodeSortBackword + 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 + if ( newNode%var1 < ptr%var1 ) then ! 如果插入结点值比操作结点值小 + if ( associated(ptr%before) ) then ! 如果操作结点前指针已关联 + call DoNodeSortForword(newNode, ptr%before) ! 递归调用 + else ! 如果操作结点前指针为空 + ptr%before => newNode ! 操作结点前指针 => 插入结点 + newNode%next => ptr ! 插入结点后指针 => 操作节点 + end if + else ! 如果插入结点值比操作结点值大 + newNode%before => ptr ! 插入结点前指针 => 操作结点 + newNode%next => ptr%next + ptr%next => newNode + newNode%next%before => newNode + end if + end subroutine DoNodeSortForword + recursive subroutine DoNodeSortForword1(newNode, ptr) ! 向前排序 + implicit none + type(doNode), intent(inout), pointer :: newNode ! 插入结点 + type(doNode), intent(inout), 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 ! 操作结点的后指针 => 插入结点 + 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 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 Exercises15_20 + use ModDoLinkList + implicit none + integer :: i + type(doNode), pointer :: newNode => null() + type(doNode), pointer :: head => null() + type(doNode), pointer :: tail => null() + type(doNode), pointer :: ptr => null() + real(sgl) :: temp + integer :: errorLevel + open(unit=1, status='scratch', iostat=errorLevel) + if ( errorLevel /= 0 ) stop "" + do i = 1, 20 + call random_number(temp) + temp = temp*200_sgl - 100_sgl + write(1, *, iostat=errorLevel) temp + if ( errorLevel /= 0 ) stop "" + end do + rewind(unit=1, iostat=errorLevel) + if ( errorLevel /= 0 ) stop "" + do + read(1, *, iostat=errorLevel) temp + if ( errorLevel /= 0 ) exit + allocate(newNode, stat=errorLevel) + if ( errorLevel /= 0 ) stop "" + newNode%var1 = temp + newNode%before => null() + newNode%next => null() + if ( .not. associated(head) ) then + head => newNode + end if + if ( .not. associated(ptr) ) then + ptr => newNode + else + ptr%next => newNode + newNode%before => ptr + ptr => newNode + end if + tail => ptr + end do + ptr => head + write(*, *) "从前向后排列:" + do + if ( associated(ptr) ) then + write(*, '(F10.5)', advance='no') ptr%var1 + ptr => ptr%next + else + write(*, *) '' + exit + end if + end do + ptr => tail + write(*, *) "从后向前排列:" + do + if ( associated(ptr) ) then + write(*, '(F10.5)', advance='no') ptr%var1 + ptr => ptr%before + else + write(*, *) '' + exit + end if + end do +end subroutine Exercises15_20 +subroutine Exercises15_21 + use ModDoLinkList + implicit none + integer :: i + type(doNode), pointer :: newNode => null() + type(doNode), pointer :: head => null() + type(doNode), pointer :: tail => null() + type(doNode), pointer :: ptr => null() + real(sgl) :: temp + integer :: errorLevel + open(unit=1, status='scratch', iostat=errorLevel) + if ( errorLevel /= 0 ) stop "" + do i = 1, 50 + call random_number(temp) + temp = temp*2000_sgl - 1000_sgl + write(1, *, iostat=errorLevel) temp + if ( errorLevel /= 0 ) stop "" + end do + rewind(unit=1, iostat=errorLevel) + if ( errorLevel /= 0 ) stop "" + do + read(1, *, iostat=errorLevel) temp + if ( errorLevel /= 0 ) exit + allocate(newNode, stat=errorLevel) + if ( errorLevel /= 0 ) stop "" + newNode%var1 = temp + newNode%before => null() + newNode%next => null() + if ( .not. associated(head) ) then + head => newNode + end if + if ( .not. associated(ptr) ) then + ptr => newNode + else + ptr%next => newNode + newNode%before => ptr + ptr => newNode + end if + tail => ptr + end do + ptr => head + write(*, *) "从前向后排列:" + do + if ( associated(ptr) ) then + write(*, '(F10.5)', advance='no') ptr%var1 + ptr => ptr%next + else + write(*, *) '' + exit + end if + end do + ptr => head + write(*, *) 1 + call DoNodeSort(ptr) + write(*, *) 2 + ptr => head + do + if ( associated(ptr%before) ) then + ptr => ptr%before + else + head => ptr + exit + end if + end do + ptr => tail + do + if ( associated(ptr%next) ) then + ptr => ptr%next + else + tail => ptr + exit + end if + end do + ptr => head + write(*, *) "升序排列:" + do + if ( associated(ptr) ) then + write(*, '(F10.4)', advance='no') ptr%var1 + ptr => ptr%next + else + write(*, *) '' + exit + end if + end do + ptr => tail + write(*, *) "降序排列:" + do + if ( associated(ptr) ) then + write(*, '(F10.4)', advance='no') ptr%var1 + ptr => ptr%before + else + write(*, *) '' + exit + end if + end do +end subroutine Exercises15_21 +module ModDuLinkList + implicit none + private + type :: duNode + +end module ModDuLinkList +subroutine Exercises15_21new + use ModDuLinkList + implicit none +end subroutine Exercises15_21new \ No newline at end of file diff --git a/第16章习题.f90 b/第16章习题.f90 new file mode 100644 index 0000000..4f77d72 --- /dev/null +++ b/第16章习题.f90 @@ -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 \ No newline at end of file diff --git a/第2章习题.f90 b/第2章习题.f90 new file mode 100644 index 0000000..b0765ba --- /dev/null +++ b/第2章习题.f90 @@ -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 \ No newline at end of file diff --git a/第5章习题.f90 b/第5章习题.f90 new file mode 100644 index 0000000..6cda017 --- /dev/null +++ b/第5章习题.f90 @@ -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 \ No newline at end of file diff --git a/第6章习题.f90 b/第6章习题.f90 new file mode 100644 index 0000000..1fc8d35 --- /dev/null +++ b/第6章习题.f90 @@ -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 \ No newline at end of file diff --git a/第7章习题.f90 b/第7章习题.f90 new file mode 100644 index 0000000..eb3fb2e --- /dev/null +++ b/第7章习题.f90 @@ -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 堆排序 +! 了解有这么个玩意就成 \ No newline at end of file diff --git a/第8章习题.f90 b/第8章习题.f90 new file mode 100644 index 0000000..c4d35b9 --- /dev/null +++ b/第8章习题.f90 @@ -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 diff --git a/第9章习题.f90 b/第9章习题.f90 new file mode 100644 index 0000000..f8fb647 --- /dev/null +++ b/第9章习题.f90 @@ -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 \ No newline at end of file