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 file contains the implementation details of the routines under the generic interface [setChoice](@ref pm_arrayResize::setChoice).
      19             : !>
      20             : !>  \finmain
      21             : !>
      22             : !>  \author
      23             : !>  \AmirShahmoradi, Monday March 6, 2017, 3:22 pm, Institute for Computational Engineering and Sciences (ICES), The University of Texas at Austin.<br>
      24             : 
      25             : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
      26             : 
      27             :         !%%%%%%%%%%%%%%%%
      28             : #if     getChoice_ENABLED
      29             :         !%%%%%%%%%%%%%%%%
      30             : 
      31             : #if     D0_D0_ENABLED || D1_D0_ENABLED
      32       45749 :         call setChoice(rngf, choice, array)
      33             : #elif   D0_S1_ENABLED || D1_D1_ENABLED
      34       13720 :         call setChoice(rngf, choice, array, unique)
      35             : #else
      36             : #error  "Unrecognized interface."
      37             : #endif
      38             : 
      39             :         !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
      40             : #elif   setChoice_ENABLED && Def_ENABLED
      41             :         !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
      42             : 
      43             :         integer(IK) :: index, lenArray
      44             : #if     D0_D0_ENABLED || D1_D1_ENABLED
      45             :         integer(IK) :: ichoice, lenChoice
      46             : #endif
      47             :         ! Check string length compatibility.
      48             : #if     SK_ENABLED && D0_D0_ENABLED
      49             : #define GET_INDEX(i) i:i
      50             : #define GET_SIZE len
      51             :         !CHECK_ASSERTION(__LINE__, 0_IK < len(choice, IK), SK_"@setChoice(): The condition `1 == len(choice)` must hold. len(choice) = "//getStr(len(choice, IK))) ! fpp
      52             : #elif   SK_ENABLED || IK_ENABLED || LK_ENABLED || CK_ENABLED || RK_ENABLED
      53             : #define GET_INDEX(i) i
      54             : #define GET_SIZE size
      55             : #if     SK_ENABLED
      56        2700 :         CHECK_ASSERTION(__LINE__, len(array, IK) == len(choice, IK), SK_"@setChoice(): The condition `len(array) == len(choice)` must hold. len(array), len(choice) = "//getStr([len(array, IK), len(choice, IK)])) ! fpp
      57             : #endif
      58             : #else
      59             : #error  "Unrecognized interface."
      60             : #endif
      61       73723 :         lenArray = GET_SIZE(array, kind = IK)
      62       73723 :         CHECK_ASSERTION(__LINE__, 0_IK < lenArray, SK_"@setChoice(): The length of the input `array` must be non-zero. lenArray = "//getStr(lenArray)) ! fpp
      63             : #if     D1_D0_ENABLED
      64       47539 :         if (1_IK < lenArray) then
      65       46998 :             call setUnifRand(rng, index, 1_IK, lenArray)
      66       46998 :             choice = array(GET_INDEX(index))
      67             :         else
      68         541 :             choice = array(GET_INDEX(1))
      69             :         end if
      70             : #elif   D0_D0_ENABLED || D1_D1_ENABLED
      71       26184 :         lenChoice = GET_SIZE(choice, kind = IK)
      72             :         !CHECK_ASSERTION(__LINE__, 0_IK < lenChoice, SK_"@setChoice(): The length of the input `choice` must be non-zero. lenChoice = "//getStr(lenChoice)) ! fpp
      73       26184 :         if (present(unique)) then
      74       13800 :             if (unique) then
      75       33891 :                 CHECK_ASSERTION(__LINE__, lenChoice <= lenArray, SK_"@setChoice(): The size of the input `choice` must smaller than or equal to the size of `array`. lenChoice, lenArray = "//getStr([lenChoice, lenArray])) ! fpp
      76             :                 block
      77       11297 :                     integer(IK) :: shuffle(lenArray)
      78       11297 :                     call setRange(shuffle, 1_IK)
      79       11297 :                     call setShuffled(rng, shuffle, lenChoice)
      80         126 :                     do concurrent(index = 1 : lenChoice)
      81       32761 :                         choice(GET_INDEX(index)) = array(GET_INDEX(shuffle(index)))
      82             :                     end do
      83             :                     return
      84             :                 end block
      85             :                 return
      86             :             end if
      87             :         end if
      88       14887 :         if (1_IK < lenArray) then
      89             :             ! \todo
      90             :             ! This must be improved. No need for uniform CDF in the default case. Use simple shuffling.
      91             :             block
      92       11503 :                 real(RKD) :: unifrnd, cdf(lenArray), lenArray_RKD
      93       11503 :                 lenArray_RKD = real(lenArray, RKD)
      94       11503 :                 call setLinSpace(cdf, 0._RKD, (lenArray_RKD - 1._RKD) / lenArray_RKD)
      95       62701 :                 do ichoice = 1, lenChoice
      96       51198 :                     call setUnifRand(rng, unifrnd)
      97       51198 :                     index = getBin(cdf, unifrnd)
      98       62701 :                     choice(GET_INDEX(ichoice)) = array(GET_INDEX(index))
      99             :                 end do
     100             :             end block
     101             :         else
     102             :             do concurrent(index = 1 : lenChoice)
     103        7197 :                 choice(GET_INDEX(index)) = array(GET_INDEX(1))
     104             :             end do
     105             :         end if
     106             : #else
     107             : #error  "Unrecognized interface."
     108             : #endif
     109             : 
     110             : #else
     111             :         !%%%%%%%%%%%%%%%%%%%%%%%
     112             : #error  "Unrecognized interface"
     113             :         !%%%%%%%%%%%%%%%%%%%%%%%
     114             : #endif
     115             : 
     116             : #undef  GET_INDEX
     117             : #undef  GET_SIZE