Fortran 90 MODULE mod_reorder_dims
!>============================================================================<
! FILE: /fs/cgd/home0/davestep/f90_routines/MOD_mod_reorder_dims.f90
! AUTHOR: David Stepaniak, NCAR/CGD/CAS
! DATE INITIATED: 12 October 1998
! LAST MODIFIED: Thu Oct 15 12:50:38 MDT 1998
!
! DESCRIPTION: This file is a MODULE (mod_reorder_dims) which contains a
! generic subroutine (reorder_dims) and its specific
! subroutines declared as MODULE PROCEDUREs (reorder_dims_2D,
! reorder_dims_3D, reorder_dims_4D, and reorder_dims_5D).
! The generic subroutine reorder_dims accepts as input a
! multidimensional array of rank 2,3,4, or 5, and reorders
! the dimensions of the input array according to a user-defined
! permutation of integers representing the dimensions of the
! input array.
!
! A concrete example will better illustrate what is being
! described. Suppose that A is an array of rank 3 (three
! dimensions) where A = A(lvl,lat,lon) and SHAPE(A) =
! (/nlvl,nlat,nlon/). Then, the following invocation
!
! INTEGER :: nlvl
! INTEGER :: nlat
! INTEGER :: nlon
! ...
! REAL, DIMENSION(nlvl,nlat,nlon) :: A
! REAL, DIMENSION(nlon,nlat,nlvl) :: B
! ...
! CALL reorder_dims( A, (/3,2,1/), B )
!
! produces an output array B of rank 3, dimensions ordered
! B = B(lon,lat,lvl) and SHAPE(B) = (/nlon,nlat,nlvl/).
!
! RESTRICTIONS: The rank (number of dimensions) of A is 2,3,4, or 5. The
! extent of each dimension of A and B must be > 1. The output
! array B must be declared and dimensioned correctly before it
! is used as an argument to 'reorder_dims'. The arrays A and B
! are of tpye REAL.
!
! NOTES: Keep in mind that this is a MODULE and that it must be
! compiled before all other source code. Also, in the calling
! program or subprogram a 'USE mod_reorder_dims' statement must
! be included, usually right after the PROGRAM, SUBROUTINE, or
! FUNCTION statment.
!
! Let rankA = SIZE(SHAPE(A)), i.e., rankA is the number of
! dimensions of A. Then the number of possible permutations
! of the reordering of the dimensions of A is (rankA)!,
! including the original ordering. All of the possible
! permutations of the reordering of the dimensions of A
! are accounted for by the MODULE PROCEDUREs for rank 2,3,4,
! and 5. (Similarly for rank 6 and 7 but I have chosen not to
! include these cases here. They can be made available upon
! request.)
!
!>============================================================================<
MODULE mod_reorder_dims
IMPLICIT NONE
!>----------------------------------------------------------------------------<
INTERFACE reorder_dims
MODULE PROCEDURE reorder_dims_2D
MODULE PROCEDURE reorder_dims_3D
MODULE PROCEDURE reorder_dims_4D
MODULE PROCEDURE reorder_dims_5D
END INTERFACE
!>----------------------------------------------------------------------------<
CONTAINS
SUBROUTINE reorder_dims_2D( A, dims_A_reorder, B )
IMPLICIT NONE
REAL, DIMENSION(:,:), INTENT(IN) :: A
INTEGER, DIMENSION(:), INTENT(IN) :: dims_A_reorder
REAL, DIMENSION(:,:), INTENT(OUT) :: B
INTEGER :: rank_A
INTEGER :: k
INTEGER, DIMENSION(:), ALLOCATABLE :: pos_ints
INTEGER :: nperms
INTEGER, DIMENSION(:,:), ALLOCATABLE :: dims_A_perms
INTEGER, DIMENSION(:,:), ALLOCATABLE :: dims_B_order
LOGICAL :: found
INTEGER, DIMENSION(:), ALLOCATABLE :: p
INTEGER, DIMENSION(:), ALLOCATABLE :: q
INTEGER, DIMENSION(:), ALLOCATABLE :: OB
INTEGER, DIMENSION(:), ALLOCATABLE :: SA
INTEGER, DIMENSION(:), ALLOCATABLE :: SB
INTEGER :: sum_abs_diff_pmq
rank_A = SIZE(SHAPE(A))
ALLOCATE( SA(rank_A) )
SA(:) = SHAPE(A)
ALLOCATE( SB(rank_A) )
SB(:) = SHAPE(B)
IF ( SIZE(SA) /= SIZE(SB) ) THEN
WRITE(*,*) "The ranks of A and B must be the same. "
WRITE(*,*) "Execution halted in SUBROUTINE reorder_dims_2D"
WRITE(*,*) "of MODULE mod_reorder_dims. "
STOP
END IF
IF ( ( ANY(SA == 1) ) .OR. ( ANY(SB == 1) ) ) THEN
WRITE(*,*) "The extent of each dimension of A and B must "
WRITE(*,*) "be > 1. "
WRITE(*,*) "Execution halted in SUBROUTINE reorder_dims_2D"
WRITE(*,*) "of MODULE mod_reorder_dims. "
STOP
END IF
IF ( &
( SB(1) /= SA(dims_A_reorder(1)) ) .OR. &
( SB(2) /= SA(dims_A_reorder(2)) ) &
) THEN
WRITE(*,*) "The shape of B is not correct. "
WRITE(*,*) "Execution halted in SUBROUTINE reorder_dims_2D"
WRITE(*,*) "of MODULE mod_reorder_dims. "
STOP
END IF
ALLOCATE( pos_ints( rank_A ) )
pos_ints = (/ ( k, k = 1, rank_A ) /)
nperms = PRODUCT( pos_ints )
DEALLOCATE( pos_ints )
ALLOCATE( dims_A_perms( nperms, rank_A ) )
ALLOCATE( dims_B_order( nperms, rank_A ) )
dims_A_perms(1,:) = (/1,2/)
dims_A_perms(2,:) = (/2,1/)
dims_B_order(1,:) = (/1,2/)
dims_B_order(2,:) = (/2,1/)
found = .FALSE.
ALLOCATE( p( rank_A ) )
ALLOCATE( q( rank_A ) )
ALLOCATE( OB( rank_A ) )
k = 0
DO
IF ( found ) EXIT
k = k + 1
p(:) = dims_A_perms(k,:)
q(:) = dims_A_reorder(:)
sum_abs_diff_pmq = SUM( ABS( p - q ) )
IF ( sum_abs_diff_pmq == 0 ) THEN
OB(:) = dims_B_order(k,:)
found = .TRUE.
END IF
IF ( k > nperms ) THEN
WRITE(*,*) "REORDERING OF DIMENSIONS OF A NOT VALID. "
WRITE(*,*) "Execution halted in SUBROUTINE reorder_dims_2D"
WRITE(*,*) "contained in MODULE mod_reorder_dims. "
STOP
END IF
END DO
DEALLOCATE( dims_A_perms )
DEALLOCATE( dims_B_order )
DEALLOCATE( p )
DEALLOCATE( q )
B(:,:) = RESHAPE(A, SHAPE = (/SB(1),SB(2)/), &
ORDER = (/OB(1),OB(2)/) )
DEALLOCATE( SA )
DEALLOCATE( SB )
DEALLOCATE( OB )
END SUBROUTINE reorder_dims_2D
SUBROUTINE reorder_dims_3D( A, dims_A_reorder, B )
IMPLICIT NONE
REAL, DIMENSION(:,:,:), INTENT(IN) :: A
INTEGER, DIMENSION(:) , INTENT(IN) :: dims_A_reorder
REAL, DIMENSION(:,:,:), INTENT(OUT) :: B
INTEGER :: rank_A
INTEGER :: k
INTEGER, DIMENSION(:), ALLOCATABLE :: pos_ints
INTEGER :: nperms
INTEGER, DIMENSION(:,:), ALLOCATABLE :: dims_A_perms
INTEGER, DIMENSION(:,:), ALLOCATABLE :: dims_B_order
LOGICAL :: found
INTEGER, DIMENSION(:), ALLOCATABLE :: p
INTEGER, DIMENSION(:), ALLOCATABLE :: q
INTEGER, DIMENSION(:), ALLOCATABLE :: OB
INTEGER, DIMENSION(:), ALLOCATABLE :: SA
INTEGER, DIMENSION(:), ALLOCATABLE :: SB
INTEGER :: sum_abs_diff_pmq
rank_A = SIZE(SHAPE(A))
ALLOCATE( SA(rank_A) )
SA(:) = SHAPE(A)
ALLOCATE( SB(rank_A) )
SB(:) = SHAPE(B)
IF ( SIZE(SA) /= SIZE(SB) ) THEN
WRITE(*,*) "The ranks of A and B must be the same. "
WRITE(*,*) "Execution halted in SUBROUTINE reorder_dims_3D"
WRITE(*,*) "of MODULE mod_reorder_dims. "
STOP
END IF
IF ( ( ANY(SA == 1) ) .OR. ( ANY(SB == 1) ) ) THEN
WRITE(*,*) "The extent of each dimension of A and B must "
WRITE(*,*) "be > 1. "
WRITE(*,*) "Execution halted in SUBROUTINE reorder_dims_3D"
WRITE(*,*) "of MODULE mod_reorder_dims. "
STOP
END IF
IF ( &
( SB(1) /= SA(dims_A_reorder(1)) ) .OR. &
( SB(2) /= SA(dims_A_reorder(2)) ) .OR. &
( SB(3) /= SA(dims_A_reorder(3)) ) &
) THEN
WRITE(*,*) "The shape of B is not correct. "
WRITE(*,*) "Execution halted in SUBROUTINE reorder_dims_3D"
WRITE(*,*) "of MODULE mod_reorder_dims. "
STOP
END IF
ALLOCATE( pos_ints( rank_A ) )
pos_ints = (/ ( k, k = 1, rank_A ) /)
nperms = PRODUCT( pos_ints )
DEALLOCATE( pos_ints )
ALLOCATE( dims_A_perms( nperms, rank_A ) )
ALLOCATE( dims_B_order( nperms, rank_A ) )
dims_A_perms(1,:) = (/1,2,3/)
dims_A_perms(2,:) = (/1,3,2/)
dims_A_perms(3,:) = (/2,1,3/)
dims_A_perms(4,:) = (/2,3,1/)
dims_A_perms(5,:) = (/3,1,2/)
dims_A_perms(6,:) = (/3,2,1/)
dims_B_order(1,:) = (/1,2,3/)
dims_B_order(2,:) = (/1,3,2/)
dims_B_order(3,:) = (/2,1,3/)
dims_B_order(4,:) = (/3,1,2/)
dims_B_order(5,:) = (/2,3,1/)
dims_B_order(6,:) = (/3,2,1/)
found = .FALSE.
ALLOCATE( p( rank_A ) )
ALLOCATE( q( rank_A ) )
ALLOCATE( OB( rank_A ) )
k = 0
DO
IF ( found ) EXIT
k = k + 1
p(:) = dims_A_perms(k,:)
q(:) = dims_A_reorder(:)
sum_abs_diff_pmq = SUM( ABS( p - q ) )
IF ( sum_abs_diff_pmq == 0 ) THEN
OB(:) = dims_B_order(k,:)
found = .TRUE.
END IF
IF ( k > nperms ) THEN
WRITE(*,*) "REORDERING OF DIMENSIONS OF A NOT VALID. "
WRITE(*,*) "Execution halted in SUBROUTINE reorder_dims_3D"
WRITE(*,*) "contained in MODULE mod_reorder_dims. "
STOP
END IF
END DO
DEALLOCATE( dims_A_perms )
DEALLOCATE( dims_B_order )
DEALLOCATE( p )
DEALLOCATE( q )
B(:,:,:) = RESHAPE(A, SHAPE = (/SB(1),SB(2),SB(3)/), &
ORDER = (/OB(1),OB(2),OB(3)/) )
DEALLOCATE( SA )
DEALLOCATE( SB )
DEALLOCATE( OB )
END SUBROUTINE reorder_dims_3D
SUBROUTINE reorder_dims_4D( A, dims_A_reorder, B )
IMPLICIT NONE
REAL, DIMENSION(:,:,:,:), INTENT(IN) :: A
INTEGER, DIMENSION(:) , INTENT(IN) :: dims_A_reorder
REAL, DIMENSION(:,:,:,:), INTENT(OUT) :: B
INTEGER :: rank_A
INTEGER :: k
INTEGER, DIMENSION(:), ALLOCATABLE :: pos_ints
INTEGER :: nperms
INTEGER, DIMENSION(:,:), ALLOCATABLE :: dims_A_perms
INTEGER, DIMENSION(:,:), ALLOCATABLE :: dims_B_order
LOGICAL :: found
INTEGER, DIMENSION(:), ALLOCATABLE :: p
INTEGER, DIMENSION(:), ALLOCATABLE :: q
INTEGER, DIMENSION(:), ALLOCATABLE :: OB
INTEGER, DIMENSION(:), ALLOCATABLE :: SA
INTEGER, DIMENSION(:), ALLOCATABLE :: SB
INTEGER :: sum_abs_diff_pmq
rank_A = SIZE(SHAPE(A))
ALLOCATE( SA(rank_A) )
SA(:) = SHAPE(A)
ALLOCATE( SB(rank_A) )
SB(:) = SHAPE(B)
IF ( SIZE(SA) /= SIZE(SB) ) THEN
WRITE(*,*) "The ranks of A and B must be the same. "
WRITE(*,*) "Execution halted in SUBROUTINE reorder_dims_4D"
WRITE(*,*) "of MODULE mod_reorder_dims. "
STOP
END IF
IF ( ( ANY(SA == 1) ) .OR. ( ANY(SB == 1) ) ) THEN
WRITE(*,*) "The extent of each dimension of A and B must "
WRITE(*,*) "be > 1. "
WRITE(*,*) "Execution halted in SUBROUTINE reorder_dims_4D"
WRITE(*,*) "of MODULE mod_reorder_dims. "
STOP
END IF
IF ( &
( SB(1) /= SA(dims_A_reorder(1)) ) .OR. &
( SB(2) /= SA(dims_A_reorder(2)) ) .OR. &
( SB(3) /= SA(dims_A_reorder(3)) ) .OR. &
( SB(4) /= SA(dims_A_reorder(4)) ) &
) THEN
WRITE(*,*) "The shape of B is not correct. "
WRITE(*,*) "Execution halted in SUBROUTINE reorder_dims_4D"
WRITE(*,*) "of MODULE mod_reorder_dims. "
STOP
END IF
ALLOCATE( pos_ints( rank_A ) )
pos_ints = (/ ( k, k = 1, rank_A ) /)
nperms = PRODUCT( pos_ints )
DEALLOCATE( pos_ints )
ALLOCATE( dims_A_perms( nperms, rank_A ) )
ALLOCATE( dims_B_order( nperms, rank_A ) )
dims_A_perms(1,:) = (/1,2,3,4/)
dims_A_perms(2,:) = (/1,2,4,3/)
dims_A_perms(3,:) = (/1,3,2,4/)
dims_A_perms(4,:) = (/1,3,4,2/)
dims_A_perms(5,:) = (/1,4,2,3/)
dims_A_perms(6,:) = (/1,4,3,2/)
dims_B_order(1,:) = (/1,2,3,4/)
dims_B_order(2,:) = (/1,2,4,3/)
dims_B_order(3,:) = (/1,3,2,4/)
dims_B_order(4,:) = (/1,4,2,3/)
dims_B_order(5,:) = (/1,3,4,2/)
dims_B_order(6,:) = (/1,4,3,2/)
dims_A_perms(7,:) = (/2,1,3,4/)
dims_A_perms(8,:) = (/2,1,4,3/)
dims_A_perms(9,:) = (/2,3,1,4/)
dims_A_perms(10,:) = (/2,3,4,1/)
dims_A_perms(11,:) = (/2,4,1,3/)
dims_A_perms(12,:) = (/2,4,3,1/)
dims_B_order(7,:) = (/2,1,3,4/)
dims_B_order(8,:) = (/2,1,4,3/)
dims_B_order(9,:) = (/3,1,2,4/)
dims_B_order(10,:) = (/4,1,2,3/)
dims_B_order(11,:) = (/3,1,4,2/)
dims_B_order(12,:) = (/4,1,3,2/)
dims_A_perms(13,:) = (/3,1,2,4/)
dims_A_perms(14,:) = (/3,1,4,2/)
dims_A_perms(15,:) = (/3,2,1,4/)
dims_A_perms(16,:) = (/3,2,4,1/)
dims_A_perms(17,:) = (/3,4,1,2/)
dims_A_perms(18,:) = (/3,4,2,1/)
dims_B_order(13,:) = (/2,3,1,4/)
dims_B_order(14,:) = (/2,4,1,3/)
dims_B_order(15,:) = (/3,2,1,4/)
dims_B_order(16,:) = (/4,2,1,3/)
dims_B_order(17,:) = (/3,4,1,2/)
dims_B_order(18,:) = (/4,3,1,2/)
dims_A_perms(19,:) = (/4,1,2,3/)
dims_A_perms(20,:) = (/4,1,3,2/)
dims_A_perms(21,:) = (/4,2,1,3/)
dims_A_perms(22,:) = (/4,2,3,1/)
dims_A_perms(23,:) = (/4,3,1,2/)
dims_A_perms(24,:) = (/4,3,2,1/)
dims_B_order(19,:) = (/2,3,4,1/)
dims_B_order(20,:) = (/2,4,3,1/)
dims_B_order(21,:) = (/3,2,4,1/)
dims_B_order(22,:) = (/4,2,3,1/)
dims_B_order(23,:) = (/3,4,2,1/)
dims_B_order(24,:) = (/4,3,2,1/)
found = .FALSE.
ALLOCATE( p( rank_A ) )
ALLOCATE( q( rank_A ) )
ALLOCATE( OB( rank_A ) )
k = 0
DO
IF ( found ) EXIT
k = k + 1
p(:) = dims_A_perms(k,:)
q(:) = dims_A_reorder(:)
sum_abs_diff_pmq = SUM( ABS( p - q ) )
IF ( sum_abs_diff_pmq == 0 ) THEN
OB(:) = dims_B_order(k,:)
found = .TRUE.
END IF
IF ( k > nperms ) THEN
WRITE(*,*) "REORDERING OF DIMENSIONS OF A NOT VALID. "
WRITE(*,*) "Execution halted in SUBROUTINE reorder_dims_4D"
WRITE(*,*) "contained in MODULE mod_reorder_dims. "
STOP
END IF
END DO
DEALLOCATE( dims_A_perms )
DEALLOCATE( dims_B_order )
DEALLOCATE( p )
DEALLOCATE( q )
B(:,:,:,:) = RESHAPE(A, SHAPE = (/SB(1),SB(2),SB(3),SB(4)/), &
ORDER = (/OB(1),OB(2),OB(3),OB(4)/) )
DEALLOCATE( SA )
DEALLOCATE( SB )
DEALLOCATE( OB )
END SUBROUTINE reorder_dims_4D
SUBROUTINE reorder_dims_5D( A, dims_A_reorder, B )
IMPLICIT NONE
REAL, DIMENSION(:,:,:,:,:), INTENT(IN) :: A
INTEGER, DIMENSION(:) , INTENT(IN) :: dims_A_reorder
REAL, DIMENSION(:,:,:,:,:), INTENT(OUT) :: B
INTEGER :: rank_A
INTEGER :: k
INTEGER, DIMENSION(:), ALLOCATABLE :: pos_ints
INTEGER :: nperms
INTEGER, DIMENSION(:,:), ALLOCATABLE :: dims_A_perms
INTEGER, DIMENSION(:,:), ALLOCATABLE :: dims_B_order
LOGICAL :: found
INTEGER, DIMENSION(:), ALLOCATABLE :: p
INTEGER, DIMENSION(:), ALLOCATABLE :: q
INTEGER, DIMENSION(:), ALLOCATABLE :: OB
INTEGER, DIMENSION(:), ALLOCATABLE :: SA
INTEGER, DIMENSION(:), ALLOCATABLE :: SB
INTEGER :: sum_abs_diff_pmq
rank_A = SIZE(SHAPE(A))
ALLOCATE( SA(rank_A) )
SA(:) = SHAPE(A)
ALLOCATE( SB(rank_A) )
SB(:) = SHAPE(B)
IF ( SIZE(SA) /= SIZE(SB) ) THEN
WRITE(*,*) "The ranks of A and B must be the same. "
WRITE(*,*) "Execution halted in SUBROUTINE reorder_dims_5D"
WRITE(*,*) "of MODULE mod_reorder_dims. "
STOP
END IF
IF ( ( ANY(SA == 1) ) .OR. ( ANY(SB == 1) ) ) THEN
WRITE(*,*) "The extent of each dimension of A and B must "
WRITE(*,*) "be > 1. "
WRITE(*,*) "Execution halted in SUBROUTINE reorder_dims_5D"
WRITE(*,*) "of MODULE mod_reorder_dims. "
STOP
END IF
IF ( &
( SB(1) /= SA(dims_A_reorder(1)) ) .OR. &
( SB(2) /= SA(dims_A_reorder(2)) ) .OR. &
( SB(3) /= SA(dims_A_reorder(3)) ) .OR. &
( SB(4) /= SA(dims_A_reorder(4)) ) .OR. &
( SB(5) /= SA(dims_A_reorder(5)) ) &
) THEN
WRITE(*,*) "The shape of B is not correct. "
WRITE(*,*) "Execution halted in SUBROUTINE reorder_dims_5D"
WRITE(*,*) "of MODULE mod_reorder_dims. "
STOP
END IF
ALLOCATE( pos_ints( rank_A ) )
pos_ints = (/ ( k, k = 1, rank_A ) /)
nperms = PRODUCT( pos_ints )
DEALLOCATE( pos_ints )
ALLOCATE( dims_A_perms( nperms, rank_A ) )
ALLOCATE( dims_B_order( nperms, rank_A ) )
dims_A_perms( 1,:) = (/1,2,3,4,5/)
dims_A_perms( 2,:) = (/1,2,3,5,4/)
dims_A_perms( 3,:) = (/1,2,4,3,5/)
dims_A_perms( 4,:) = (/1,2,4,5,3/)
dims_A_perms( 5,:) = (/1,2,5,3,4/)
dims_A_perms( 6,:) = (/1,2,5,4,3/)
dims_A_perms( 7,:) = (/1,3,2,4,5/)
dims_A_perms( 8,:) = (/1,3,2,5,4/)
dims_A_perms( 9,:) = (/1,3,4,2,5/)
dims_A_perms( 10,:) = (/1,3,4,5,2/)
dims_A_perms( 11,:) = (/1,3,5,2,4/)
dims_A_perms( 12,:) = (/1,3,5,4,2/)
dims_A_perms( 13,:) = (/1,4,2,3,5/)
dims_A_perms( 14,:) = (/1,4,2,5,3/)
dims_A_perms( 15,:) = (/1,4,3,2,5/)
dims_A_perms( 16,:) = (/1,4,3,5,2/)
dims_A_perms( 17,:) = (/1,4,5,2,3/)
dims_A_perms( 18,:) = (/1,4,5,3,2/)
dims_A_perms( 19,:) = (/1,5,2,3,4/)
dims_A_perms( 20,:) = (/1,5,2,4,3/)
dims_A_perms( 21,:) = (/1,5,3,2,4/)
dims_A_perms( 22,:) = (/1,5,3,4,2/)
dims_A_perms( 23,:) = (/1,5,4,2,3/)
dims_A_perms( 24,:) = (/1,5,4,3,2/)
dims_A_perms( 25,:) = (/2,1,3,4,5/)
dims_A_perms( 26,:) = (/2,1,3,5,4/)
dims_A_perms( 27,:) = (/2,1,4,3,5/)
dims_A_perms( 28,:) = (/2,1,4,5,3/)
dims_A_perms( 29,:) = (/2,1,5,3,4/)
dims_A_perms( 30,:) = (/2,1,5,4,3/)
dims_A_perms( 31,:) = (/2,3,1,4,5/)
dims_A_perms( 32,:) = (/2,3,1,5,4/)
dims_A_perms( 33,:) = (/2,3,4,1,5/)
dims_A_perms( 34,:) = (/2,3,4,5,1/)
dims_A_perms( 35,:) = (/2,3,5,1,4/)
dims_A_perms( 36,:) = (/2,3,5,4,1/)
dims_A_perms( 37,:) = (/2,4,1,3,5/)
dims_A_perms( 38,:) = (/2,4,1,5,3/)
dims_A_perms( 39,:) = (/2,4,3,1,5/)
dims_A_perms( 40,:) = (/2,4,3,5,1/)
dims_A_perms( 41,:) = (/2,4,5,1,3/)
dims_A_perms( 42,:) = (/2,4,5,3,1/)
dims_A_perms( 43,:) = (/2,5,1,3,4/)
dims_A_perms( 44,:) = (/2,5,1,4,3/)
dims_A_perms( 45,:) = (/2,5,3,1,4/)
dims_A_perms( 46,:) = (/2,5,3,4,1/)
dims_A_perms( 47,:) = (/2,5,4,1,3/)
dims_A_perms( 48,:) = (/2,5,4,3,1/)
dims_A_perms( 49,:) = (/3,1,2,4,5/)
dims_A_perms( 50,:) = (/3,1,2,5,4/)
dims_A_perms( 51,:) = (/3,1,4,2,5/)
dims_A_perms( 52,:) = (/3,1,4,5,2/)
dims_A_perms( 53,:) = (/3,1,5,2,4/)
dims_A_perms( 54,:) = (/3,1,5,4,2/)
dims_A_perms( 55,:) = (/3,2,1,4,5/)
dims_A_perms( 56,:) = (/3,2,1,5,4/)
dims_A_perms( 57,:) = (/3,2,4,1,5/)
dims_A_perms( 58,:) = (/3,2,4,5,1/)
dims_A_perms( 59,:) = (/3,2,5,1,4/)
dims_A_perms( 60,:) = (/3,2,5,4,1/)
dims_A_perms( 61,:) = (/3,4,1,2,5/)
dims_A_perms( 62,:) = (/3,4,1,5,2/)
dims_A_perms( 63,:) = (/3,4,2,1,5/)
dims_A_perms( 64,:) = (/3,4,2,5,1/)
dims_A_perms( 65,:) = (/3,4,5,1,2/)
dims_A_perms( 66,:) = (/3,4,5,2,1/)
dims_A_perms( 67,:) = (/3,5,1,2,4/)
dims_A_perms( 68,:) = (/3,5,1,4,2/)
dims_A_perms( 69,:) = (/3,5,2,1,4/)
dims_A_perms( 70,:) = (/3,5,2,4,1/)
dims_A_perms( 71,:) = (/3,5,4,1,2/)
dims_A_perms( 72,:) = (/3,5,4,2,1/)
dims_A_perms( 73,:) = (/4,1,2,3,5/)
dims_A_perms( 74,:) = (/4,1,2,5,3/)
dims_A_perms( 75,:) = (/4,1,3,2,5/)
dims_A_perms( 76,:) = (/4,1,3,5,2/)
dims_A_perms( 77,:) = (/4,1,5,2,3/)
dims_A_perms( 78,:) = (/4,1,5,3,2/)
dims_A_perms( 79,:) = (/4,2,1,3,5/)
dims_A_perms( 80,:) = (/4,2,1,5,3/)
dims_A_perms( 81,:) = (/4,2,3,1,5/)
dims_A_perms( 82,:) = (/4,2,3,5,1/)
dims_A_perms( 83,:) = (/4,2,5,1,3/)
dims_A_perms( 84,:) = (/4,2,5,3,1/)
dims_A_perms( 85,:) = (/4,3,1,2,5/)
dims_A_perms( 86,:) = (/4,3,1,5,2/)
dims_A_perms( 87,:) = (/4,3,2,1,5/)
dims_A_perms( 88,:) = (/4,3,2,5,1/)
dims_A_perms( 89,:) = (/4,3,5,1,2/)
dims_A_perms( 90,:) = (/4,3,5,2,1/)
dims_A_perms( 91,:) = (/4,5,1,2,3/)
dims_A_perms( 92,:) = (/4,5,1,3,2/)
dims_A_perms( 93,:) = (/4,5,2,1,3/)
dims_A_perms( 94,:) = (/4,5,2,3,1/)
dims_A_perms( 95,:) = (/4,5,3,1,2/)
dims_A_perms( 96,:) = (/4,5,3,2,1/)
dims_A_perms( 97,:) = (/5,1,2,3,4/)
dims_A_perms( 98,:) = (/5,1,2,4,3/)
dims_A_perms( 99,:) = (/5,1,3,2,4/)
dims_A_perms(100,:) = (/5,1,3,4,2/)
dims_A_perms(101,:) = (/5,1,4,2,3/)
dims_A_perms(102,:) = (/5,1,4,3,2/)
dims_A_perms(103,:) = (/5,2,1,3,4/)
dims_A_perms(104,:) = (/5,2,1,4,3/)
dims_A_perms(105,:) = (/5,2,3,1,4/)
dims_A_perms(106,:) = (/5,2,3,4,1/)
dims_A_perms(107,:) = (/5,2,4,1,3/)
dims_A_perms(108,:) = (/5,2,4,3,1/)
dims_A_perms(109,:) = (/5,3,1,2,4/)
dims_A_perms(110,:) = (/5,3,1,4,2/)
dims_A_perms(111,:) = (/5,3,2,1,4/)
dims_A_perms(112,:) = (/5,3,2,4,1/)
dims_A_perms(113,:) = (/5,3,4,1,2/)
dims_A_perms(114,:) = (/5,3,4,2,1/)
dims_A_perms(115,:) = (/5,4,1,2,3/)
dims_A_perms(116,:) = (/5,4,1,3,2/)
dims_A_perms(117,:) = (/5,4,2,1,3/)
dims_A_perms(118,:) = (/5,4,2,3,1/)
dims_A_perms(119,:) = (/5,4,3,1,2/)
dims_A_perms(120,:) = (/5,4,3,2,1/)
dims_B_order( 1,:) = (/1,2,3,4,5/)
dims_B_order( 2,:) = (/1,2,3,5,4/)
dims_B_order( 3,:) = (/1,2,4,3,5/)
dims_B_order( 4,:) = (/1,2,5,3,4/)
dims_B_order( 5,:) = (/1,2,4,5,3/)
dims_B_order( 6,:) = (/1,2,5,4,3/)
dims_B_order( 7,:) = (/1,3,2,4,5/)
dims_B_order( 8,:) = (/1,3,2,5,4/)
dims_B_order( 9,:) = (/1,4,2,3,5/)
dims_B_order( 10,:) = (/1,5,2,3,4/)
dims_B_order( 11,:) = (/1,4,2,5,3/)
dims_B_order( 12,:) = (/1,5,2,4,3/)
dims_B_order( 13,:) = (/1,3,4,2,5/)
dims_B_order( 14,:) = (/1,3,5,2,4/)
dims_B_order( 15,:) = (/1,4,3,2,5/)
dims_B_order( 16,:) = (/1,5,3,2,4/)
dims_B_order( 17,:) = (/1,4,5,2,3/)
dims_B_order( 18,:) = (/1,5,4,2,3/)
dims_B_order( 19,:) = (/1,3,4,5,2/)
dims_B_order( 20,:) = (/1,3,5,4,2/)
dims_B_order( 21,:) = (/1,4,3,5,2/)
dims_B_order( 22,:) = (/1,5,3,4,2/)
dims_B_order( 23,:) = (/1,4,5,3,2/)
dims_B_order( 24,:) = (/1,5,4,3,2/)
dims_B_order( 25,:) = (/2,1,3,4,5/)
dims_B_order( 26,:) = (/2,1,3,5,4/)
dims_B_order( 27,:) = (/2,1,4,3,5/)
dims_B_order( 28,:) = (/2,1,5,3,4/)
dims_B_order( 29,:) = (/2,1,4,5,3/)
dims_B_order( 30,:) = (/2,1,5,4,3/)
dims_B_order( 31,:) = (/3,1,2,4,5/)
dims_B_order( 32,:) = (/3,1,2,5,4/)
dims_B_order( 33,:) = (/4,1,2,3,5/)
dims_B_order( 34,:) = (/5,1,2,3,4/)
dims_B_order( 35,:) = (/4,1,2,5,3/)
dims_B_order( 36,:) = (/5,1,2,4,3/)
dims_B_order( 37,:) = (/3,1,4,2,5/)
dims_B_order( 38,:) = (/3,1,5,2,4/)
dims_B_order( 39,:) = (/4,1,3,2,5/)
dims_B_order( 40,:) = (/5,1,3,2,4/)
dims_B_order( 41,:) = (/4,1,5,2,3/)
dims_B_order( 42,:) = (/5,1,4,2,3/)
dims_B_order( 43,:) = (/3,1,4,5,2/)
dims_B_order( 44,:) = (/3,1,5,4,2/)
dims_B_order( 45,:) = (/4,1,3,5,2/)
dims_B_order( 46,:) = (/5,1,3,4,2/)
dims_B_order( 47,:) = (/4,1,5,3,2/)
dims_B_order( 48,:) = (/5,1,4,3,2/)
dims_B_order( 49,:) = (/2,3,1,4,5/)
dims_B_order( 50,:) = (/2,3,1,5,4/)
dims_B_order( 51,:) = (/2,4,1,3,5/)
dims_B_order( 52,:) = (/2,5,1,3,4/)
dims_B_order( 53,:) = (/2,4,1,5,3/)
dims_B_order( 54,:) = (/2,5,1,4,3/)
dims_B_order( 55,:) = (/3,2,1,4,5/)
dims_B_order( 56,:) = (/3,2,1,5,4/)
dims_B_order( 57,:) = (/4,2,1,3,5/)
dims_B_order( 58,:) = (/5,2,1,3,4/)
dims_B_order( 59,:) = (/4,2,1,5,3/)
dims_B_order( 60,:) = (/5,2,1,4,3/)
dims_B_order( 61,:) = (/3,4,1,2,5/)
dims_B_order( 62,:) = (/3,5,1,2,4/)
dims_B_order( 63,:) = (/4,3,1,2,5/)
dims_B_order( 64,:) = (/5,3,1,2,4/)
dims_B_order( 65,:) = (/4,5,1,2,3/)
dims_B_order( 66,:) = (/5,4,1,2,3/)
dims_B_order( 67,:) = (/3,4,1,5,2/)
dims_B_order( 68,:) = (/3,5,1,4,2/)
dims_B_order( 69,:) = (/4,3,1,5,2/)
dims_B_order( 70,:) = (/5,3,1,4,2/)
dims_B_order( 71,:) = (/4,5,1,3,2/)
dims_B_order( 72,:) = (/5,4,1,3,2/)
dims_B_order( 73,:) = (/2,3,4,1,5/)
dims_B_order( 74,:) = (/2,3,5,1,4/)
dims_B_order( 75,:) = (/2,4,3,1,5/)
dims_B_order( 76,:) = (/2,5,3,1,4/)
dims_B_order( 77,:) = (/2,4,5,1,3/)
dims_B_order( 78,:) = (/2,5,4,1,3/)
dims_B_order( 79,:) = (/3,2,4,1,5/)
dims_B_order( 80,:) = (/3,2,5,1,4/)
dims_B_order( 81,:) = (/4,2,3,1,5/)
dims_B_order( 82,:) = (/5,2,3,1,4/)
dims_B_order( 83,:) = (/4,2,5,1,3/)
dims_B_order( 84,:) = (/5,2,4,1,3/)
dims_B_order( 85,:) = (/3,4,2,1,5/)
dims_B_order( 86,:) = (/3,5,2,1,4/)
dims_B_order( 87,:) = (/4,3,2,1,5/)
dims_B_order( 88,:) = (/5,3,2,1,4/)
dims_B_order( 89,:) = (/4,5,2,1,3/)
dims_B_order( 90,:) = (/5,4,2,1,3/)
dims_B_order( 91,:) = (/3,4,5,1,2/)
dims_B_order( 92,:) = (/3,5,4,1,2/)
dims_B_order( 93,:) = (/4,3,5,1,2/)
dims_B_order( 94,:) = (/5,3,4,1,2/)
dims_B_order( 95,:) = (/4,5,3,1,2/)
dims_B_order( 96,:) = (/5,4,3,1,2/)
dims_B_order( 97,:) = (/2,3,4,5,1/)
dims_B_order( 98,:) = (/2,3,5,4,1/)
dims_B_order( 99,:) = (/2,4,3,5,1/)
dims_B_order(100,:) = (/2,5,3,4,1/)
dims_B_order(101,:) = (/2,4,5,3,1/)
dims_B_order(102,:) = (/2,5,4,3,1/)
dims_B_order(103,:) = (/3,2,4,5,1/)
dims_B_order(104,:) = (/3,2,5,4,1/)
dims_B_order(105,:) = (/4,2,3,5,1/)
dims_B_order(106,:) = (/5,2,3,4,1/)
dims_B_order(107,:) = (/4,2,5,3,1/)
dims_B_order(108,:) = (/5,2,4,3,1/)
dims_B_order(109,:) = (/3,4,2,5,1/)
dims_B_order(110,:) = (/3,5,2,4,1/)
dims_B_order(111,:) = (/4,3,2,5,1/)
dims_B_order(112,:) = (/5,3,2,4,1/)
dims_B_order(113,:) = (/4,5,2,3,1/)
dims_B_order(114,:) = (/5,4,2,3,1/)
dims_B_order(115,:) = (/3,4,5,2,1/)
dims_B_order(116,:) = (/3,5,4,2,1/)
dims_B_order(117,:) = (/4,3,5,2,1/)
dims_B_order(118,:) = (/5,3,4,2,1/)
dims_B_order(119,:) = (/4,5,3,2,1/)
dims_B_order(120,:) = (/5,4,3,2,1/)
found = .FALSE.
ALLOCATE( p( rank_A ) )
ALLOCATE( q( rank_A ) )
ALLOCATE( OB( rank_A ) )
k = 0
DO
IF ( found ) EXIT
k = k + 1
p(:) = dims_A_perms(k,:)
q(:) = dims_A_reorder(:)
sum_abs_diff_pmq = SUM( ABS( p - q ) )
IF ( sum_abs_diff_pmq == 0 ) THEN
OB(:) = dims_B_order(k,:)
found = .TRUE.
END IF
IF ( k > nperms ) THEN
WRITE(*,*) "REORDERING OF DIMENSIONS OF A NOT VALID. "
WRITE(*,*) "Execution halted in SUBROUTINE reorder_dims_5D"
WRITE(*,*) "contained in MODULE mod_reorder_dims. "
STOP
END IF
END DO
DEALLOCATE( dims_A_perms )
DEALLOCATE( dims_B_order )
DEALLOCATE( p )
DEALLOCATE( q )
B(:,:,:,:,:) = RESHAPE(A, SHAPE = (/SB(1),SB(2),SB(3),SB(4),SB(5)/), &
ORDER = (/OB(1),OB(2),OB(3),OB(4),OB(5)/) )
DEALLOCATE( SA )
DEALLOCATE( SB )
DEALLOCATE( OB )
END SUBROUTINE reorder_dims_5D
!>============================================================================<
END MODULE mod_reorder_dims
!>============================================================================<