! ============================================================================== ! 通过 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