计算物理精解【3】- FORTRAN计算

文章目录

概述
hello,world
- 环境
- 接收输入与输出
读取csv文件
if and select case
循环
format
read,write format
read,write
- 读写文件
- 录入与读取数据
- 文件定位
- csv
数组
- 一维数组
- 最小二乘法
- 下标
- 隐式循环
关系代数基本运算
- 笛卡尔积
- 投影+选择
过程参数
select case 和过程
module
快排
函数
自定义类型
forall
where
element
不定结构的数组参数
高斯消元法
Collaborative Filtering协同过滤
- 欧几里德距离

概述

FORTRAN是英文“FORmulaTRANslator”的缩写，译为“公式翻译器”，它是世界上最早出现的计算机高级程序设计语言，广泛应用于科学和工程计算领域。FORTRAN语言以其特有的功能在数值、科学和工程计算领域发挥着重要作用。
Fortran语言的最大特性是接近数学公式的自然描述，在计算机里具有很高的执行效率。易学，语法严谨。可以直接对矩阵和复数进行运算，这一点类似matlab。自诞生以来广泛地应用于数值计算领域，积累了大量高效而可靠的源程序。很多专用的大型数值运算计算机针对Fortran做了优化。广泛地应用于并行计算和高性能计算领域。Fortran90，Fortran95，Fortran2003的相继推出使Fortran语言具备了现代高级编程语言的一些特性。

hello,world

环境

codeblock + gfortran

linux
安装 gfortran和codeblock即可
windows
下载相应版本mingw-w64
https://sourceforge.net/projects/mingw-w64/files/
然后解压后，配置path路径
最后，codeblock新增项目，选择fortran
并配置编译器

program hello
    implicit none

    write (*,*) "Hello,World!"

end program

code::blocks中文设置
没有好的方法，直接将文件保存为gbk格式。
不要使用utf-8

接收输入与输出


program hello
    implicit none
    integer::age
    character(len=10) ::name
    write (*,*) '您叫什么名字？'
    read(*,*) name

    write (*,*) '您今年多少岁？'
    read(*,*) age

    write (*,*) 'Hi,欢迎',name,'加入学习fortran的队伍!'
    write (*,*) '您今年',age,'岁!'

end program

读取csv文件

以读取机器学习训练集iris为例。

program aiFortran
    implicit none
    character(20)::class_name
    character(200)::file_name
    integer::record_count=0
    integer::io_status
    integer::read_status
    integer::path_pos
    character(200)::err_msg
    real::sepal_length,sepal_width,petal_length,petal_width
    type::iris_info
        real::iris_sepal_length
        real::iris_sepal_width
        real::iris_petal_length
        real::iris_petal_width
        character(len=20)::iris_class_name
    end type iris_info
    type(iris_info),dimension(200)::iris_datas
    type(iris_info)::iris_data

    character(len=255) :: cmd
    call get_command(cmd)
    path_pos=index(cmd, '\bin' , .true.)
    file_name=trim(cmd(1:path_pos))//"iris\iris.data"

    open (unit=10,file=file_name,status='old',action='read',iostat=io_status,iomsg=err_msg)
    if (io_status/=0)  then
        write(*,90) file_name,err_msg
        90 format ('读取iris文件',A200,'异常:',A200)
    else
        write (*,*) "萼片长度,萼片宽度,花瓣长度,花瓣宽度,分类"
        read_file:do
            read (10,*,iostat=read_status) sepal_length,sepal_width,petal_length,petal_width,class_name
            if (read_status/=0) exit
            record_count=record_count+1
            iris_data=iris_info(sepal_length,sepal_width,petal_length,petal_width,class_name)
            iris_datas(record_count)=iris_data
            write (*,100) iris_data
        end do read_file
        close(unit=10)
        write (*,*) "共读取",record_count,"条数据!"
    endif

    100 format(4(F5.1,1X),A50)


end program aiFortran

if and select case

 您叫什么名字？
张三
 您数学、英语、政治成绩多少分？
98,78,55
 Hi,欢迎张三      !
 您平均分：          77 !
 您真是一个数学天才！
 您政治要加油了！

Process returned 0 (0x0)   execution time : 17.262 s
Press any key to continue.


program hello
    implicit none
    integer::math_score,english_score,politics_score
    character (len=10)::name
    write (*,*) '您叫什么名字？'
    read(*,*) name

    write (*,*) '您数学、英语、政治成绩多少分？'
    read(*,*) math_score,english_score,politics_score

    write (*,*) 'Hi,欢迎',name,'!'
    write (*,*) '您平均分：',(math_score+english_score+politics_score)/3,'!'
    math:select case (math_score)
    case (101:) math
        write (*,*) '您数学成绩真实吗？'
    case (60:79) math
        write (*,*) '您数学及格了！'
    case (80:79)  math
        write (*,*) '您数学比较好了！'
    case (80:95)  math
        write (*,*) '您数学很优异！'
    case (96:100)  math
        write (*,*) '您真是一个数学天才！'
    end select math
    english:if (english_score >85 )then
        write (*,*) '您英语比较好了！'
    else if (english_score >95) then
        write (*,*) '您真是一个英语天才！'
    end if english
    politics:select case (politics_score)
    case (:70)
        write (*,*) '您政治要加油了！'
    case (96,97,98,99,100)
        write (*,*) '您真是一个政治天才！'
    case (101:)
        write (*,*) '您政治成绩真实吗？'
    case default
        write (*,*) '您政治比较好了！'
    end select politics


end program

上面程序有一个错误

    english:if (english_score >85 )then
        write (*,*) '您英语比较好了！'
    else if (english_score >95) then
        write (*,*) '您真是一个英语天才！'
    end if english

 您叫什么名字？
张三
 您数学、英语、政治成绩多少分？
89,98,77
 Hi,欢迎张三      !
 您平均分：          88 !
 您数学很优异！
 您英语比较好了！
 您政治比较好了！

Process returned 0 (0x0)   execution time : 12.550 s
Press any key to continue.

修改一下


program hello
    implicit none
    integer::math_score,english_score,politics_score
    character (len=10)::name
    write (*,*) '您叫什么名字？'
    read(*,*) name

    write (*,*) '您数学、英语、政治成绩多少分？'
    read(*,*) math_score,english_score,politics_score

    write (*,*) 'Hi,欢迎',name,'!'
    write (*,*) '您平均分：',(math_score+english_score+politics_score)/3,'!'
    math:select case (math_score)
    case (101:) math
        write (*,*) '您数学成绩真实吗？'
    case (60:79) math
        write (*,*) '您数学及格了！'
    case (80:79)  math
        write (*,*) '您数学比较好了！'
    case (80:95)  math
        write (*,*) '您数学很优异！'
    case (96:100)  math
        write (*,*) '您真是一个数学天才！'
    end select math
    english:if (english_score >95 )then
        write (*,*) '您真是一个英语天才！'
    else if (english_score >85) then
        write (*,*) '您英语比较好了！'
    end if english
    politics:select case (politics_score)
    case (:70)
        write (*,*) '您政治要加油了！'
    case (96,97,98,99,100)
        write (*,*) '您真是一个政治天才！'
    case (101:)
        write (*,*) '您政治成绩真实吗？'
    case default
        write (*,*) '您政治比较好了！'
    end select politics


end program

 您叫什么名字？
张三
 您数学、英语、政治成绩多少分？

88,99,44
 Hi,欢迎张三      !
 您平均分：          77 !
 您数学很优异！
 您真是一个英语天才！
 您政治要加油了！

Process returned 0 (0x0)   execution time : 11.435 s
Press any key to continue.

循环

求素数


program hello
    implicit none
    integer::num,i
    logical::is_prime_number=.TRUE.

    write (*,*) "请输入数："
    read (*,*) num

    do i=2,num-1
        if (mod(num,i)==0) then
            is_prime_number=.FALSE.
            write (*,*) num,'/',i,'=',num/i
            exit
        endif
    end do
    if (is_prime_number) then
        write (*,*) num,"是素数"
    else
        write (*,*) num,"不是素数"
    end if


end program


program hello
    implicit none
    integer::i,max_num,n
    logical::is_prime_number

    write (*,*) "请输入求素数的最大范围："
    read (*,*) max_num
    do n=3,max_num-1
        is_prime_number=.TRUE.
        do i=2,n-1
            if (mod(n,i)==0) then
                is_prime_number=.FALSE.
                write (*,*) n,'/',i,'=',n/i
                exit
            endif
        end do
        if (is_prime_number) then
            write (*,*) n,"是素数"
        end if
    end do



end program

format

11,342,992,345.4253345,202.32454532,0.023435
     11   342 992 345.43      0.20232E+03 2.343500033E-02

Process returned 0 (0x0)   execution time : 14.987 s
Press any key to continue.


program format_output
    implicit none
    integer::i,j,k
    real::x1,x2,x3
    read (*,*) i,j,k,x1,x2,x3
    write (*,100) i,j,k,x1,x2,x3
    100 format(" ",2I6,1X,I0,1X,F0.2,1X,E16.5,1X,ES15.9)

end program format_output

read,write format

program learn
    implicit none
    integer::id
    real::math_score,english_score,politics_score
    write(*,*) "请输入数据（学号,数学成绩,英语成绩,政治成绩):"
    read (*,100) id,math_score,english_score,politics_score
    write (*,100) id,math_score,english_score,politics_score
    100 format(I5,3F6.2)


end program learn

 请输入数据（学号,数学成绩,英语成绩,政治成绩):
1,87.34,98.22,69.54
    1 87.34 98.22 69.54

Process returned 0 (0x0)   execution time : 13.665 s
Press any key to continue.

program learn
    implicit none
    character(10)::name
    integer::id
    real::math_score,english_score,politics_score
    write(*,*) "请输入数据（学号,姓名,数学成绩,英语成绩,政治成绩):"
    read (*,*) id,name,math_score,english_score,politics_score
    write (*,100) id,name,math_score,english_score,politics_score
    100 format(I5,A10,3F6.2)


end program learn

 请输入数据（学号,姓名,数学成绩,英语成绩,政治成绩):
1,张三,89.31,86.81,76.34
    1张三       89.31 86.81 76.34

Process returned 0 (0x0)   execution time : 20.302 s
Press any key to continue.

read,write

读写文件

program learn
    implicit none
    character(10)::student_name
    character(20)::file_name
    integer::id
    integer::io_status
    character(100)::err_msg
    real::math_score,english_score,politics_score

    write(*,*) "请输入文件名:"
    read (*,*)  file_name
    write(*,*) "请输入数据（学号,姓名,数学成绩,英语成绩,政治成绩):"
    read (*,*) id,student_name,math_score,english_score,politics_score

    open (unit=11,file=file_name,status='replace',action='write',iostat=io_status,iomsg=err_msg)
    if (io_status/=0)  then
        write(*,*) "写入文件",file_name,"异常"
    else
        write (11,100) id,student_name,math_score,english_score,politics_score
        close(unit=11)
    endif


    open (unit=10,file=file_name,status='old',action='read',iostat=io_status,iomsg=err_msg)
    if (io_status/=0)  then
        write(*,*) "读取文件",file_name,"异常"
    else
        read (10,100) id,student_name,math_score,english_score,politics_score
        write (*,100) id,student_name,math_score,english_score,politics_score
        close(unit=10)
    endif
    100 format(I5,A10,3F6.2)


end program learn

录入与读取数据

 请输入文件名:
test.dat
 请输入数据（学号,姓名,数学成绩,英语成绩,政治成绩):
1,ads,dsf,adsf,adf,adsf
 请输入数据（学号,姓名,数学成绩,英语成绩,政治成绩):
2,asfd,asdf,adsf,345
 请输入数据（学号,姓名,数学成绩,英语成绩,政治成绩):
3,张三,98.32,68.88,91.34
 录入成功！
 继续录入吗？(y/n)
n
    3张三       98.32 68.88 91.34

Process returned 0 (0x0)   execution time : 35.250 s
Press any key to continue.

program learn
    implicit none
    character(10)::student_name
    character(20)::file_name
    character(1)::is_continue_input,ans
    integer::id
    integer::io_status
    integer::read_status
    integer::write_status
    character(100)::err_msg
    real::math_score,english_score,politics_score

    write(*,*) "请输入文件名:"
    read (*,*)  file_name

    open (unit=11,file=file_name,status='replace',action='write',iostat=io_status,iomsg=err_msg)
    if (io_status/=0)  then
        write(*,*) "写入文件",file_name,"异常:",err_msg
    else
        write_file:do
            write(*,*) "请输入数据（学号,姓名,数学成绩,英语成绩,政治成绩):"
            read (*,*,iostat=read_status) id,student_name,math_score,english_score,politics_score
            if (read_status/=0) cycle
            write(11,100,iostat=write_status) id,student_name,math_score,english_score,politics_score
            if (write_status==0) write (*,*) "录入成功！"
            write (*,*) "继续录入吗？(y/n)"
            read(*,*) is_continue_input
            if (is_continue_input=='n' .or. is_continue_input=='N') exit
        end do write_file
        close(unit=11)
    endif


    open (unit=10,file=file_name,status='old',action='read',iostat=io_status,iomsg=err_msg)
    if (io_status/=0)  then
        write(*,*) "读取文件",file_name,"异常:",err_msg
    else
        read_file:do
            read (10,100,iostat=read_status) id,student_name,math_score,english_score,politics_score
            if (read_status/=0) exit
            write (*,100) id,student_name,math_score,english_score,politics_score
        end do read_file
        close(unit=10)
    endif
    100 format(I5,A10,3F6.2)


end program learn

文件定位

rewind 从文件头开始

 请输入文件名:
test.dat
 请输入数据（学号,姓名,数学成绩,英语成绩,政治成绩):
1,张三,87.34,69.49,73.29
 录入成功！
 继续录入吗？(y/n)
y
 请输入数据（学号,姓名,数学成绩,英语成绩,政治成绩):
2,李四,88.32,76.33,93.16
 录入成功！
 继续录入吗？(y/n)
n
 请输入学号:
1
    1张三       87.34 69.49 73.29
 请输入学号:
2
    2李四       88.32 76.33 93.16
 请输入学号:
1
    1张三       87.34 69.49 73.29
 请输入学号:
1
    1张三       87.34 69.49 73.29
 请输入学号:
2
    2李四       88.32 76.33 93.16
 请输入学号:
2
    2李四       88.32 76.33 93.16
 请输入学号:
3
 找不到该学生的记录
 请输入学号:
1
    1张三       87.34 69.49 73.29
 请输入学号:
2
    2李四       88.32 76.33 93.16
 请输入学号:
3
 找不到该学生的记录
 请输入学号:
99
 找不到该学生的记录
 请输入学号:
-1

program learn
    implicit none
    character(10)::student_name
    character(20)::file_name
    character(1)::is_continue_input,ans
    logical::data_is_finded
    integer::id
    integer::io_status
    integer::read_status
    integer::write_status
    integer::search_id
    character(100)::err_msg
    real::math_score,english_score,politics_score

    write(*,*) "请输入文件名:"
    read (*,*)  file_name

    open (unit=11,file=file_name,status='replace',action='write',iostat=io_status,iomsg=err_msg)
    if (io_status/=0)  then
        write(*,*) "写入文件",file_name,"异常:",err_msg
    else
        write_file:do
            write(*,*) "请输入数据（学号,姓名,数学成绩,英语成绩,政治成绩):"
            read (*,*,iostat=read_status) id,student_name,math_score,english_score,politics_score
            if (read_status/=0) cycle
            write(11,100,iostat=write_status) id,student_name,math_score,english_score,politics_score
            if (write_status==0) write (*,*) "录入成功！"
            write (*,*) "继续录入吗？(y/n)"
            read(*,*) is_continue_input
            if (is_continue_input=='n' .or. is_continue_input=='N') exit
        end do write_file
        close(unit=11)
    endif


    open (unit=10,file=file_name,status='old',action='read',iostat=io_status,iomsg=err_msg)
    if (io_status/=0)  then
        write(*,*) "读取文件",file_name,"异常:",err_msg
    else
        search_data:do
            data_is_finded=.false.
            write(*,*) "请输入学号:"
            read(*,*) search_id
            if (search_id<=0) exit
            rewind(unit=10) !从文件头开始
            find_id:do
                read (10,100,iostat=read_status) id,student_name,math_score,english_score,politics_score
                if (read_status/=0) exit
                if (id==search_id) then
                    data_is_finded=.true.
                    write (*,100) id,student_name,math_score,english_score,politics_score
                endif
            end do find_id
            if (.not. data_is_finded) write(*,*) "找不到该学生的记录"

        end do search_data

        close(unit=10)
    endif
    100 format(I5,A10,3F6.2)


end program learn

backspace 回退一条记录

请输入文件名:
test.dat
 请输入数据（学号,姓名,数学成绩,英语成绩,政治成绩):
1,张三,66,77,88
 录入成功！
 继续录入吗？(y/n)
y
 请输入数据（学号,姓名,数学成绩,英语成绩,政治成绩):
2,李四,88,99,77
 录入成功！
 继续录入吗？(y/n)
y
 请输入数据（学号,姓名,数学成绩,英语成绩,政治成绩):
3,王五,72,83,91
 录入成功！
 继续录入吗？(y/n)
n
    1张三       66.00 77.00 88.00
    2李四       88.00 99.00 77.00
    3王五       72.00 83.00 91.00
    3王五       72.00 83.00 91.00
    2李四       88.00 99.00 77.00
    1张三       66.00 77.00 88.00

Process returned 0 (0x0)   execution time : 40.113 s
Press any key to continue.

program learn
    implicit none
    character(10)::student_name
    character(20)::file_name
    character(1)::is_continue_input
    integer::record_count
    integer::id
    integer::io_status
    integer::read_status
    integer::write_status
    character(100)::err_msg
    real::math_score,english_score,politics_score

    record_count=0
    write(*,*) "请输入文件名:"
    read (*,*)  file_name

    open (unit=11,file=file_name,status='replace',action='write',iostat=io_status,iomsg=err_msg)
    if (io_status/=0)  then
        write(*,*) "写入文件",file_name,"异常:",err_msg
    else
        write_file:do
            write(*,*) "请输入数据（学号,姓名,数学成绩,英语成绩,政治成绩):"
            read (*,*,iostat=read_status) id,student_name,math_score,english_score,politics_score
            if (read_status/=0) cycle
            write(11,100,iostat=write_status) id,student_name,math_score,english_score,politics_score
            if (write_status==0) write (*,*) "录入成功！"
            write (*,*) "继续录入吗？(y/n)"
            read(*,*) is_continue_input
            if (is_continue_input=='n' .or. is_continue_input=='N') exit
        end do write_file
        close(unit=11)
    endif


    open (unit=10,file=file_name,status='old',action='read',iostat=io_status,iomsg=err_msg)
    if (io_status/=0)  then
        write(*,*) "读取文件",file_name,"异常:",err_msg
    else
        read_file:do
            read (10,100,iostat=read_status) id,student_name,math_score,english_score,politics_score
            if (read_status/=0) exit
            write (*,100) id,student_name,math_score,english_score,politics_score
            record_count=record_count+1
        end do read_file
        backspace(unit=10)
        back_read_file:do
            backspace(unit=10)
            read (10,100,iostat=read_status) id,student_name,math_score,english_score,politics_score
            if (read_status/=0  .or. record_count<=0) exit
            write (*,100) id,student_name,math_score,english_score,politics_score
            backspace(unit=10)
            record_count=record_count-1
        end do back_read_file
        close(unit=10)
    endif
    100 format(I5,A10,3F6.2)


end program learn

csv

下载鸢尾属植物机器学习数据集
http://archive.ics.uci.edu/dataset/53/iris
数据集包含3类，每个类包含50个实例，每个类表示一种鸢尾属植物。一类与另一类是线性可分离的；后者彼此之间不是线性可分离的。

program learn
    implicit none
    character(20)::class_name
    character(200)::file_name
    integer::record_count=0
    integer::io_status
    integer::read_status
    integer::path_pos
    character(200)::err_msg
    real::sepal_length,sepal_width,petal_length,petal_width

    character(len=255) :: cmd
    call get_command(cmd)
    path_pos=index(cmd, '\' , .true.)
    file_name=trim(cmd(1:path_pos))//"iris\iris.data"

    open (unit=10,file=file_name,status='old',action='read',iostat=io_status,iomsg=err_msg)
    if (io_status/=0)  then
        write(*,90) file_name,err_msg
        90 format ('读取iris文件',A200,'异常:',A200)
    else
        write (*,*) "萼片长度,萼片宽度,花瓣长度,花瓣宽度,分类"
        read_file:do
            read (10,*,iostat=read_status) sepal_length,sepal_width,petal_length,petal_width,class_name
            if (read_status/=0) exit
            write (*,100) sepal_length,sepal_width,petal_length,petal_width,class_name
            record_count=record_count+1
        end do read_file
        close(unit=10)
        write (*,*) "共读取",record_count,"条数据!"
    endif
    100 format(4(F5.1,1X),A50)


end program learn

...
...
  6.7   3.0   5.2   2.3                               Iris-virginica
  6.3   2.5   5.0   1.9                               Iris-virginica
  6.5   3.0   5.2   2.0                               Iris-virginica
  6.2   3.4   5.4   2.3                               Iris-virginica
  5.9   3.0   5.1   1.8                               Iris-virginica
 共读取         150 条数据!

数组

一维数组

program hello
    implicit none
    integer,dimension(5)::x=[1,2,3,4,5]
    integer,dimension(5)::b=[11,22,33,44,55]
    real::a=6.2
    real,dimension(5)::y
    y=x*a+b
    write(*,*) y
end program

   17.2000008       34.4000015       51.5999985       68.8000031       86.0000000

Process returned 0 (0x0)   execution time : 0.032 s
Press any key to continue.

最小二乘法

program hello
    implicit none
    real,dimension(5)::x=[10,20,30,40,50]
    real,dimension(5)::b=[10,15,12,13,9]
    real::a=16.29
    real,dimension(5)::y
    real::x_mean
    real::y_mean
    real::a_predict2
    real::a_predict1
    real::b_predict,a_predict
    y=a*x+b
    x_mean=sum(x)/5
    y_mean=sum(y)/5
    a_predict2=sum((x-x_mean)**2)
    a_predict1=sum(((x-x_mean)*(y-y_mean)))
    a_predict=a_predict1/a_predict2
    b_predict=y_mean-a*x_mean
    write(*,*) 'a=',a_predict
    write(*,*) 'b=',b_predict
end program

下标

program learn
    implicit none
    real,dimension(5)::a=[10,20,30,40,50]
    integer,dimension(5)::b=[1,2,3,4,5]
    integer::i
    write (*,*) [(i,i=1,3)]
    write (*,*) (i,i=3,20,4)
    write(*,*) a(2:4)
    write(*,*) b(1),b(4)
    write(*,*) b([1,5])
    write(*,*) b([(i,i=1,5,2)])


end program learn

           1           2           3
           3           7          11          15          19
   20.0000000       30.0000000       40.0000000
           1           4
           1           5
           1           3           5

Process returned 0 (0x0)   execution time : 0.034 s
Press any key to continue.

隐式循环

program learn
    implicit none
    integer i,j
    write (*,100) ((i,j,j=1,9),i=1,9)
    100 format (I5,1X,I5)
    write (*,110) ((i,j,i*j,j=1,9),i=1,9)
    110 format (I5,'*',I5,'=',I10)

end program learn

...
    9     4
    9     5
    9     6
    9     7
    9     8
    9     9
    1*    1=         1
    1*    2=         2
    1*    3=         3
    1*    4=         4
    1*    5=         5
    1*    6=         6
    1*    7=         7
    1*    8=         8
	...

	program learn
    implicit none
    integer,dimension(2,3)::a
    integer,dimension(2,3)::b
    a=reshape([1,66,89,2,74,79],[2,3])
    b=reshape([1,76,99,2,84,59],[2,3])
    write (*,100) a
    write (*,100) b
    100 format (3I5)

end program learn

    1   66   89
    2   74   79
    1   76   99
    2   84   59

Process returned 0 (0x0)   execution time : 0.172 s
Press any key to continue.

关系代数基本运算

笛卡尔积

aid a1 a2bid b1 b2
  1 66 74  1 76 84
  2 89 79  1 76 84
  1 66 74  2 99 59
  2 89 79  2 99 59

Process returned 0 (0x0)   execution time : 0.167 s
Press any key to continue.

program learn
    implicit none
    integer,dimension(2,3)::a
    integer,dimension(2,3)::b
    integer::i,j
    a=reshape([1,2,66,89,74,79],[2,3])
    b=reshape([1,2,76,99,84,59],[2,3])
    write (*,120) 'aid','a1','a2','bid','b1','b2'
    write (*,110) ((a(i,:),b(j,:),i=1,2),j=1,2)
    110 format (6(I3))
    120 format (6(A3))
end program learn

aid a1 a2bid b1 b2
  1 66 74  1 76 84
  2 89 79  1 76 84
  1 66 74  2 99 59
  2 89 79  2 99 59
 ---------
  2 89 79  1 76 84
 ---------
 66 89 66 89

program learn
    implicit none
    integer,dimension(2,3)::a
    integer,dimension(2,3)::b
    integer,dimension(24)::c
    integer,dimension(4,6)::d
    integer::i,j
    integer::k
    a=reshape([1,2,66,89,74,79],[2,3],order=[1,2])
    b=reshape([1,2,76,99,84,59],[2,3],order=[1,2])
    write (*,120) 'aid','a1','a2','bid','b1','b2'
    c=[((a(i,:),b(j,:),i=1,2),j=1,2)]
    d=reshape(c,[4,6],order=[2,1])
    write (*,110) c
    write  (*,*) "---------"
    write (*,110) d(2,:)
    write  (*,*) "---------"
    write (*,110) d(:,2)
    110 format (6(I3))
    120 format (6(A3))
end program learn

投影+选择

program learn
    implicit none
    integer,dimension(2,3)::a
    integer,dimension(2,3)::b
    integer,dimension(24)::c
    integer,dimension(4,6)::d
    integer::i,j
    integer::k
    a=reshape([1,2,66,89,74,79],[2,3],order=[1,2])
    b=reshape([1,2,76,99,84,59],[2,3],order=[1,2])
    write (*,120) 'aid','a1','a2','bid','b1','b2'
    c=[((a(i,:),b(j,:),i=1,2),j=1,2)]
    d=reshape(c,[4,6],order=[2,1])
    write (*,110) c
    write  (*,*) "---------"
    write (*,110) d(2,:)
    write  (*,*) "---------"
    write (*,110) d(:,2)
    write  (*,*) "---------"
    write  (*,*) "b1>70 and a2<70"
    write (*,120) 'aid','a1','a2','bid','b1','b2'
    !b1>70 and a2<90 选择
    k=1
    do
       if (d(k,5)>70 .and. d(k,3)<79) write (*,110) d(k,:)
       k=k+1
       if (k>4) exit
    end do
    write (*,120) 'aid','a1','a2','bid','b1','b2'
    !b1>70 and a2<90 选择+投影
    write  (*,*) "b1>70 and a2<70 and aid=bid"
    write (*,120) 'aid','a1','a2','b1','b2'
    k=1
    do
       if (d(k,5)>70 .and. d(k,3)<79 .and. d(k,1)==d(k,4)) write (*,110) d(k,1:3),d(k,5:6)
       k=k+1
       if (k>4) exit
    end do
    110 format (6(I3))
    120 format (6(A3))
end program learn

aid a1 a2bid b1 b2
  1 66 74  1 76 84
  2 89 79  1 76 84
  1 66 74  2 99 59
  2 89 79  2 99 59
 ---------
  2 89 79  1 76 84
 ---------
 66 89 66 89
 ---------
 b1>70 and a2<70
aid a1 a2bid b1 b2
  1 66 74  1 76 84
  1 66 74  2 99 59
aid a1 a2bid b1 b2
 b1>70 and a2<70 and aid=bid
aid a1 a2 b1 b2
  1 66 74 76 84

Process returned 0 (0x0)   execution time : 0.141 s
Press any key to continue.

过程参数

program hello
    implicit none

    integer,dimension(10)::my_nums
    integer::result,avg,i
    my_nums=[(i,i=1,40,4 )]
    call sum_nums(my_nums,10,result,avg)
    write(*,*) result,avg

end program

subroutine sum_nums(nums,n,result,avg)
    integer,dimension(n),intent(in):: nums
    integer,intent(out)::result,avg
    result=0
    do i=1,n
        write (*,*) nums(i)
        result=result+nums(i)
    end do
    avg=result/n
end subroutine

select case 和过程

 请输入计算的类型:
  1-->三角形           
  2-->平行四边形     
  3-->梯形              
  4-->圆形              
1
      请输入计算的参数1
9.22
      请输入计算的参数2
2.7
      请输入计算的参数3
-1
三角形            面积：     12.45

Process returned 0 (0x0)   execution time : 10.916 s
Press ENTER to continue.

program hello
    implicit none
    integer::g_type,i
    real::p
    real::area
    character(len=20),dimension(4)::g_str
    real,dimension(3)::param
    g_str=[character(len=20)::"三角形","平行四边形","梯形","圆形"]
    write (*,*) "请输入计算的类型:"
    write (*,110) (i,g_str(i),i=1,4)
    110 format (I3,'-->',A20)
    read (*,"(I3)") g_type
    if (g_type>4 .or. g_type<1) stop
    i=1
    do while (i<4)
        write (*,"(A30,I1)") "请输入计算的参数",i
        read (*,"(F6.2)") p
        if (p>=0.) then
           param(i)=p
        else
           exit
        end if
        i=i+1
    end do
    call get_area(param,area,g_type)
    write (*,"(A20,A10,F10.2)") g_str(g_type),"面积：",area
end program

subroutine get_area(param,area,g_type)
  integer,intent(in):: g_type
  real,dimension(3),intent(in)::param
  real,intent(out):: area

  select case (g_type)
        case(1)
            area=(1/2.)*param(1)*param(2)
        case(2)
            area=param(1)*param(2)
        case(3)
            area=(1/2.)*(param(1)+param(2))*param(3)
        case(4)
            area=2.*3.1415*param(1)
  end select
end subroutine get_area

module

 请输入计算的类型:
  1-->平均速度(x1,x2,t1,t2)
  2-->平均速率(s,t1,t2)
2
 请输入s,t1,t2:
38,11,121
  0.345454544

Process returned 0 (0x0)   execution time : 10.317 s
Press any key to continue.

program learn
    use v_compute
    implicit none
    real::t1,t2,x1,x2,s,result
    integer::cpt_type,i
    character(len=40),dimension(2)::cpt_str

    cpt_str=[character(len=40)::"平均速度(x1,x2,t1,t2)","平均速率(s,t1,t2)"]
    write (*,*) "请输入计算的类型:"
    write (*,110) (i,cpt_str(i),i=1,2)
    110 format (I3,'-->',A40)
    read (*,"(I3)") cpt_type
    if (cpt_type>2 .or. cpt_type<1) stop
    select case(cpt_type)
        case(1)
            write (*,*) "请输入x1,x2,t1,t2:"
            read (*,*) x1,x2,t1,t2
            call get_v(x1,x2,t1,t2,result)
        case(2)
            write (*,*) "请输入s,t1,t2:"
            read (*,*) s,t1,t2
            call get_v(s,t1,t2,result)
    end select
    write (*,*) result
end program learn

v_compute.f90

module v_compute
implicit none

    interface get_v
        module procedure get_v1
        module procedure get_v2
    end interface
contains
     subroutine get_v1(x1,x2,t1,t2,result)
        !平均速度
        real,intent(out)::result
        real,intent(out)::x1,x2,t1,t2
        result=(x2-x1)/(t2-t1)
    end subroutine
    subroutine get_v2(s,t1,t2,result)
        !平均速率
        real,intent(out)::result
        real,intent(out)::s,t1,t2
        result=s/(t2-t1)
    end subroutine

end module v_compute

快排

  4
  8
  9
 22
 33
 34
 56
 88
 91
212

Process returned 0 (0x0)   execution time : 0.139 s
Press any key to continue.

program hello
    implicit none

    integer,dimension(10)::my_nums
    integer::i
    my_nums=[9,34,212,91,88,33,8,22,4,56]
    call qsort_nums(my_nums,1,10)
    write(*,"(I3)") [(my_nums(i),i=1,10)]


end program

recursive subroutine qsort_nums(nums,first,last)
    integer,intent(in)::first,last
    integer,dimension(n),intent(inout):: nums
    integer::i,j,key,temp
    if (last<=first) then
        return
    end if
    i=first
    j=last
    key=nums(first)
    sort:do
            i_next:do
                if (nums(i)<=key .and. i<last) then
                    i=i+1
                else
                    exit
                endif
            end do i_next
            j_prev:do
                if (nums(j)>key .and. j>first) then
                    j=j-1
                else
                    exit
                endif
            end do j_prev
            if (i<j) then
                temp=nums(i)
                nums(i)=nums(j)
                nums(j)=temp
            else
                exit sort
            end if
    end do sort
    nums(first)= nums(j);
    nums(j) = key;
    call qsort_nums(nums,first,j-1)
    call qsort_nums(nums,j+1,last)
end subroutine

函数

内部函数

program learn
    implicit none

    real::result,x
    x=11.33
    result=get_num(x)
    write (*,100) x,result
    100 format (2F10.2)
    contains
        real function get_num(x)
            real,intent(in)::x
            get_num=x*2
        end function get_num
end program learn

外部函数

program learn
    implicit none
    real::get_num
    real::result,x
    x=11.33
    result=get_num(x)
    write (*,100) x,result
    100 format (2F10.2)
end program learn


real function get_num(x)
    real,intent(in)::x
    get_num=x*2
end function get_num

二分法求解一元多次方程
main.f90


program hello
    use bisect
    implicit none
    real::root
    integer::err_flag
    character(len=50)::err_msg
    real,external::fun_root
    call get_root(fun_root,-20.,20.,1.0E-7,root,err_flag,err_msg)
    if (err_flag>0) then
        write (*,*) "error:",err_msg
    else
        write (*,*) root
    end if


end program

real function fun_root(x)
     implicit none
     real,intent(in)::x
     fun_root=5*x**3-3*x**2+111*x+21
end function fun_root

bisect.f90

module bisect
implicit none

contains
     subroutine get_root(func,x_a,x_b,tolerance,root,err_flag,err_msg)
        integer,intent(out)::err_flag
        character(len=50),intent(out)::err_msg
        real,external::func
        real,intent(out)::root
        real,intent(in)::x_a,x_b,tolerance
        real::a
        real::b
        real::fun_a,fun_b,fun_x,x
        a=x_a
        b=x_b
        fun_a=func(a)
        fun_b=func(b)
        if (fun_a*fun_b>=0) then
            err_flag=1
            err_msg="f(a)f(b)>0"
            return
        end if
        write (*,"(A1)",advance='no') "|"
        do while ((b-a)/2>tolerance)
            x=(a+b)/2
            fun_x=func(x)
            if (fun_x==0.) then
                exit
            endif
            if (fun_x*fun_a<0.) then
                b=x
                fun_b=fun_x
            else
                a=x
                fun_a=fun_x
            end if
            write (*,"(A1)",advance='no') "="
        end do
        write (*,"(A1/)",advance='no') ">"
        root=(a+b)/2
        err_flag=0
        err_msg=""
    end subroutine

end module bisect

|============================>
 -0.187935606

Process returned 0 (0x0)   execution time : 0.033 s
Press any key to continue.

正割法

|=============================>
  -1.31523108
.. 找到解
  -1.31523120

Process returned 0 (0x0)   execution time : 0.149 s
Press any key to continue.


program hello
    use equation_root
    implicit none
    real::root
    real::a,b
    integer::err_flag
    character(len=50)::err_msg
    real,external::fun_root
    a=-50.
    b=50.
    call get_root(2,fun_root,a,b,1.0E-7,1.0E-35,root,err_flag,err_msg,50)
    if (err_flag>0) then
        write (*,*) "error:",err_msg
    else
        write (*,*) root
    end if


end program

real function fun_root(x)
     implicit none
     real,intent(in)::x
     fun_root=x**3+9*cos(x)
end function fun_root

自定义类型

program learn
    implicit none
    type::student
        integer::student_id
        character(len=10)::student_name
        integer::age
        integer::class_id
    end type
    type::class
        integer::class_id
        character(len=50)::class_name
        integer::teacher_id!班主任ID
    end type
    type::student_score
        real::english_score
        real::math_score
        real::fortran_score
        real::cpp_score
        real::data_struct_score
        real::politics_score
        real::database_score
    end type
    type::teacher
        integer::teacher_id
        character(len=10)::teacher_name
        character(len=50)::degree!学位
    end type
    type(student) ::st1=student(1,"张三",25,1)
    write(*,*) st1%student_id,st1%student_name,st1%age,st1%class_id

end program learn

           1 张三                25           1

Process returned 0 (0x0)   execution time : 0.167 s
Press any key to continue.


# allocate可重新分配数组（动态数组）
```fotran
program learn
    implicit none
    integer,dimension(2,3)::a
    integer,dimension(2,3)::b
    integer,dimension(24)::c
    integer,dimension(:,:),allocatable::d
    integer::i,j
    integer::k
    a=reshape([1,2,66,89,74,79],[2,3],order=[1,2])
    b=reshape([1,2,76,99,84,59],[2,3],order=[1,2])
    write (*,120) 'aid','a1','a2','bid','b1','b2'
    c=[((a(i,:),b(j,:),i=1,2),j=1,2)]
    d=reshape(c,[2*2,3+3],order=[2,1])
    write (*,110) c
    write  (*,*) "---------"
    write (*,110) d(2,:)
    write  (*,*) "---------"
    write (*,110) d(:,2)
    write  (*,*) "---------"
    write  (*,*) "b1>70 and a2<70"
    write (*,120) 'aid','a1','a2','bid','b1','b2'
    !b1>70 and a2<90 选择
    k=1
    do
       if (d(k,5)>70 .and. d(k,3)<79) write (*,110) d(k,:)
       k=k+1
       if (k>4) exit
    end do
    write (*,120) 'aid','a1','a2','bid','b1','b2'
    !b1>70 and a2<90 选择+投影
    write  (*,*) "b1>70 and a2<70 and aid=bid"
    write (*,120) 'aid','a1','a2','b1','b2'
    k=1
    do
       if (d(k,5)>70 .and. d(k,3)<79 .and. d(k,1)==d(k,4)) write (*,110) d(k,1:3),d(k,5:6)
       k=k+1
       if (k>4) exit
    end do
    110 format (6(I3))
    120 format (6(A3))
end program learn

或者使用allocatte和deallocate

program learn
    implicit none
    integer::status
    integer,dimension(2,3)::a
    integer,dimension(2,3)::b
    integer,dimension(24)::c
    integer,dimension(:,:),allocatable::d
    integer::i,j
    integer::k
    a=reshape([1,2,66,89,74,79],[2,3],order=[1,2])
    b=reshape([1,2,76,99,84,59],[2,3],order=[1,2])
    write (*,120) 'aid','a1','a2','bid','b1','b2'
    c=[((a(i,:),b(j,:),i=1,2),j=1,2)]
    allocate(d(2+2,3+3),stat=status)
    d=reshape(c,[2+2,3+3],order=[2,1])
    write (*,110) c
    write  (*,*) "---------"
    write (*,110) d(2,:)
    write  (*,*) "---------"
    write (*,110) d(:,2)
    write  (*,*) "---------"
    write  (*,*) "b1>70 and a2<70"
    write (*,120) 'aid','a1','a2','bid','b1','b2'
    !b1>70 and a2<90 选择
    k=1
    do
       if (d(k,5)>70 .and. d(k,3)<79) write (*,110) d(k,:)
       k=k+1
       if (k>4) exit
    end do
    write (*,120) 'aid','a1','a2','bid','b1','b2'
    !b1>70 and a2<90 选择+投影
    write  (*,*) "b1>70 and a2<70 and aid=bid"
    write (*,120) 'aid','a1','a2','b1','b2'
    k=1
    do
       if (d(k,5)>70 .and. d(k,3)<79 .and. d(k,1)==d(k,4)) write (*,110) d(k,1:3),d(k,5:6)
       k=k+1
       if (k>4) exit
    end do
    110 format (6(I3))
    120 format (6(A3))
    deallocate(d,stat=status)
end program learn

使用自定义类型

program learn
    implicit none
    type::student
        integer::student_id
        character(len=10)::student_name
        integer::age
    end type student
    type::student_score
        integer::student_id
        real::fortran_score
        real::cpp_score
        real::data_struct_score
    end type student_score

    type::student_info
        type(student)::student_base_info
        type(student_score)::score
    end type student_info




    type(student),dimension(:),allocatable::st
    type(student_score),dimension(:),allocatable::st_scores
    type(student_info),dimension(:),allocatable::all_datas
    type(student) ::st1=student(1,"张三",25)
    type(student_score) ::st_score1=student_score(1,88.32,75.51,93.55)
    type(student) ::st2=student(2,"李四",26)
    type(student_score) ::st_score2=student_score(2,68.32,72.51,73.55)
    type(student) ::st3=student(3,"王五",29)
    type(student_score) ::st_score3=student_score(3,78.32,92.51,83.55)
    integer::i
    integer::j
    integer::k

    st=[st1,st2,st3]
    st_scores=[st_score1,st_score2,st_score3]
    all_datas=[((student_info(st(i),st_scores(j)),i=1,3),j=1,3)]
    write (*,110) all_datas
    110 format (I3,A8,I3,I3,F6.2,F6.2,F6.2)
    120 format (I3,A8,I3,F6.2,F6.2,F6.2)
    !age>23 and fortran_score>75 选择+投影
    write  (*,*) "age>23 and fortran_score>75"
    k=1
    do
       if (all_datas(k)%student_base_info%age>25 .and. all_datas(k)%score%fortran_score>75 &
          .and.  all_datas(k)%student_base_info%student_id==all_datas(k)%score%student_id) then
            write (*,120) all_datas(k)%student_base_info,&
            all_datas(k)%score%fortran_score,all_datas(k)%score%cpp_score,all_datas(k)%score%data_struct_score
       endif
       k=k+1
       if (k>9) exit
    end do

end program learn

  1张三     25  1 88.32 75.51 93.55
  2李四     26  1 88.32 75.51 93.55
  3王五     29  1 88.32 75.51 93.55
  1张三     25  2 68.32 72.51 73.55
  2李四     26  2 68.32 72.51 73.55
  3王五     29  2 68.32 72.51 73.55
  1张三     25  3 78.32 92.51 83.55
  2李四     26  3 78.32 92.51 83.55
  3王五     29  3 78.32 92.51 83.55
 age>23 and fortran_score>75
  3王五     29 78.32 92.51 83.55

Process returned 0 (0x0)   execution time : 0.045 s
Press any key to continue.

forall

可自动并行化，不按顺序执行

program learn
    implicit none
    real::get_num
    integer::i
    real,dimension(6)::x=[1.,2.,3.,4.,5.,6.]
    real,dimension(6)::result
    forall(i=1:6)
        result(i)=get_num(x(i))
    end forall
    write (*,*) x,result
end program learn

pure function get_num(x)
    real,intent(in)::x
    real::get_num
    get_num=x*2
end function get_num

program learn
    implicit none
    type::student
        integer::student_id
        character(len=10)::student_name
        integer::age
    end type student
    type::student_score
        integer::student_id
        real::fortran_score
        real::cpp_score
        real::data_struct_score
    end type student_score

    type::student_info
        type(student)::student_base_info
        type(student_score)::score
    end type student_info




    type(student),dimension(:),allocatable::st
    type(student_score),dimension(:),allocatable::st_scores
    type(student_info),dimension(:),allocatable::all_datas
    type(student_info),dimension(:),allocatable::datas
    type(student) ::st1=student(1,"张三",25)
    type(student_score) ::st_score1=student_score(1,88.32,75.51,93.55)
    type(student) ::st2=student(2,"李四",26)
    type(student_score) ::st_score2=student_score(2,68.32,72.51,73.55)
    type(student) ::st3=student(3,"王五",29)
    type(student_score) ::st_score3=student_score(3,78.32,92.51,83.55)
    integer::i
    integer::j
    integer::k
    integer::status

    st=[st1,st2,st3]
    st_scores=[st_score1,st_score2,st_score3]
    all_datas=[((student_info(st(i),st_scores(j)),i=1,3),j=1,3)]
    allocate(datas(9),stat=status)
    write (*,110) all_datas
    110 format (I3,A8,I3,I3,F6.2,F6.2,F6.2)

    !age>23 and fortran_score>75 选择+投影
    write  (*,*) "age>23 and fortran_score>75"

    forall(k=1:9,&
           all_datas(k)%score%fortran_score>75 &
          .and.  all_datas(k)%student_base_info%student_id==all_datas(k)%score%student_id)
          datas(k)=all_datas(k)
    end forall
    k=1
    do
        if (datas(k)%student_base_info%student_id>0) write (*,110) datas(k)
        k=k+1
        if (k>9) exit
    end do
    deallocate(datas,stat=status)

end program learn

where

比循环每个元素更具有效率优势，尤其是多维数组。

program learn
    implicit none
    integer,dimension(10)::x=[1,2,3,4,5,6,7,8,9,10]
    logical,dimension(10)::is_even_number
    where (mod(x,2)==0)
         is_even_number=.true.
    elsewhere
         is_even_number=.false.
    endwhere
    write (*,*) x,is_even_number

end program learn

element

逐元函数

program learn
    implicit none
    real::x=22.
    real::result
    interface
        elemental real function get_num(x)
            implicit none
            real,intent(in)::x
        endfunction
    end interface
    result=get_num(x)
    write (*,*) result


end program learn

elemental function get_num(x)
    implicit none
    real,intent(in)::x
    real::get_num
    get_num=x*2.
end function get_num

program learn
    implicit none
    real,dimension(3)::x=[11.,22.,33.]
    real,dimension(3)::result
    integer::i
    interface
        elemental real function get_num(x)
            implicit none
            real,intent(in)::x
        endfunction
    end interface
    forall(i=1:3)
        result(i)=get_num(x(i))
    end forall
    write (*,*) result

end program learn

elemental function get_num(x)
    implicit none
    real,intent(in)::x
    real::get_num
    get_num=x*2.
end function get_num

program learn
    implicit none
    real,dimension(3)::x=[11.,22.,33.]
    real,dimension(3)::result
    interface
        elemental real function get_num(x)
            implicit none
            real,intent(in)::x
        endfunction
    end interface
    result=get_num(x)
    write (*,*) result


end program learn

elemental function get_num(x)
    implicit none
    real,intent(in)::x
    real::get_num
    get_num=x*2.
end function get_num

不定结构的数组参数

program learn
    implicit none
    real,dimension(3)::x=[11.,22.,33.]
    real,dimension(3)::result
    interface
        subroutine get_num(x,result)
            implicit none
            real,intent(in),dimension(:)::x
            real,intent(out),dimension(:)::result
        end subroutine
    end interface
    call get_num(x,result)
    write(*,*) x,result

end program learn

subroutine get_num(x,result)
    implicit none
    real,intent(in),dimension(:)::x
    real,intent(out),dimension(:)::result
    result=x*2.
end subroutine get_num

高斯消元法


program hello
    use gauss
    implicit none
    integer,parameter::mat_n=3
    real,dimension(mat_n)::roots
    real,dimension(mat_n)::b=[3,3,-6]
    character(len=50)::a_format
    real,dimension(mat_n,mat_n)::a=reshape([1,2,-3,2,1,1,-1,-2,1],[mat_n,mat_n],order=[1,2])
    integer::err_flag
    character(len=50)::err_msg
    write (a_format,"(I1,(A9))") mat_n,"(F6.2,1x)"


    call gauss_roots(a,b,mat_n,roots,err_flag,err_msg)
    if (err_flag>0) then
        write (*,*) "error:",err_msg
    else
        a=reshape(a,[mat_n,mat_n],order=[2,1])
        write (*,*) "a="
        write (*,"("//a_format//")") a
        write (*,*) "b="
        write (*,*) b
        write (*,*) "x="
        write (*,*) roots
    end if
end program

 a=
  1.00   2.00  -1.00
  0.00  -3.00   0.00
  0.00   0.00  -2.00
 b=
   3.00000000      -3.00000000      -4.00000000
 x=
   3.00000000       1.00000000       2.00000000

Process returned 0 (0x0)   execution time : 0.182 s
Press any key to continue.

Collaborative Filtering协同过滤

欧几里德距离


program learn
    use eds
    implicit none
    integer,parameter::n=2
    real::similar_distance
    similar_distance=euclidean_distance_score([4.5,1.],[4.,2.],2)
    write(*,*) similar_distance




end program learn

module eds
implicit none
contains
    function euclidean_distance_score(x,y,n)
        real::euclidean_distance_score
        real,dimension(n),intent(in)::x,y
        integer,intent(in)::n
        real::distance
        distance=sqrt(sum((x-y)**2))
        euclidean_distance_score= 1./(1+distance)
    end function euclidean_distance_score


end module eds