[Fortran] 纯文本查看 复制代码
program main
implicit none
interface
subroutine PMF_unfold(A,ncmpx,ncmpy,nhx,nhy,f,B)
integer::icmpx,icmpy,ihx,ihy,m,n,f
integer::ncmpx,ncmpy,nhx,nhy
real*4::A(ncmpx,ncmpy,nhx,nhy)
real*4,pointer::B(:,:)
real*4,target::B1(ncmpx,ncmpy*nhx*nhy),B2(ncmpy,ncmpx*nhx*nhy),B3(nhx,ncmpx*ncmpy*nhy),B4(nhy,ncmpx*ncmpy*nhx)
end subroutine
end interface
!主函数
integer::icmpx,icmpy,ihx,ihy,f
real*4,allocatable::A1(:,:,:,:)
real*4,allocatable,target::B1(:,:),B2(:,:),B3(:,:),B4(:,:)
real*4,pointer::B(:,:)
integer::ncmpx,ncmpy,nhx,nhy
ncmpx=3
ncmpy=4
nhx=5
nhy=6
allocate(A1(ncmpx,ncmpy,nhx,nhy))
allocate(B1(ncmpx,ncmpy*nhx*nhy),B2(ncmpy,ncmpx*nhx*nhy),B3(nhx,ncmpx*ncmpy*nhy),B4(nhy,ncmpx*ncmpy*nhx))
!生成四维数组
do ihy=1,nhy
do ihx=1,nhx
do icmpy=1,ncmpy
do icmpx=1,ncmpx
A1(icmpx,icmpy,ihx,ihy)=icmpx+(icmpy-1)*ncmpx+(ihx-1)*ncmpx*ncmpy+(ihy-1)*nhx* ncmpx*ncmpy+1000
end do
end do
end do
end do
f=4!当F等于四时,调用函数
call PMF_unfold(A1,ncmpx,ncmpy,nhx,nhy,f,B)
write(*,*)B(5,:)
!子函数
subroutine PMF_unfold(A,ncmpx,ncmpy,nhx,nhy,f,B)
implicit none
integer::icmpx,icmpy,ihx,ihy,m,n,f
integer::ncmpx,ncmpy,nhx,nhy
real*4::A(ncmpx,ncmpy,nhx,nhy)
real*4,pointer::B(:,:)
real*4,target::B1(ncmpx,ncmpy*nhx*nhy),B2(ncmpy,ncmpx*nhx*nhy)
real*4,target::B1B3(nhx,ncmpx*ncmpy*nhy),B4(nhy,ncmpx*ncmpy*nhx)
!将四维数组沿第一维展开得到B1矩阵
if(f==1)then
do ihy=1,nhy
do ihx=1,nhx
do icmpy=1,ncmpy
do icmpx=1,ncmpx
m=icmpx
n=(ihy-1)*nhx*ncmpy+(ihx-1)*ncmpy+icmpy
B1(m,n)=A(icmpx,icmpy,ihx,ihy)
end do
end do
end do
end do
B=>B1(1:ncmpx,1:ncmpy*nhx*nhy)
end if
!沿第二维即cmpy维展开得到B2矩阵
if(f==2)then
do ihy=1,nhy
do ihx=1,nhx
do icmpy=1,ncmpy
do icmpx=1,ncmpx
m=icmpy
n=(icmpx-1)*nhy*nhx+(ihy-1)*nhx+ihx
B2(m,n)=A(icmpx,icmpy,ihx,ihy)
end do
end do
end do
end do
B=>B2(:,:)
end if
!沿着第三维即hx维展开得到B3矩阵
if(f==3)then
do ihy=1,nhy
do ihx=1,nhx
do icmpy=1,ncmpy
do icmpx=1,ncmpx
m=ihx
n=(icmpy-1)*nhy*ncmpx+(icmpx-1)*nhy+ihy
B3(m,n)=A(icmpx,icmpy,ihx,ihy)
end do
end do
end do
end do
B=>B3(:,:)
end if
!沿第四维即hy维展开得到B4矩阵
if(f==4)then
do ihy=1,nhy
do ihx=1,nhx
do icmpy=1,ncmpy
do icmpx=1,ncmpx
m=ihy
n=(ihx-1)*ncmpy*ncmpx+(icmpy-1)*ncmpx+icmpx
B4(m,n)=A(icmpx,icmpy,ihx,ihy)
end do
end do
end do
end do
B=>B4(:,:)
end if
end subroutine