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 interfaces of [pm_arrayPad](@ref pm_arrayPad).
19 : !>
20 : !> \finmain
21 : !>
22 : !> \author
23 : !> \AmirShahmoradi, September 1, 2017, 11:35 PM, Institute for Computational Engineering and Sciences (ICES), The University of Texas at Austin
24 :
25 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
26 :
27 : !>>>>>>>>>>>>>>>>>>>>>>>>
28 : !!> \bug
29 : !!> gfortran as of version 10.3 cannot handle regular allocation for assumed-length allocatable character types and returns the following error:
30 : !!> Fortran runtime error: Integer overflow when calculating the amount of memory to allocate
31 : !!> The following preprocessor condition bypasses gfortran's bug.
32 : !#if setPaddedAsisSB_D0_SK_ENABLED || setPaddedMargSB_D0_SK_ENABLED || getPaddedAsisSB_D0_SK_ENABLED || getPaddedMargSB_D0_SK_ENABLED
33 : !#define ALLOCATE_NEW_WITH_STAT allocate(character(lenarrayPaddedMinusOne+1_IK,SK) :: arrayPadded, stat = stat)
34 : !#define ALLOCATE_NEW allocate(character(lenarrayPaddedMinusOne+1_IK,SK) :: arrayPadded)
35 : !#elif setPaddedAsisSB_D1_SK_ENABLED || setPaddedMargSB_D1_SK_ENABLED || getPaddedAsisSB_D1_SK_ENABLED || getPaddedMargSB_D1_SK_ENABLED
36 : !#define ALLOCATE_NEW_WITH_STAT allocate(character(len(array)) :: arrayPadded(lb : lb + lenarrayPaddedMinusOne), stat = stat)
37 : !#define ALLOCATE_NEW allocate(character(len(array)) :: arrayPadded(lb : lb + lenarrayPaddedMinusOne))
38 : !#else
39 : !#define ALLOCATE_NEW_WITH_STAT allocate(arrayPadded(lb : lb + lenarrayPaddedMinusOne), stat = stat)
40 : !#define ALLOCATE_NEW allocate(arrayPadded(lb : lb + lenarrayPaddedMinusOne))
41 : !#endif
42 : !<<<<<<<<<<<<<<<<<<<<<<<
43 :
44 : integer(IK) :: i, lenArray, lenarrayPaddedMinusOne
45 : #if Asis_ENABLED && SB_ENABLED
46 : integer(IK), parameter :: lmsize = 0_IK, rmsize = 0_IK
47 : #elif Asis_ENABLED && SL_ENABLED
48 : integer(IK), parameter :: lmsize = 0_IK
49 : #elif Asis_ENABLED && SR_ENABLED
50 : integer(IK), parameter :: rmsize = 0_IK
51 : #elif !Marg_ENABLED
52 : #error "Unrecognized interface."
53 : #endif
54 : #if setPadded_ENABLED
55 : integer(IK) :: stat
56 : #if SK_ENABLED && D0_ENABLED
57 : character(:,SKC), allocatable :: arrayPadded
58 : #elif SK_ENABLED && D1_ENABLED
59 : character(len(array,IK),SKC), allocatable :: arrayPadded(:)
60 : #elif IK_ENABLED && D1_ENABLED
61 : integer(IKC), allocatable :: arrayPadded(:)
62 : #elif LK_ENABLED && D1_ENABLED
63 : logical(LKC), allocatable :: arrayPadded(:)
64 : #elif CK_ENABLED && D1_ENABLED
65 : complex(CKC), allocatable :: arrayPadded(:)
66 : #elif RK_ENABLED && D1_ENABLED
67 : real(RKC), allocatable :: arrayPadded(:)
68 : #else
69 : #error "Unrecognized interface."
70 : #endif
71 : #elif !getPadded_ENABLED
72 : #error "Unrecognized interface."
73 : #endif
74 : ! Set the array bounds.
75 : #if SK_ENABLED && D0_ENABLED
76 : #define GET_INDEX(i) i:i
77 : integer(IK) , parameter :: lb = 1_IK
78 600 : lenArray = len(array, kind = IK)
79 : #elif D1_ENABLED
80 : #define GET_INDEX(i) i
81 : #if getPadded_ENABLED
82 : integer(IK) , parameter :: lb = 1_IK
83 : #elif setPadded_ENABLED
84 : integer(IK) :: lb
85 11301 : lb = lbound(array, dim = 1, kind = IK)
86 : #endif
87 11301 : lenArray = size(array, kind = IK)
88 : #else
89 : #error "Unrecognized interface."
90 : #endif
91 : ! Verify the validity of the input.
92 : #if SB_ENABLED || SL_ENABLED
93 12988 : CHECK_ASSERTION(__LINE__, lpsize >= 0_IK, SK_"The condition `lpsize >= 0_IK` must hold. lpsize = "//getStr(lpsize))
94 : #endif
95 : #if SB_ENABLED || SR_ENABLED
96 12991 : CHECK_ASSERTION(__LINE__, rpsize >= 0_IK, SK_"The condition `rpsize >= 0_IK` must hold. rpsize = "//getStr(rpsize))
97 : #endif
98 : #if Marg_ENABLED && (SB_ENABLED || SL_ENABLED)
99 9724 : CHECK_ASSERTION(__LINE__, lmsize >= 0_IK, SK_"The condition `lmsize >= 0_IK` must hold. lmsize = "//getStr(lmsize))
100 : #endif
101 : #if Marg_ENABLED && (SB_ENABLED || SR_ENABLED)
102 9724 : CHECK_ASSERTION(__LINE__, rmsize >= 0_IK, SK_"The condition `rmsize >= 0_IK` must hold. rmsize = "//getStr(rmsize))
103 : #endif
104 : ! Set the length of padded array.
105 : #if SB_ENABLED
106 5407 : lenarrayPaddedMinusOne = lenArray + lpsize + rpsize + lmsize + rmsize - 1_IK
107 : #elif SL_ENABLED
108 3247 : lenarrayPaddedMinusOne = lenArray + lpsize + lmsize - 1_IK
109 : #elif SR_ENABLED
110 3247 : lenarrayPaddedMinusOne = lenArray + rpsize + rmsize - 1_IK
111 : #else
112 : #error "Unrecognized interface."
113 : #endif
114 : ! Allocate the new array for the subroutine interface.
115 : #if setPadded_ENABLED
116 11901 : if (present(failed)) then
117 : #if SK_ENABLED && D0_ENABLED
118 297 : allocate(character(lenarrayPaddedMinusOne + 1_IK, SKC) :: arrayPadded, stat = stat)
119 : #elif SK_ENABLED && D1_ENABLED
120 594 : allocate(character(len(array,IK),SKC) :: arrayPadded(lb : lb + lenarrayPaddedMinusOne), stat = stat)
121 : #else
122 5940 : allocate(arrayPadded(lb : lb + lenarrayPaddedMinusOne), stat = stat)
123 : #endif
124 5940 : failed = logical(stat > 0_IK, LK)
125 : if (failed) return ! LCOV_EXCL_LINE
126 : else
127 : #if SK_ENABLED && D0_ENABLED
128 303 : allocate(character(lenarrayPaddedMinusOne + 1_IK, SKC) :: arrayPadded)
129 : #elif SK_ENABLED && D1_ENABLED
130 600 : allocate(character(len(array,IK),SKC) :: arrayPadded(lb : lb + lenarrayPaddedMinusOne))
131 : #else
132 5952 : allocate(arrayPadded(lb : lb + lenarrayPaddedMinusOne))
133 : #endif
134 : end if
135 : #endif
136 :
137 : ! Fill the left margin, if any.
138 :
139 : #if Marg_ENABLED && (SB_ENABLED || SL_ENABLED)
140 9724 : if (present(lmfill)) then
141 3078 : do concurrent(i = lb : lb + lmsize - 1_IK)
142 12980 : arrayPadded(GET_INDEX(i)) = lmfill
143 : end do
144 : end if
145 : #endif
146 :
147 : ! Pad the array contents in the new array.
148 :
149 : #if SB_ENABLED || SL_ENABLED
150 11786 : do concurrent(i = lb + lmsize : lb + lmsize + lpsize - 1_IK)
151 39044 : arrayPadded(GET_INDEX(i)) = lpfill
152 : end do
153 37732 : arrayPadded(lb + lmsize + lpsize : lb + lmsize + lpsize + lenArray - 1_IK) = array
154 : #endif
155 : #if SB_ENABLED
156 5135 : do concurrent(i = lb + lmsize + lpsize + lenArray : lb + lenarrayPaddedMinusOne - rmsize)
157 24382 : arrayPadded(GET_INDEX(i)) = rpfill
158 : end do
159 : #elif SR_ENABLED
160 14294 : arrayPadded(lb : lb + lenArray - 1_IK) = array
161 3083 : do concurrent(i = lb + lenArray : lb + lenArrayPaddedMinusOne - rmsize)
162 14785 : arrayPadded(GET_INDEX(i)) = rpfill
163 : end do
164 : #endif
165 : ! Fill the right margin, if any.
166 :
167 : #if Marg_ENABLED && (SB_ENABLED || SR_ENABLED)
168 9724 : if (present(rmfill)) then
169 : do concurrent(i = lb + lenarrayPaddedMinusOne - rmsize + 1_IK : lb + lenarrayPaddedMinusOne)
170 14068 : arrayPadded(GET_INDEX(i)) = rmfill
171 : end do
172 : end if
173 : #endif
174 :
175 : #if setPadded_ENABLED
176 11901 : call move_alloc(arrayPadded, array)
177 : #endif
178 :
179 : #undef GET_INDEX
|
