!-----------------------------------------------------------------------
! The following transposition engine is based on the idea that many
! transpositions can be re-written as permutation of the 2nd and 4th
! dimensions of a 5D array. The most "difficult" part is to find how
! to remap the input array on such a 5D array, by repacking contiguous
! dimensions and inserting others which are degenerated.
!
! Examples:
! - 21:       a(n1,n2) <= b(1, n1, 1, n2, 1)
!             tr(a) = tr(b) = c(1,n2,1,n1,1)
! - 321:      a(n1,n2,n3) <= b(1, n1, n2, n3, 1)
!             tr(a) = tr(b) = c(1,n3,n2,n1,1)
! - 312:      a(n1,n2,n3) <= b(1, n1*n2, 1, n3, 1)
!             tr(a) = tr(b) = c(1,n3,1,n1*n2,1)
! - 1567423:  a(n1,n2,n3,n4,n5,n6,n7) <= b(n1, n2*n3, n4, n5*n6*n7, 1)
!             tr(a) = tr(b) = c(n1,n5*n6*n7,n4,n2*n3,1)
!
! Pros:
!  - since we always swap the 2nd and 4th dimension of the 5D array,
!    there is no need of a permutation array in the transposition loop.
!  - up to now all the transpositions needed in the Gildas context are
!    supported in a single pass.
!  - such an approach allows the calling programs to loop on the 5th
!    dimension of the 5D array, i.e. allocate only a working buffer
!    of dimensions m1*m2*m3*m4. This is particularly useful when
!    transposing disk images.
! Cons:
!  - all the transpositions are not supported. Some of them imply
!    executing several times the 5D transposition loop to achieve a
!    goal. If the problem fits in memory, a general (7D) transposition
!    loop with a permutation array should be prefered since the result
!    is achieved in a single pass.
!-----------------------------------------------------------------------
module gmath_transpose
  !---------------------------------------------------------------------
  ! @ private
  !  No need to share the code 'tr_maxdims': the transposition engine
  ! is able to deal with a number of dimensions lower or equal, or
  ! to complain for larger numbers.
  !---------------------------------------------------------------------
  integer(kind=4), parameter :: tr_maxdims=7
end module gmath_transpose
!
subroutine transpose_getcode(strin,strout,code,error)
  use gbl_message
  use gmath_interfaces, except_this=>transpose_getcode
  use gmath_transpose
  !---------------------------------------------------------------------
  ! @ public
  !  Convert a dimension string into a transposition code, e.g.
  !   'VLM' transposed to 'LMV'  <=>  transposition code '231'
  !---------------------------------------------------------------------
  character(len=*), intent(in)    :: strin   !
  character(len=*), intent(in)    :: strout  !
  character(len=*), intent(out)   :: code    !
  logical,          intent(inout) :: error   !
  ! Local
  character(len=*), parameter :: rname='TRANSPOSE'
  integer(kind=4) :: ni,no,nc,i
  character(len=tr_maxdims) :: in,out
  !
  ni = len_trim(strin)
  no = len_trim(strout)
  nc = len(code)
  !
  ! Sanity check
  if (ni.ne.no)  goto 100
  if (no.gt.tr_maxdims) then
    call gmath_message(seve%e,rname,'Transposition supported up to 7 dimensions')
    goto 100
  endif
  if (no.gt.nc) then
    call gmath_message(seve%e,rname,'Programming error, string for code too short')
    goto 100
  endif
  !
  ! Case-insensitive work
  in = strin
  call sic_upper(in)
  out = strout
  call sic_upper(out)
  !
  code = ''
  do i=1,no
    code(i:i) = char(ichar('0')+index(in,out(i:i)))
  enddo
  !
  call transpose_check(code,error)
  if (error)  goto 100
  return
  !
  ! Error
100 continue
  call gmath_message(seve%e,rname,  &
    'Could not transpose '//trim(strin)//' to '//strout)
  error = .true.
  return
  !
end subroutine transpose_getcode
!
subroutine transpose_getorder(code,itr,mdims,error)
  use gbl_message
  use gmath_interfaces, except_this=>transpose_getorder
  use gmath_transpose
  !---------------------------------------------------------------------
  ! @ public
  ! Decode transposition code into an index of axis orders
  !---------------------------------------------------------------------
  character(len=*), intent(in)    :: code        ! Transposition code
  integer(kind=4),  intent(in)    :: mdims       ! Maximum number of dimensions
  integer(kind=4),  intent(out)   :: itr(mdims)  ! Transposition index array
  logical,          intent(inout) :: error       ! Error flag
  ! Local
  character(len=*), parameter :: rname='TRANSPOSE'
  integer(kind=4) :: n
  !
  if (mdims.gt.tr_maxdims) then
    call gmath_message(seve%e,rname,'Unsupported number of dimensions')
    error = .true.
    return
  endif
  !
  call transpose_check(code,error)
  if (error)  return
  !
  ! Find transposition code
  itr(:) = 0
  read (code,'(7I1)',iostat=n) itr(1:len_trim(code))
  if (n.ne.0) then
    call gmath_message(seve%e,rname,'Invalid transposition '//code)
    call putios('E-TRANSPOSE,  ',n)
    error = .true.
    return
  endif
  !
end subroutine transpose_getorder
!
subroutine transpose_check(code,error)
  use gbl_message
  use gmath_interfaces, except_this=>transpose_check
  use gmath_transpose
  !---------------------------------------------------------------------
  ! @ private
  ! Check that the input code is correct, i.e. check:
  !  - code too large (unsupported number of dimensions)
  !  - illegal characters (e.g. letters)
  !  - correct numbering (each dimension must be present once and only
  !    once)
  !---------------------------------------------------------------------
  character(len=*), intent(in)    :: code   !
  logical,          intent(inout) :: error  !
  ! Local
  character(len=*), parameter :: rname='TRANSPOSE'
  integer(kind=4) :: nc,ic,p1,p2
  !
  nc = len_trim(code)
  if (nc.gt.tr_maxdims) then
    call gmath_message(seve%e,rname,'Too many dimensions in transposition code '//code)
    error = .true.
    return
  endif
  !
  p1 = 1
  p2 = 1
  do ic=1,nc
    p1 = p1*ic
    p2 = p2*index(code,char(ic+ichar('0')))
  enddo
  !
  if (p1.ne.p2) then
    call gmath_message(seve%e,rname,'Invalid transposition code '//code)
    error = .true.
    return
  endif
  !
end subroutine transpose_check
!
subroutine transpose_getblock(idim,ndims,code,block,error)
  use gildas_def
  use gbl_message
  use gmath_interfaces, except_this=>transpose_getblock
  use gmath_transpose
  !---------------------------------------------------------------------
  ! @ public
  !  Repack the transposition order into a general case of the following form:
  !      unchanged, swap1,  unchanged, swap2,   unchanged
  !      Nelems,    Nfirst, Nmiddle,   Nsecond, Nlast
  !---------------------------------------------------------------------
  integer(kind=4),            intent(in)    :: ndims        ! Effective or maximum number of dimensions
  integer(kind=index_length), intent(in)    :: idim(ndims)  ! Array dimensions
  character(len=*),           intent(in)    :: code         ! Transposition code
  integer(kind=index_length), intent(out)   :: block(5)     ! Resulting transposition pack
  logical,                    intent(inout) :: error        ! Error flag
  ! Local
  character(len=*), parameter :: rname='TRANSPOSE'
  integer(kind=4) :: repack(5),id,fd
  integer(kind=index_length) :: dims(tr_maxdims)
  integer(kind=index_length) :: nelems,nfirst,nmiddle,nsecon,nlast
  character(len=tr_maxdims) :: start,goal
  !
  if (ndims.gt.tr_maxdims) then
    call gmath_message(seve%e,rname,'Unsupported number of dimensions')
    error = .true.
    return
  endif
  !
  do id=1,ndims
    dims(id) = max(1,idim(id))
  enddo
  do id = ndims+1,tr_maxdims
    dims(id) = 1
  enddo
  !
  start = '1234567'
  goal  = start
  goal(1:len_trim(code)) = trim(code)
  if (start.eq.goal) then
    ! The subsequent optimizations will only perform a r4tor4
    call gmath_message(seve%w,rname,'No transposition here: '//code)
  endif
  !
  call transpose_repack(start,goal,repack)
  !
  if (start.ne.goal) then
    ! 'start' has been updated on return but does not yet match the goal
    ! Several permutations are not yet implemented
    call gmath_message(seve%e,rname,  &
      'Not implemented: more than 1 permutation needed for '//code)
    call transpose_guess(code)
    error = .true.
    return
  endif
  !
  nelems = 1
  fd = 1
  do id=fd,fd+repack(1)-1
    nelems = nelems*dims(id)
  enddo
  !
  nfirst = 1
  fd = fd+repack(1)
  do id=fd,fd+repack(2)-1
    nfirst = nfirst*dims(id)
  enddo
  !
  nmiddle = 1
  fd = fd+repack(2)
  do id=fd,fd+repack(3)-1
    nmiddle = nmiddle*dims(id)
  enddo
  !
  nsecon = 1
  fd = fd+repack(3)
  do id=fd,fd+repack(4)-1
    nsecon = nsecon*dims(id)
  enddo
  !
  nlast = 1
  fd = fd+repack(4)
  do id=fd,fd+repack(5)-1
    nlast = nlast*dims(id)
  enddo
  !
  block(1) = nelems
  block(2) = nfirst
  block(3) = nmiddle
  block(4) = nsecon
  block(5) = nlast
  !
end subroutine transpose_getblock
!
subroutine transpose_repack(start,goal,repack)
  use gbl_message
  use gmath_interfaces, except_this=>transpose_repack
  use gmath_transpose
  !---------------------------------------------------------------------
  ! @ private
  !   Compute the repack array for the 'goal' starting from 'start'
  !   Note that there is no assumption on the order of the start code
  ! (in particular you can not assume it is '1234567'). This is a
  ! desired feature to call consecutively this subroutine to achieve the
  ! goal in several steps.
  !   Note also that there no assumption on the characters it contains,
  ! e.g. if you plan to modify this code, think on what should be done
  ! if start='baefdcg' and goal='bedgafc'
  !---------------------------------------------------------------------
  character(len=*), intent(inout) :: start      ! Updated on return
  character(len=*), intent(in)    :: goal       !
  integer(kind=4),  intent(out)   :: repack(5)  ! How the dimensions should be packed
  ! Local
  character(len=*), parameter :: rname='TRANSPOSE'
  character(len=tr_maxdims) :: before,swap1,middle,swap2,after
  integer(kind=4) :: poss,posg,l1,l2
  character(len=message_length) :: mess
  !
  ! If no permutation, repack everything in the 1st (unchanged) group
  repack(:) = (/ tr_maxdims,0,0,0,0 /)
  !
  ! Find where the difference starts
  do posg=1,tr_maxdims
    if (goal(posg:posg).ne.start(posg:posg))  exit
  enddo
  if (posg.ge.tr_maxdims)  return  ! start == goal, nothing to do
  !
  ! Find the pattern to swap (swap2), its length, and its position in 'start'
  swap2 = goal(posg:)
  do
    l2 = len_trim(swap2)
    poss = index(start,swap2(1:l2))
    if (poss.ne.0)  exit
    swap2(l2:l2) = ' '
  enddo
  !
  ! Find swap1 and middle
  swap1  = start(posg:poss-1)  ! This is swap1+middle: we have to separate them cleverly...
  middle = ''
  do
    l1 = len_trim(swap1)
    if (index(goal(posg+l2:),swap1(1:l1)).ne.0)  exit
    middle = swap1(l1:l1)//middle
    swap1(l1:l1) = ' '
  enddo
  !
  ! And finally find the boundaries
  before = start(1:posg-1)
  after  = start(poss+l2:)
  !
  write(mess,100)  &
    trim(before),trim(swap1),trim(middle),trim(swap2),trim(after),  &
    ' -> ',                                                         &
    trim(before),trim(swap2),trim(middle),trim(swap1),trim(after)
  call gmath_message(seve%d,rname,mess)
  !
  start = trim(before)//trim(swap2)//trim(middle)//trim(swap1)//trim(after)
  !
  ! Set the repack array
  repack(1) = len_trim(before)
  repack(2) = len_trim(swap1)
  repack(3) = len_trim(middle)
  repack(4) = len_trim(swap2)
  repack(5) = len_trim(after)
  ! write(*,'(5(I2))')  repack(:)
  !
100 format( 2 ('(',A,')', '[',A,']', '(',A,')', '[',A,']', '(',A,')', A))
end subroutine transpose_repack
!
subroutine transpose_guess(code)
  use gbl_message
  use gmath_interfaces, except_this=>transpose_guess
  use gmath_transpose
  !---------------------------------------------------------------------
  ! @ private
  !  Give users the serie of permutations needed to achieve the goal.
  ! Note that each user permutation must be given from '1234567' to
  ! 'intermediate-goal', e.g. 2143 = 2134 + 1243
  !---------------------------------------------------------------------
  character(len=*), intent(in) :: code
  ! Local
  character(len=*), parameter :: rname='TRANSPOSE'
  character(len=tr_maxdims) :: start,goal,interm
  integer(kind=4) :: nt,nd,repack(5)
  character(len=message_length) :: mess
  !
  nd = len_trim(code)
  start = '1234567'
  goal  = start
  goal(1:nd) = trim(code)
  nt = 0
  !
  call gmath_message(seve%i,rname,'Transpositions needed to achieve '//trim(code)//':')
  do while (start.ne.goal)
    nt = nt+1
    call transpose_repack(start,goal,repack)
    !
    call transposition_repack_to_code(repack,interm)
    write(mess,'(A,I0,A,A)')  '  #',nt,': ',interm(1:nd)
    call gmath_message(seve%r,rname,mess)
  enddo
  !
end subroutine transpose_guess
!
subroutine transposition_repack_to_code(repack,code)
  use gmath_interfaces, except_this=>transposition_repack_to_code
  use gmath_transpose
  !---------------------------------------------------------------------
  ! @ private
  !  Generate the transposition code from the repack array
  !---------------------------------------------------------------------
  integer(kind=4),  intent(in)  :: repack(5)  !
  character(len=*), intent(out) :: code       !
  ! Local
  integer(kind=4) :: id,fd
  character(len=tr_maxdims) :: before,swap1,middle,swap2,after
  !
  before = ''
  fd = 1
  do id=fd,fd+repack(1)-1
    before = trim(before)//char(id+ichar('0'))
  enddo
  !
  swap1 = ''
  fd = fd+repack(1)
  do id=fd,fd+repack(2)-1
    swap1 = trim(swap1)//char(id+ichar('0'))
  enddo
  !
  middle = ''
  fd = fd+repack(2)
  do id=fd,fd+repack(3)-1
    middle = trim(middle)//char(id+ichar('0'))
  enddo
  !
  swap2 = ''
  fd = fd+repack(3)
  do id=fd,fd+repack(4)-1
    swap2 = trim(swap2)//char(id+ichar('0'))
  enddo
  !
  after = ''
  fd = fd+repack(4)
  do id=fd,fd+repack(5)-1
    after = trim(after)//char(id+ichar('0'))
  enddo
  !
  code = trim(before)//trim(swap2)//trim(middle)//trim(swap1)//trim(after)
  !
end subroutine transposition_repack_to_code
!
subroutine trans4all(x,y,nb,n1,nm,n2,nl)
  use gildas_def
  !---------------------------------------------------------------------
  ! @ public-mandatory (because symbol is used elsewhere)
  ! Swap the 2nd and 4th dimension among the 5 ones.
  ! This version for 4-bytes words.
  !---------------------------------------------------------------------
  integer(kind=index_length), intent(in)  :: nb                 !
  integer(kind=index_length), intent(in)  :: n1                 !
  integer(kind=index_length), intent(in)  :: nm                 !
  integer(kind=index_length), intent(in)  :: n2                 !
  integer(kind=index_length), intent(in)  :: nl                 !
  real(kind=4),               intent(out) :: x(nb,n2,nm,n1,nl)  !
  real(kind=4),               intent(in)  :: y(nb,n1,nm,n2,nl)  !
  ! Local
  integer(kind=index_length) :: i,j,k,l,m
  !
  do k=1,nl
    do j=1,n2
      do m=1,nm
        do i=1,n1
          do l=1,nb
            x(l,j,m,i,k) = y(l,i,m,j,k)
          enddo
        enddo
      enddo
    enddo
  enddo
end subroutine trans4all
!
subroutine trans4(in,ou,nelems,nx,nm,ny)
  use gildas_def
  !---------------------------------------------------------------------
  ! @ public
  ! Swap the 2nd and 4th dimension among the 4 ones.
  ! This version for 4-bytes words.
  !---------------------------------------------------------------------
  integer(kind=index_length), intent(in)  :: nelems               !
  integer(kind=index_length), intent(in)  :: nx                   !
  integer(kind=index_length), intent(in)  :: nm                   !
  integer(kind=index_length), intent(in)  :: ny                   !
  real(kind=4),               intent(in)  :: in(nelems,nx,nm,ny)  !
  real(kind=4),               intent(out) :: ou(nelems,ny,nm,nx)  !
  ! Local
  integer(kind=index_length) :: i,j,l,m
  !
  do j=1,ny
    do m=1,nm
      do i=1,nx
        do l=1,nelems
          ou(l,j,m,i) = in(l,i,m,j)
        enddo
      enddo
    enddo
  enddo
end subroutine trans4
!
subroutine trans4slice(nelems,nfirst,nmiddl,nsecon,in,kin,lin,ou,kou,lou)
  use gildas_def
  !---------------------------------------------------------------------
  ! @ public
  ! Swap the 2nd and 4th dimension among the 4 ones, for the slices
  ! [kin:lin] in 'nsecon' and [kou:lou] in 'nfirst'.
  ! This version for 4-bytes words.
  !---------------------------------------------------------------------
  integer(kind=index_length), intent(in)  :: nelems                      !
  integer(kind=index_length), intent(in)  :: nfirst                      !
  integer(kind=index_length), intent(in)  :: nmiddl                      !
  integer(kind=index_length), intent(in)  :: nsecon                      !
  integer(kind=index_length), intent(in)  :: kin,lin                     !
  integer(kind=index_length), intent(in)  :: kou,lou                     !
  real(kind=4),               intent(in)  :: in(nelems,nfirst,nmiddl,*)  !
  real(kind=4),               intent(out) :: ou(nelems,nsecon,nmiddl,*)  !
  ! Local
  integer(kind=index_length) :: ibig,jbig,iou,jin,l,m
  !
  do iou=1,lou-kou+1           ! Size of output array
    ibig = iou+kou-1
    do jin=1,lin-kin+1         ! Size of input array
      jbig = jin+kin-1
      do m=1,nmiddl
        do l=1,nelems
          ou(l,jbig,m,iou) = in(l,ibig,m,jin)
        enddo
      enddo
    enddo
  enddo
end subroutine trans4slice
!
subroutine trans8all(x,y,nb,n1,nm,n2,nl)
  use gildas_def
  !---------------------------------------------------------------------
  ! @ public-mandatory (because symbol is used elsewhere)
  ! Swap the 2nd and 4th dimension among the 5 ones.
  ! This version for 8-bytes words.
  !---------------------------------------------------------------------
  integer(kind=index_length), intent(in)  :: nb                 !
  integer(kind=index_length), intent(in)  :: n1                 !
  integer(kind=index_length), intent(in)  :: nm                 !
  integer(kind=index_length), intent(in)  :: n2                 !
  integer(kind=index_length), intent(in)  :: nl                 !
  real(kind=8),               intent(out) :: x(nb,n2,nm,n1,nl)  !
  real(kind=8),               intent(in)  :: y(nb,n1,nm,n2,nl)  !
  ! Local
  integer(kind=index_length) :: i,j,k,l,m
  !
  do k=1,nl
    do j=1,n2
      do m=1,nm
        do i=1,n1
          do l=1,nb
            x(l,j,m,i,k) = y(l,i,m,j,k)
          enddo
        enddo
      enddo
    enddo
  enddo
end subroutine trans8all
