641 lines
33 KiB
Fortran
641 lines
33 KiB
Fortran
! ==============================================================================
|
||
! 通过 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 |