不定数量的多重循环简单实现

不定数量的多重循环简单实现

---

要点概览

1. 目的
   
   • 实现不定数量的多重(层)循环
   • 循环层数可以是1到n
   • 不同层的循环数可以是不同的
2. 运行环境
   
   • windows系统：64位win7
   • fotran编译器：mingw gfortran
3. 注意/思路：
   
   • 降维给出包含全部遍历的数组
   • 递归代替循环实现遍历

---

多重循环是很简单的事情，c中多写几个for就可以了。fortran给出几重do和end do也OK。

比如三种循环:

    do i=1,ni
        do j=1,nj
            do k=1,nk
                write(*,*) 'code block for each ijk=',i,j,k
            end do
        end do
    end do

可以看到当已知循环的层数的时候，写出多重循环结构就可以了。而且遍历数可以利用输入参数随意改变。
但是当循环的层数不定的时候，有没有办法给出可变的多重循环结构呢？

答案显然是有的，有一种比较直接的解决思路就是递归。而另一种则是利用数组写出所有遍历情况的循环变量值列表，
做多重循环等价于利用这些循环变量值列表做计算，下面分别展开说明:

利用遍历情况数组给出的不定数量多重循环

这里给出了模块，全局变量nergodic是遍历状态的总数，数组vergodic则记录所有遍历状态的循环变量取值。
给出两个子程序，差异在于对于输入参数处理得到的多重循环的内外顺序不同。即循环结构是根据输入的循环变量顺序从外到内还是从内到外。
其中mloopasrcsv的结果是模拟递归的多重循环内外顺序，即第一个变量在最外层，最后一个变量在最内层。
而mloopdiff的结果是第一个变量在最内层，最后一个变量在最外层。

module multiloop
    integer::nergodic !多层循环的遍历总数
    integer,allocatable::vergodic(:,:) !记录所有遍历的循环变量取值

    contains


    !每一重循环的数量可能不同，可能相同,模拟递归的内外层顺序。
    !第一个变量在最外层，最后一个变量在最内层，因为最后一个变量先变化
    !输入参数:
    !nvars_ml，多重循环的层数
    !vmaxs_ml(nvars_ml)，多重循环各层的循环变量的最大取值构成的数组
    subroutine mloopasrcsv(nvars_ml,vmaxs_ml)
    implicit none
    integer::nvars_ml  !循环的层数
    integer::vmaxs_ml(nvars_ml)   !给出各层循环的循环变量最大值列表
    integer::ndims,ndim
    integer::i,j,k,ii
    integer,allocatable::array(:,:)

    ndims=1
    do i=1,nvars_ml
        ndims=ndims*vmaxs_ml(i)
    end do

    allocate(array(ndims,nvars_ml))
    if(allocated(vergodic)) then
        deallocate(vergodic)
        allocate(vergodic(ndims,nvars_ml))
    else
        allocate(vergodic(ndims,nvars_ml))
    end if

    array=0
    ndim=1
    do  k=1,nvars_ml!将多重循环的所有循环变量的遍历值写入2维数组中，第一维是遍历数，第二维记录对应每一遍历数的训练变量

        !一个循环变量一个循环变量的填
        if(k==1) then  !第一个循环变量填入第二维第一个位置
            do i=1,vmaxs_ml(nvars_ml)
                array(i,:)=(/(1,ii=2,nvars_ml),i/)
            end do
            ndim=ndim*vmaxs_ml(nvars_ml)

        else if(k<nvars_ml) then !接下来的循环变量，填入第二个位置，前面位置的信息采用复制信息
            do j=1,vmaxs_ml(nvars_ml-k+1)
                do i=1,ndim
                    array((j-1)*ndim+i,:)=(/(1,ii=k+1,nvars_ml),j,array(i,nvars_ml-k+2:nvars_ml)/)
                end do
            end do
            ndim=ndim*vmaxs_ml(nvars_ml-k+1)

        else
            do j=1,vmaxs_ml(1)
                do i=1,ndim
                    array((j-1)*ndim+i,:)=(/j,array(i,2:nvars_ml)/)
                end do
            end do
        end if

    end do

    do i=1,ndims
        write(*,*) i,'th code block for each vars are',array(i,:)
    end do

    nergodic=ndims
    vergodic=array
    write(*,*) 'total number for ergodic',nergodic

    end subroutine

    !每一重循环的数量可能不同，可能相同
    !第一个变量在最内层，最后一个变量在最外层，因为第一个变量先变化
    !输入参数:
    !nvars_ml，多重循环的层数
    !vmaxs_ml(nvars_ml)，多重循环各层的循环变量的最大取值构成的数组
    subroutine mloopdiff(nvars_ml,vmaxs_ml)
    implicit none
    integer::nvars_ml  !循环的层数
    integer::vmaxs_ml(nvars_ml)   !给出各层循环的循环变量最大值列表
    integer::ndims,ndim
    integer::i,j,k,ii
    integer,allocatable::array(:,:)

    ndims=1
    do i=1,nvars_ml
        ndims=ndims*vmaxs_ml(i)
    end do

    allocate(array(ndims,nvars_ml))
    if(allocated(vergodic)) then
        deallocate(vergodic)
        allocate(vergodic(ndims,nvars_ml))
    else
        allocate(vergodic(ndims,nvars_ml))
    end if

    array=0
    ndim=1
    do  k=1,nvars_ml!将多重循环的所有循环变量的遍历值写入2维数组中，第一维是遍历数，第二维记录对应每一遍历数的训练变量

        !一个循环变量一个循环变量的填
        if(k==1) then  !第一个循环变量填入第二维第一个位置
            do i=1,vmaxs_ml(k)
                array(i,:)=(/i,(1,ii=2,nvars_ml)/)
            end do
            ndim=ndim*vmaxs_ml(k)

        else if(k<nvars_ml) then !接下来的循环变量，填入第二个位置，前面位置的信息采用复制信息
            do j=1,vmaxs_ml(k)
                do i=1,ndim
                    array((j-1)*ndim+i,:)=(/array(i,1:k-1),j,(1,ii=k+1,nvars_ml)/)
                end do
            end do
            ndim=ndim*vmaxs_ml(k)

        else
            do j=1,vmaxs_ml(k)
                do i=1,ndim
                    array((j-1)*ndim+i,:)=(/array(i,1:k-1),j/)
                end do
            end do
        end if

    end do

    do i=1,ndims
        write(*,*) i,'th code block for each vars are',array(i,:)
    end do

    nergodic=ndims
    vergodic=array
    write(*,*) 'total number for ergodic',nergodic

    end subroutine

    end module

利用递归给出的不定数量多重循环

递归可以表示一种递进的结构，因此可以用来表示多重循环。假设当前处于递归深度1，针对该深度做循环并保存对应该深度的循环层的循环变量的值，并进入下一层的递归，处理对应下一层的循环层。这就是利用递归表示的不定数量多重循环的思路。这里给出模块，其中mlooprcsv是对输入参数和递归程序的封装，mloopinner是真正的递归程序。

module multiloop2
    integer::nergodic

    contains

    !递归实现多重循环的包装程序，使其与非递归方法输入参数一致
    !输入参数:
    !nvars_ml，多重循环的层数
    !vmaxs_ml(nvars_ml)，多重循环各层的循环变量的最大取值构成的数组
    subroutine mlooprcsv(nvars_ml,vmaxs_ml)
    integer::nvars_ml,vmaxs_ml(nvars_ml)
    integer::d,sn  !d为当前递归深度，snbeg为遍历过程当前状态的序号
    integer,allocatable::vnow(:) !vnow为遍历过程当前状态的各循环变量的值

    sn=0
    d=1
    allocate(vnow(nd))
    vnow=1

    call mloopinner(d,nvars_ml,vnow,vmaxs_ml,sn)

    deallocate(vnow)
    end subroutine


    !递归实现多重循环遍历，注意循环各层的内外关系
    !输入参数:
    !d，为当前递归深度，表示多重循环的第d层
    !nd，为总的递归深度，即总的多重循环层数
    !vnow，为当前状态的循环变量值列表
    !vend，为各层循环循环变量的最大值
    !sn，为当前状态的序号，即遍历序数
    recursive subroutine mloopinner(d,nd,vnow,vend,sn)
    implicit none
    integer::d,nd,sn
    integer::vnow(nd),vend(nd)
    integer::i

    if (d==nd) then

        do i=1,vend(nd)
            vnow(d)=i
            sn=sn+1
            write(*,*) sn,'th code block for each vars are',vnow(:)
        end do

    else if(d<nd .and. d>0) then

        do i=1,vend(d)
            vnow(d)=i
            call mloopinner(d+1,nd,vnow,vend,sn)
        end do

    else
        write(*,*) 'error!'
    end if

    nergodic=sn
    if(d==1) then !最外层结束后输出遍历总数
        write(*,*) 'total number for ergodic',nergodic
    end if

    end subroutine
    end module

小结

做两个函数，测试上述函数:

subroutine testb()
    use multiloop
    implicit none
    integer::nd,i
    integer,allocatable::vend(:)

    nd=3
    allocate(vend(nd))
    vend=(/2,3,4/)
    call mloopdiff(nd,vend)
    call mloopasrcsv(nd,vend)
    deallocate(vend)

    nd=1
    allocate(vend(nd))
    vend=(/10/)
    call mloopdiff(nd,vend)
    deallocate(vend)

    end subroutine

    subroutine testc()
    use multiloop2
    implicit none
    integer::nd,i
    integer,allocatable::vend(:)


    nd=3
    allocate(vend(nd))
    vend=(/2,3,4/)
    call mlooprcsv(nd,vend)
    deallocate(vend)

    nd=1
    allocate(vend(nd))
    vend=(/10/)
    call mlooprcsv(nd,vend)
    deallocate(vend)

    end subroutine

结果为:

===========================================
compile the f90 file with mpich2_gfortran
===========================================
===========================================
Run the executable file
===========================================
    1th code block for each vars are    1    1    1
    2th code block for each vars are    2    1    1
    3th code block for each vars are    1    2    1
    4th code block for each vars are    2    2    1
    5th code block for each vars are    1    3    1
    6th code block for each vars are    2    3    1
    7th code block for each vars are    1    1    2
    8th code block for each vars are    2    1    2
    9th code block for each vars are    1    2    2
   10th code block for each vars are    2    2    2
   11th code block for each vars are    1    3    2
   12th code block for each vars are    2    3    2
   13th code block for each vars are    1    1    3
   14th code block for each vars are    2    1    3
   15th code block for each vars are    1    2    3
   16th code block for each vars are    2    2    3
   17th code block for each vars are    1    3    3
   18th code block for each vars are    2    3    3
   19th code block for each vars are    1    1    4
   20th code block for each vars are    2    1    4
   21th code block for each vars are    1    2    4
   22th code block for each vars are    2    2    4
   23th code block for each vars are    1    3    4
   24th code block for each vars are    2    3    4
 total number for ergodic          24
    1th code block for each vars are    1    1    1
    2th code block for each vars are    1    1    2
    3th code block for each vars are    1    1    3
    4th code block for each vars are    1    1    4
    5th code block for each vars are    1    2    1
    6th code block for each vars are    1    2    2
    7th code block for each vars are    1    2    3
    8th code block for each vars are    1    2    4
    9th code block for each vars are    1    3    1
   10th code block for each vars are    1    3    2
   11th code block for each vars are    1    3    3
   12th code block for each vars are    1    3    4
   13th code block for each vars are    2    1    1
   14th code block for each vars are    2    1    2
   15th code block for each vars are    2    1    3
   16th code block for each vars are    2    1    4
   17th code block for each vars are    2    2    1
   18th code block for each vars are    2    2    2
   19th code block for each vars are    2    2    3
   20th code block for each vars are    2    2    4
   21th code block for each vars are    2    3    1
   22th code block for each vars are    2    3    2
   23th code block for each vars are    2    3    3
   24th code block for each vars are    2    3    4
 total number for ergodic          24
    1th code block for each vars are    1
    2th code block for each vars are    2
    3th code block for each vars are    3
    4th code block for each vars are    4
    5th code block for each vars are    5
    6th code block for each vars are    6
    7th code block for each vars are    7
    8th code block for each vars are    8
    9th code block for each vars are    9
   10th code block for each vars are   10
 total number for ergodic          10

    1th code block for each vars are    1    1    1
    2th code block for each vars are    1    1    2
    3th code block for each vars are    1    1    3
    4th code block for each vars are    1    1    4
    5th code block for each vars are    1    2    1
    6th code block for each vars are    1    2    2
    7th code block for each vars are    1    2    3
    8th code block for each vars are    1    2    4
    9th code block for each vars are    1    3    1
   10th code block for each vars are    1    3    2
   11th code block for each vars are    1    3    3
   12th code block for each vars are    1    3    4
   13th code block for each vars are    2    1    1
   14th code block for each vars are    2    1    2
   15th code block for each vars are    2    1    3
   16th code block for each vars are    2    1    4
   17th code block for each vars are    2    2    1
   18th code block for each vars are    2    2    2
   19th code block for each vars are    2    2    3
   20th code block for each vars are    2    2    4
   21th code block for each vars are    2    3    1
   22th code block for each vars are    2    3    2
   23th code block for each vars are    2    3    3
   24th code block for each vars are    2    3    4
 total number for ergodic          24
    1th code block for each vars are    1
    2th code block for each vars are    2
    3th code block for each vars are    3
    4th code block for each vars are    4
    5th code block for each vars are    5
    6th code block for each vars are    6
    7th code block for each vars are    7
    8th code block for each vars are    8
    9th code block for each vars are    9
   10th code block for each vars are   10
 total number for ergodic          10
请按任意键继续. . .

显然上述函数实现了不定数量的多重循环功能。

参考资料

无

ps:

好久不用fortran有些生疏了，突然发现fortran的动态数组有点像python的列表了，竟然不需要分配内存也可以使用的。
这是挺有意思的事情，看下面的示例:

subroutine testa()
    integer,allocatable::sa(:)
    integer::sb(2)
    integer::sc

    sa=(/1,2/) !动态数组完全不需要分配内存了。
    write(*,*) sa
    sb=(/1,2/) 
    write(*,*) sb
    !sc=(/1,2/) !错误，标量不能赋值为矢量
    !write(*,*) sc

    sa=(/1,2,3/)
    write(*,*) sa
    !sb=(/1,2,3/) !错误，固定数组形状不符
    !write(*,*) sb 

    sa=[1,2,3,4]
    write(*,*) sa

    sa=(/1,1/) !这里看出来sa变了，sa似乎有点类似python中的对象名了。
    write(*,*) sa(:)
    do i=1,4
        write(*,*) sa(i)
    end do

    deallocate(sa)
    allocate(sa(5)) !当前面一句不给出时，错误，因为给一个已经分配的数组再分配内存
    sa=[1,2,3,4,5]
    write(*,*) sa

    sa=[1,2,3,4,5,6]
    write(*,*) sa

    end subroutine

通过sa，sb，sc的比较可以发现，sa作为一个动态数组，可以不需要分配内存就直接赋值使用。而且换一个赋值语句增加数组长度仍然可以使用。
从分配内存操作的表现看，赋值命令(//)或[]自带内存分配和释放功能，当sa已经赋值为一个数组后，再次使用赋值命令，其中自带内存释放和分配。
当赋值后，手动使用allocate出错表明，此时数组已经分配内存，因此要手动再分配就需要将其先释放出来。

history：

v1.0 20180329 完成基本内容