我扩展了此功能并用于我的目的多年,我认为将其分发给需要它的其他人是有益的。!ErrorMsg 只是一个简单的子程序,例如 echo/print 语句。
subroutine Unique2DArray_D(Arr_a,dim,dup,diff)
IMPLICIT NONE
real*8,DIMENSION(:,:),allocatable::Arr_a,Arr_b
integer,intent(in),optional::dim
integer,allocatable,optional::dup(:)
real*8,optional::diff
LOGICAL,DIMENSION(:), allocatable::TF(:,:),mask
INTEGER,DIMENSION(:),allocatable::index_vector
INTEGER::i,j,numrows,numcols,ns,dim_
real*8::diff_
logical::pres_dim,pres_dup
numrows=size(Arr_a,1); numcols=size(Arr_a,2);
pres_dim=present(dim); pres_dup=present(dup)
! Arr_a(1,:)=[1,2,4,5,5,9,6,8,2,5,4]
! Arr_a(2,:)=[5,2,5,6,7,6,6,3,7,6,6]
dim_=1; if(pres_dim)dim_=dim; diff_=1d-20; if(present(diff))diff_=diff
if(dim_==2)then
ALLOCATE(mask(numcols),TF(numrows,numcols)); mask=.TRUE.;
DO j=numcols,2,-1
TF(:,j-1)=.false.
do i=1,numrows
TF(i,:j-1)=(abs(Arr_a(i,:j-1)-Arr_a(i,j))<=diff_)
end do;
mask(j)=.not.any(all(TF(:,:j-1),dim=1))
END DO
! Make an index vector
ns=size(PACK([(i,i=1,numcols)],mask));
ALLOCATE(index_vector(ns)); index_vector=PACK([(i,i=1,numcols)],mask)
! Now copy the unique elements of a into b
if(pres_dup)then;
allocate(dup(numcols-ns)); dup=PACK([(i,i=1,numcols)],.not.mask)
end if
ALLOCATE(Arr_b(numrows,ns)); Arr_b=Arr_a(:,index_vector)
elseif(dim_==1)then
! Arr_a(:,1)=[1, ! Arr_a(:,2)=[5,]
! 2, 2,
! 4, 5,
! 5, 6,
! 5, 7,
! 9, 6,
! 6, 6,
! 8, 3,
! 2, 7,
! 5, 6,
! 4] 6]
ALLOCATE(mask(numrows),TF(numrows,numcols)); mask=.TRUE.;
DO i=numrows,2,-1
TF(i-1,:)=.false.
do j=1,numcols
TF(:i-1,j)=(abs(Arr_a(:i-1,j)-Arr_a(i,j))<=diff_)
end do;
mask(i)=.not.any(all(TF(:i-1,:),dim=2))
END DO
! Make an index vector
ns=size(PACK([(i,i=1,numrows)],mask));
ALLOCATE(index_vector(ns)); index_vector=PACK([(i,i=1,numrows)],mask)
! Now copy the unique elements of a into b
if(pres_dup)then;
allocate(dup(numrows-ns)); dup=PACK([(i,i=1,numrows)],.not.mask)
end if
ALLOCATE(Arr_b(ns,numcols)); Arr_b=Arr_a(index_vector,:)
!ALLOCATE(Arr_b,source=Arr_a(index_vector,:))
else
call ErrorMsg('Dim is incorrect in Unique2DArrayD!',-1)
end if
call move_alloc(Arr_b,Arr_a)
end subroutine Unique2DArray_D