Line data    Source code

       1             : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
       2             : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
       3             : !!!!                                                                                                                            !!!!
       4             : !!!!    ParaMonte: Parallel Monte Carlo and Machine Learning Library.                                                           !!!!
       5             : !!!!                                                                                                                            !!!!
       6             : !!!!    Copyright (C) 2012-present, The Computational Data Science Lab                                                          !!!!
       7             : !!!!                                                                                                                            !!!!
       8             : !!!!    This file is part of the ParaMonte library.                                                                             !!!!
       9             : !!!!                                                                                                                            !!!!
      10             : !!!!    LICENSE                                                                                                                 !!!!
      11             : !!!!                                                                                                                            !!!!
      12             : !!!!       https://github.com/cdslaborg/paramonte/blob/main/LICENSE.md                                                          !!!!
      13             : !!!!                                                                                                                            !!!!
      14             : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      15             : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      16             : 
      17             : !>  \brief
      18             : !>  This include file contains procedure implementations of [pm_swap](@ref pm_swap).
      19             : !>
      20             : !>  \finmain
      21             : !>
      22             : !>  \author
      23             : !>  \AmirShahmoradi, Sunday 3:33 AM, September 19, 2021, Dallas, TX
      24             : 
      25             : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
      26             : 
      27             :         ! Check for string length consistency.
      28             : #if     SK_ENABLED
      29             : #define CHECK_STRLEN \
      30             : CHECK_ASSERTION(__LINE__, len(a, IK) == len(b, IK), SK_"@setSwapped(): The condition `len(a) == len(b)` must hold. len(a), len(b) = "//getStr([len(a, IK), len(b, IK)])) ! fpp
      31             : #else
      32             : #define CHECK_STRLEN
      33             : #endif
      34             :         ! Define the sizing and slicing rules.
      35             : #if     SK_ENABLED && D0_ENABLED
      36             : #define GET_SIZE len
      37             : #define GET_SLICE(i) i:i
      38             : #elif   D1_ENABLED
      39             : #define GET_SIZE size
      40             : #define GET_SLICE(i) i
      41             : #elif   !D0_ENABLED
      42             : #error  "Unrecognized interface."
      43             : #endif
      44             :         !%%%%%%%%%%%%%%%%%
      45             : #if     setSwapped_ENABLED
      46             :         !%%%%%%%%%%%%%%%%%
      47             : 
      48             :         ! Define the place holder.
      49             : #if     !(BLAS_ENABLED && DISPATCH_ENABLED)
      50             : #if     SK_ENABLED && D0_ENABLED
      51             :         character(1,SKC) :: tmp
      52             : #elif   SK_ENABLED && D1_ENABLED
      53           1 :         character(len(a,IK),SKC) :: tmp
      54             : #elif   IK_ENABLED
      55             :         integer(IKC)    :: tmp
      56             : #elif   LK_ENABLED
      57             :         logical(LKC)    :: tmp
      58             : #elif   CK_ENABLED
      59             :         complex(CKC)    :: tmp
      60             : #elif   RK_ENABLED
      61             :         real(RKC)       :: tmp
      62             : #else
      63             : #error  "Unrecognized interface."
      64             : #endif
      65             : #endif
      66             : #if     D0_ENABLED && !SK_ENABLED
      67             :         CHECK_STRLEN
      68          10 :         tmp = a
      69          10 :         a = b
      70          10 :         b = tmp
      71             : #elif   Def_ENABLED && D1_ENABLED && BLAS_ENABLED && DISPATCH_ENABLED
      72             :         CHECK_STRLEN
      73             :         CHECK_ASSERTION(__LINE__, size(a, 1, IK) == size(b, 1, IK), SK_"@setSwapped(): The condition `size(a) == size(b)` must hold. size(a), size(b) = "//getStr([size(a), size(b)])) ! fpp
      74             :         call blasSWAP(size(a, 1, IK), a, 1_IK, b, 1_IK)
      75             : #elif   Def_ENABLED && (D1_ENABLED || (D0_ENABLED && SK_ENABLED))
      76             :         integer(IK) :: iell, nell, mell
      77           6 :         nell = GET_SIZE(a, kind = IK)
      78           6 :         CHECK_STRLEN
      79          18 :         CHECK_ASSERTION(__LINE__, nell == GET_SIZE(b, kind = IK), SK_"@setSwapped(): The condition `size(a) == size(b)` must hold. size(a), size(b) = "//getStr([GET_SIZE(a, kind = IK), GET_SIZE(b, kind = IK)])) ! fpp
      80           6 :         mell = mod(nell, 3_IK)
      81           6 :         if (mell /= 0_IK) then
      82          15 :             do iell = 1, mell
      83           2 :                 tmp = a(GET_SLICE(iell))
      84           2 :                 a(GET_SLICE(iell)) = b(GET_SLICE(iell))
      85          15 :                 b(GET_SLICE(iell)) = tmp
      86             :             end do
      87           5 :             if (nell < 3_IK) return
      88             :         end if
      89           1 :         do iell = mell + 1, nell, 3
      90           0 :             tmp = a(GET_SLICE(iell))
      91           0 :             a(GET_SLICE(iell)) = b(GET_SLICE(iell))
      92           0 :             b(GET_SLICE(iell)) = tmp
      93           0 :             tmp = a(GET_SLICE(iell + 1))
      94           0 :             a(GET_SLICE(iell + 1)) = b(GET_SLICE(iell + 1))
      95           0 :             b(GET_SLICE(iell + 1)) = tmp
      96           0 :             tmp = a(GET_SLICE(iell + 2))
      97           0 :             a(GET_SLICE(iell + 2)) = b(GET_SLICE(iell + 2))
      98           2 :             b(GET_SLICE(iell + 2)) = tmp
      99             :         end do
     100             : #elif   Inc_ENABLED && (D1_ENABLED || (D0_ENABLED && SK_ENABLED))
     101             :         integer(IK) :: nell
     102           7 :         if (inca == 1_IK .and. incb == 1_IK) then
     103           0 :             call setSwapped(a, b)
     104             :         else
     105          21 :             CHECK_ASSERTION(__LINE__, inca /= 0_IK .or. GET_SIZE(a, kind = IK) == 1_IK, SK_"@setSwapped(): The condition `inca /= 0 .or. size(a) == 1` must hold. size(a), inca = "//getStr([GET_SIZE(a, kind = IK), inca])) ! fpp
     106          21 :             CHECK_ASSERTION(__LINE__, incb /= 0_IK .or. GET_SIZE(b, kind = IK) == 1_IK, SK_"@setSwapped(): The condition `incb /= 0 .or. size(b) == 1` must hold. size(b), incb = "//getStr([GET_SIZE(b, kind = IK), incb])) ! fpp
     107          35 :             CHECK_ASSERTION(__LINE__, (GET_SIZE(a, kind = IK) - 1) / max(1_IK,abs(inca)) == (GET_SIZE(b, kind = IK) - 1) / max(1_IK,abs(incb)) .or. (GET_SIZE(a, kind = IK) == 1_IK .and. inca == 0_IK) .or. (GET_SIZE(b, kind = IK) == 1_IK .and. incb == 0_IK), \
     108             :             SK_"@setSwapped(): The condition `(size(a(1::max(1,abs(inca)))) == size(b(1::max(1,abs(incb))))) .or. (size(a) == 1 .and. inca == 0) .or. (size(b) == 1 .and. incb == 0)` must hold. size(a), inca, size(b), incb = "\
     109             :             //getStr([GET_SIZE(a, kind = IK), INCA, GET_SIZE(b, kind = IK), INCB])) ! fpp
     110           7 :             if (inca /= 0_IK) then
     111           6 :                 nell = 1 + (GET_SIZE(a, kind = IK) - 1) / abs(inca)
     112           1 :             elseif (incb /= 0_IK) then
     113           1 :                 nell = 1 + (GET_SIZE(b, kind = IK) - 1) / abs(incb)
     114             :             elseif (inca == 0_IK .and. incb == 0_IK) then
     115           0 :                 return
     116             :             else
     117             :                 nell = 1_IK
     118             :             end if
     119             : #if         BLAS_ENABLED && DISPATCH_ENABLED
     120             :             call blasSWAP(nell, a, inca, b, incb)
     121             : #else
     122             :             block
     123             :                 integer(IK) :: iell, aell, bell
     124             :                 aell = 1
     125             :                 bell = 1
     126           7 :                 if (inca < 0_IK) aell = (1 - nell) * inca + 1
     127           7 :                 if (incb < 0_IK) bell = (1 - nell) * incb + 1
     128          42 :                 do iell = 1, nell
     129           0 :                     tmp = a(GET_SLICE(aell))
     130           0 :                     a(GET_SLICE(aell)) = b(GET_SLICE(bell))
     131           0 :                     b(GET_SLICE(bell)) = tmp
     132          35 :                     aell = aell + inca
     133          42 :                     bell = bell + incb
     134             :                 end do
     135             :             end block
     136             : #endif
     137             :         end if
     138             : #else
     139             : #error  "Unrecognized interface."
     140             : #endif
     141             : #else
     142             :         !%%%%%%%%%%%%%%%%%%%%%%%%
     143             : #error  "Unrecognized interface."
     144             :         !%%%%%%%%%%%%%%%%%%%%%%%%
     145             : #endif
     146             : #undef  CHECK_STRLEN
     147             : #undef  GET_SLICE
     148             : #undef  GET_SIZE