[4046] | 1 | MODULE strings_mod |
---|
| 2 | |
---|
[5748] | 3 | USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: REAL64, REAL32 |
---|
| 4 | |
---|
[4046] | 5 | IMPLICIT NONE |
---|
| 6 | |
---|
| 7 | PRIVATE |
---|
[5754] | 8 | PUBLIC :: maxlen, init_printout, msg, lunout, prt_level, maxTableWidth |
---|
[4068] | 9 | PUBLIC :: strLower, strHead, strStack, strCount, strReduce, strClean, strIdx |
---|
[5747] | 10 | PUBLIC :: strUpper, strTail, strStackm, strParse, strReplace, strFind, find, duplicate, cat |
---|
[4046] | 11 | PUBLIC :: dispTable, dispOutliers, dispNameList |
---|
[5748] | 12 | PUBLIC :: is_numeric, num2str, str2bool, str2int, str2real, str2dble |
---|
| 13 | PUBLIC :: reduceExpr, addQuotes, checkList, removeComment |
---|
[4046] | 14 | |
---|
[5748] | 15 | INTERFACE num2str; MODULE PROCEDURE bool2str, int2str, real2str, dble2str; END INTERFACE num2str |
---|
[4046] | 16 | INTERFACE msg; MODULE PROCEDURE msg_1, msg_m; END INTERFACE msg |
---|
| 17 | INTERFACE strHead; MODULE PROCEDURE strHead_1, strHead_m; END INTERFACE strHead |
---|
| 18 | INTERFACE strTail; MODULE PROCEDURE strTail_1, strTail_m; END INTERFACE strTail |
---|
| 19 | INTERFACE strClean; MODULE PROCEDURE strClean_1, strClean_m; END INTERFACE strClean |
---|
| 20 | INTERFACE strReduce; MODULE PROCEDURE strReduce_1, strReduce_2; END INTERFACE strReduce |
---|
| 21 | INTERFACE strIdx; MODULE PROCEDURE strIdx_1, strIdx_m; END INTERFACE strIdx |
---|
| 22 | INTERFACE strCount; MODULE PROCEDURE strCount_m1, strCount_11, strCount_1m; END INTERFACE strCount |
---|
| 23 | INTERFACE strReplace; MODULE PROCEDURE strReplace_1, strReplace_m; END INTERFACE strReplace |
---|
[5751] | 24 | INTERFACE cat; MODULE PROCEDURE horzcat_s00, horzcat_i00, horzcat_r00, horzcat_d00, horzcat_l00, & |
---|
| 25 | horzcat_s10, horzcat_i10, horzcat_r10, horzcat_d10, horzcat_l10, & |
---|
| 26 | horzcat_s11, horzcat_i11, horzcat_r11, horzcat_d11, horzcat_l11, & |
---|
| 27 | horzcat_s21, horzcat_i21, horzcat_r21, horzcat_d21, horzcat_l21, & |
---|
| 28 | horzcat_s22, horzcat_i22, horzcat_r22, horzcat_d22, horzcat_l22; END INTERFACE cat |
---|
[5748] | 29 | INTERFACE strFind; MODULE PROCEDURE strFind_1, strFind_m; END INTERFACE strFind |
---|
[5751] | 30 | INTERFACE find; MODULE PROCEDURE strFind_1, strFind_m, intFind_1, intFind_m, booFind; END INTERFACE find |
---|
[5747] | 31 | INTERFACE duplicate; MODULE PROCEDURE dupl_s, dupl_i, dupl_r, dupl_l; END INTERFACE duplicate |
---|
[5751] | 32 | INTERFACE dispTable; MODULE PROCEDURE dispTable_1, dispTable_2; END INTERFACE dispTable |
---|
[4046] | 33 | INTERFACE dispOutliers; MODULE PROCEDURE dispOutliers_1, dispOutliers_2; END INTERFACE dispOutliers |
---|
| 34 | INTERFACE reduceExpr; MODULE PROCEDURE reduceExpr_1, reduceExpr_m; END INTERFACE reduceExpr |
---|
| 35 | INTERFACE addQuotes; MODULE PROCEDURE addQuotes_1, addQuotes_m; END INTERFACE addQuotes |
---|
| 36 | |
---|
| 37 | INTEGER, PARAMETER :: maxlen = 256 !--- Standard maximum length for strings |
---|
| 38 | INTEGER, SAVE :: lunout = 6 !--- Printing unit (default: 6, ie. on screen) |
---|
| 39 | INTEGER, SAVE :: prt_level = 1 !--- Printing level (default: 1, ie. print all) |
---|
[5751] | 40 | INTEGER, SAVE :: maxTableWidth = 192 !--- Default max. number of characters per lines in dispTable |
---|
[4046] | 41 | |
---|
| 42 | CONTAINS |
---|
| 43 | |
---|
| 44 | !============================================================================================================================== |
---|
| 45 | SUBROUTINE init_printout(lunout_, prt_level_) |
---|
[5001] | 46 | IMPLICIT NONE |
---|
[4046] | 47 | INTEGER, INTENT(IN) :: lunout_, prt_level_ |
---|
[4363] | 48 | lunout = lunout_ |
---|
| 49 | prt_level = prt_level_ |
---|
[4046] | 50 | END SUBROUTINE init_printout |
---|
| 51 | !============================================================================================================================== |
---|
| 52 | |
---|
| 53 | |
---|
| 54 | !============================================================================================================================== |
---|
| 55 | !=== Display one or several messages, one each line, starting with the current routine name "modname". |
---|
| 56 | !============================================================================================================================== |
---|
| 57 | SUBROUTINE msg_1(str, modname, ll, unit) |
---|
[5001] | 58 | IMPLICIT NONE |
---|
[4046] | 59 | !--- Display a simple message "str". Optional parameters: |
---|
| 60 | ! * "modname": module name, displayed in front of the message (with ": " separator) if present. |
---|
| 61 | ! * "ll": message trigger ; message is displayed only if ll==.TRUE. |
---|
| 62 | ! * "unit": write unit (by default: "lunout") |
---|
| 63 | CHARACTER(LEN=*), INTENT(IN) :: str |
---|
| 64 | CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: modname |
---|
| 65 | LOGICAL, OPTIONAL, INTENT(IN) :: ll |
---|
| 66 | INTEGER, OPTIONAL, INTENT(IN) :: unit |
---|
[4349] | 67 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
[4120] | 68 | CHARACTER(LEN=maxlen) :: subn |
---|
[4046] | 69 | INTEGER :: unt |
---|
[4120] | 70 | subn = ''; IF(PRESENT(modname)) subn = modname |
---|
[4063] | 71 | IF(PRESENT(ll)) THEN; IF(.NOT.ll) RETURN; END IF |
---|
[4046] | 72 | unt = lunout; IF(PRESENT(unit)) unt = unit |
---|
[4120] | 73 | IF(subn == '') WRITE(unt,'(a)') str !--- Simple message |
---|
| 74 | IF(subn /= '') WRITE(unt,'(a)') TRIM(subn)//': '//str !--- Routine name provided |
---|
[4046] | 75 | END SUBROUTINE msg_1 |
---|
| 76 | !============================================================================================================================== |
---|
| 77 | SUBROUTINE msg_m(str, modname, ll, unit, nmax) |
---|
[5001] | 78 | IMPLICIT NONE |
---|
[4046] | 79 | !--- Same as msg_1 with multiple strings that are stacked (separator: coma) on up to "nmax" full lines. |
---|
| 80 | CHARACTER(LEN=*), INTENT(IN) :: str(:) |
---|
| 81 | CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: modname |
---|
| 82 | LOGICAL, OPTIONAL, INTENT(IN) :: ll |
---|
| 83 | INTEGER, OPTIONAL, INTENT(IN) :: unit |
---|
| 84 | INTEGER, OPTIONAL, INTENT(IN) :: nmax |
---|
[4349] | 85 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
[4046] | 86 | CHARACTER(LEN=maxlen), ALLOCATABLE :: s(:) |
---|
[4120] | 87 | CHARACTER(LEN=maxlen) :: subn |
---|
[4046] | 88 | INTEGER :: unt, nmx, k |
---|
[4063] | 89 | LOGICAL :: l |
---|
[4120] | 90 | subn = ''; IF(PRESENT(modname)) subn = modname |
---|
[4063] | 91 | l = .TRUE.; IF(PRESENT(ll)) l = ll |
---|
| 92 | unt = lunout; IF(PRESENT(unit)) unt = unit |
---|
| 93 | nmx = 128; IF(PRESENT(nmax)) nmx = nmax |
---|
[4046] | 94 | s = strStackm(str, ', ', nmx) |
---|
[4120] | 95 | DO k=1,SIZE(s); CALL msg_1(s(k), subn, l, unt); END DO |
---|
[4046] | 96 | END SUBROUTINE msg_m |
---|
| 97 | !============================================================================================================================== |
---|
| 98 | |
---|
| 99 | |
---|
| 100 | !============================================================================================================================== |
---|
| 101 | !=== Lower/upper case conversion function. ==================================================================================== |
---|
| 102 | !============================================================================================================================== |
---|
[5745] | 103 | ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION strLower(str) RESULT(out) |
---|
[5001] | 104 | IMPLICIT NONE |
---|
[4046] | 105 | CHARACTER(LEN=*), INTENT(IN) :: str |
---|
| 106 | INTEGER :: k |
---|
| 107 | out = str |
---|
| 108 | DO k=1,LEN_TRIM(str) |
---|
[4120] | 109 | IF(str(k:k)>='A' .AND. str(k:k)<='Z') out(k:k)=ACHAR(IACHAR(str(k:k))+32) |
---|
[4046] | 110 | END DO |
---|
| 111 | END FUNCTION strLower |
---|
| 112 | !============================================================================================================================== |
---|
[5745] | 113 | ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION strUpper(str) RESULT(out) |
---|
[5001] | 114 | IMPLICIT NONE |
---|
[4046] | 115 | CHARACTER(LEN=*), INTENT(IN) :: str |
---|
| 116 | INTEGER :: k |
---|
| 117 | out = str |
---|
| 118 | DO k=1,LEN_TRIM(str) |
---|
[4120] | 119 | IF(str(k:k)>='a' .AND. str(k:k)<='z') out(k:k)=ACHAR(IACHAR(str(k:k))-32) |
---|
[4046] | 120 | END DO |
---|
| 121 | END FUNCTION strUpper |
---|
| 122 | !============================================================================================================================== |
---|
| 123 | |
---|
| 124 | |
---|
| 125 | !============================================================================================================================== |
---|
[4403] | 126 | !=== Extract the substring in front of the first (last if lBackward==TRUE) occurrence of "sep" in "str" ================ |
---|
[4046] | 127 | !=== Examples for str='a_b_c' and sep='_' and the bash command with the same effect: ================ |
---|
| 128 | !=== * strHead(..,.FALSE.) = 'a' ${str%%$sep*} ================ |
---|
| 129 | !=== * strHead(..,.TRUE.) = 'a_b' ${str%$sep*} ================ |
---|
| 130 | !============================================================================================================================== |
---|
[5745] | 131 | CHARACTER(LEN=maxlen) FUNCTION strHead_1(str, sep, lBackward) RESULT(out) |
---|
[5001] | 132 | IMPLICIT NONE |
---|
[4046] | 133 | CHARACTER(LEN=*), INTENT(IN) :: str |
---|
| 134 | CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sep |
---|
[4403] | 135 | LOGICAL, OPTIONAL, INTENT(IN) :: lBackward |
---|
[4349] | 136 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
[4046] | 137 | IF(PRESENT(sep)) THEN |
---|
[4403] | 138 | IF( PRESENT(lBackWard)) out = str(1:INDEX(str,sep,lBackWard)-1) |
---|
| 139 | IF(.NOT.PRESENT(lBackWard)) out = str(1:INDEX(str,sep)-1) |
---|
[4046] | 140 | ELSE |
---|
[4403] | 141 | IF( PRESENT(lBackWard)) out = str(1:INDEX(str,'/',lBackWard)-1) |
---|
| 142 | IF(.NOT.PRESENT(lBackWard)) out = str(1:INDEX(str,'/')-1) |
---|
[4046] | 143 | END IF |
---|
| 144 | IF(out == '') out = str |
---|
| 145 | END FUNCTION strHead_1 |
---|
| 146 | !============================================================================================================================== |
---|
[4403] | 147 | FUNCTION strHead_m(str, sep, lBackward) RESULT(out) |
---|
[5001] | 148 | IMPLICIT NONE |
---|
[4046] | 149 | CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:) |
---|
| 150 | CHARACTER(LEN=*), INTENT(IN) :: str(:) |
---|
| 151 | CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sep |
---|
[4403] | 152 | LOGICAL, OPTIONAL, INTENT(IN) :: lBackward |
---|
[4349] | 153 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
[4046] | 154 | INTEGER :: k |
---|
| 155 | IF(PRESENT(sep)) THEN |
---|
[4403] | 156 | IF( PRESENT(lBackWard)) out = [(strHead_1(str(k), sep, lBackWard), k=1, SIZE(str))] |
---|
| 157 | IF(.NOT.PRESENT(lBackWard)) out = [(strHead_1(str(k), sep), k=1, SIZE(str))] |
---|
[4046] | 158 | ELSE |
---|
[4403] | 159 | IF( PRESENT(lBackWard)) out = [(strHead_1(str(k), '/', lBackWard), k=1, SIZE(str))] |
---|
| 160 | IF(.NOT.PRESENT(lBackWard)) out = [(strHead_1(str(k), '/'), k=1, SIZE(str))] |
---|
[4046] | 161 | END IF |
---|
| 162 | END FUNCTION strHead_m |
---|
| 163 | !============================================================================================================================== |
---|
[4403] | 164 | !=== Extract the substring following the first (last if lBackward==TRUE) occurrence of "sep" in "str" ================ |
---|
[4046] | 165 | !=== Examples for str='a_b_c' and sep='_' and the bash command with the same effect: ================ |
---|
[4403] | 166 | !=== * strTail(str, '_', .FALSE.) = 'b_c' ${str#*$sep} ================ |
---|
| 167 | !=== * strTail(str, '_', .TRUE.) = 'c' ${str##*$sep} ================ |
---|
[4046] | 168 | !============================================================================================================================== |
---|
[5745] | 169 | CHARACTER(LEN=maxlen) FUNCTION strTail_1(str, sep, lBackWard) RESULT(out) |
---|
[5001] | 170 | IMPLICIT NONE |
---|
[4046] | 171 | CHARACTER(LEN=*), INTENT(IN) :: str |
---|
| 172 | CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sep |
---|
[4403] | 173 | LOGICAL, OPTIONAL, INTENT(IN) :: lBackWard |
---|
[4349] | 174 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
[4046] | 175 | IF(PRESENT(sep)) THEN |
---|
[4403] | 176 | IF( PRESENT(lBackWard)) out = str(INDEX(str,sep,lBackWard)+LEN(sep):LEN_TRIM(str)) |
---|
| 177 | IF(.NOT.PRESENT(lBackWard)) out = str(INDEX(str,sep) +LEN(sep):LEN_TRIM(str)) |
---|
[4046] | 178 | ELSE |
---|
[4403] | 179 | IF( PRESENT(lBackWard)) out = str(INDEX(str,'/',lBackWard)+1:LEN_TRIM(str)) |
---|
| 180 | IF(.NOT.PRESENT(lBackWard)) out = str(INDEX(str,'/') +1:LEN_TRIM(str)) |
---|
[4046] | 181 | END IF |
---|
| 182 | IF(out == '') out = str |
---|
| 183 | END FUNCTION strTail_1 |
---|
| 184 | !============================================================================================================================== |
---|
[4403] | 185 | FUNCTION strTail_m(str, sep, lBackWard) RESULT(out) |
---|
[5001] | 186 | IMPLICIT NONE |
---|
[4046] | 187 | CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:) |
---|
| 188 | CHARACTER(LEN=*), INTENT(IN) :: str(:) |
---|
| 189 | CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sep |
---|
[4403] | 190 | LOGICAL, OPTIONAL, INTENT(IN) :: lBackWard |
---|
[4349] | 191 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
[4046] | 192 | INTEGER :: k |
---|
| 193 | IF(PRESENT(sep)) THEN |
---|
[4403] | 194 | IF( PRESENT(lBackWard)) out = [(strTail_1(str(k), sep, lBackWard), k=1, SIZE(str))] |
---|
| 195 | IF(.NOT.PRESENT(lBackWard)) out = [(strTail_1(str(k), sep), k=1, SIZE(str))] |
---|
[4046] | 196 | ELSE |
---|
[4403] | 197 | IF( PRESENT(lBackWard)) out = [(strTail_1(str(k), '/', lBackWard), k=1, SIZE(str))] |
---|
| 198 | IF(.NOT.PRESENT(lBackWard)) out = [(strTail_1(str(k), '/'), k=1, SIZE(str))] |
---|
[4046] | 199 | END IF |
---|
| 200 | END FUNCTION strTail_m |
---|
| 201 | !============================================================================================================================== |
---|
| 202 | |
---|
| 203 | |
---|
| 204 | !============================================================================================================================== |
---|
| 205 | !=== Concatenates the strings "str(:)" with separator "sep" into a single string using a separator (',' by default). ========== |
---|
| 206 | !============================================================================================================================== |
---|
[4063] | 207 | FUNCTION strStack(str, sep, mask) RESULT(out) |
---|
[5001] | 208 | IMPLICIT NONE |
---|
[4046] | 209 | CHARACTER(LEN=:), ALLOCATABLE :: out |
---|
| 210 | CHARACTER(LEN=*), INTENT(IN) :: str(:) |
---|
| 211 | CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sep |
---|
[4063] | 212 | LOGICAL, OPTIONAL, INTENT(IN) :: mask(:) |
---|
[4349] | 213 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
[4046] | 214 | CHARACTER(LEN=:), ALLOCATABLE :: s |
---|
[4063] | 215 | INTEGER :: is, i0 |
---|
[4046] | 216 | IF(SIZE(str) == 0) THEN; out = ''; RETURN; END IF |
---|
| 217 | ALLOCATE(s, SOURCE=', '); IF(PRESENT(sep)) s=sep |
---|
[4063] | 218 | IF(PRESENT(mask)) THEN |
---|
| 219 | IF(ALL(.NOT.mask)) THEN; out = ''; RETURN; END IF |
---|
| 220 | i0 = 0; DO WHILE(.NOT.mask(i0+1)); i0 = i0+1; END DO |
---|
| 221 | out = str(i0); DO is=i0+1,SIZE(str, DIM=1); IF(.NOT.mask(is)) CYCLE; out = TRIM(out)//s//TRIM(str(is)); END DO |
---|
| 222 | ELSE |
---|
| 223 | out = str(1); DO is=2,SIZE(str, DIM=1); out = TRIM(out)//s//TRIM(str(is)); END DO |
---|
| 224 | END IF |
---|
[4046] | 225 | END FUNCTION strStack |
---|
| 226 | !============================================================================================================================== |
---|
| 227 | !=== Concatenate the strings "str(:)" with separator "sep" into one or several lines of "nmax" characters max (for display) === |
---|
| 228 | !============================================================================================================================== |
---|
| 229 | FUNCTION strStackm(str, sep, nmax) RESULT(out) |
---|
[5001] | 230 | IMPLICIT NONE |
---|
[4046] | 231 | CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:) |
---|
| 232 | CHARACTER(LEN=*), INTENT(IN) :: str(:) |
---|
| 233 | CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sep |
---|
| 234 | INTEGER, OPTIONAL, INTENT(IN) :: nmax |
---|
[4349] | 235 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
[4046] | 236 | CHARACTER(LEN=maxlen), ALLOCATABLE :: t(:) |
---|
| 237 | CHARACTER(LEN=maxlen) :: sp |
---|
| 238 | INTEGER :: is, ns, no, mx, n |
---|
| 239 | IF(SIZE(str) == 0) THEN; out = ['']; RETURN; END IF |
---|
| 240 | sp =', '; IF(PRESENT(sep )) sp = sep |
---|
| 241 | ns = 2 ; IF(PRESENT(sep )) ns = LEN(sep) |
---|
| 242 | mx = 256; IF(PRESENT(nmax)) mx = nmax |
---|
| 243 | no = 1; out = [''] |
---|
| 244 | DO is = 1, SIZE(str) |
---|
| 245 | n = LEN_TRIM(str(is)); IF(out(no)/='') n = n+ns+LEN_TRIM(out(no)) !--- Line length after "str(is)" inclusion |
---|
| 246 | IF(out(no) == '') THEN |
---|
| 247 | out(no) = str(is) !--- Empty new line: set to "str(is)" |
---|
| 248 | ELSE IF(n <= mx) THEN |
---|
| 249 | out(no) = TRIM(out(no))//sp(1:ns)//TRIM(str(is)) !--- Append "str(is)" to the current line |
---|
| 250 | ELSE |
---|
| 251 | ALLOCATE(t(no+1)); t(1:no) = out; no=no+1; t(no) = str(is) !--- Full line: "str(si)" put in next line |
---|
| 252 | CALL MOVE_ALLOC(FROM=t, TO=out) |
---|
| 253 | END IF |
---|
| 254 | END DO |
---|
| 255 | END FUNCTION strStackm |
---|
| 256 | !============================================================================================================================== |
---|
| 257 | |
---|
| 258 | |
---|
| 259 | !============================================================================================================================== |
---|
| 260 | !=== String cleaning: replace tabulation by spaces, remove NULL characters and comments. ====================================== |
---|
| 261 | !============================================================================================================================== |
---|
| 262 | SUBROUTINE strClean_1(str) |
---|
[5001] | 263 | IMPLICIT NONE |
---|
[4046] | 264 | CHARACTER(LEN=*), INTENT(INOUT) :: str |
---|
| 265 | INTEGER :: k, n, m |
---|
| 266 | n = LEN(str) |
---|
| 267 | DO k = n, 1, -1 |
---|
| 268 | m = IACHAR(str(k:k)) |
---|
| 269 | IF(m==9) str(k:k) = ' ' !--- Replace the tabulations with spaces |
---|
| 270 | IF(m==0) str(k:n) = str(k+1:n)//' ' !--- Remove the NULL characters |
---|
| 271 | END DO |
---|
| 272 | m = INDEX(str,'!')-1; IF(m==-1) m = LEN_TRIM(str) !--- Remove end of line comment |
---|
| 273 | str = ADJUSTL(str(1:m)) |
---|
| 274 | END SUBROUTINE strClean_1 |
---|
| 275 | !============================================================================================================================== |
---|
| 276 | SUBROUTINE strClean_m(str) |
---|
[5001] | 277 | IMPLICIT NONE |
---|
[4046] | 278 | CHARACTER(LEN=*), INTENT(INOUT) :: str(:) |
---|
| 279 | INTEGER :: k |
---|
| 280 | DO k = 1, SIZE(str); CALL strClean_1(str(k)); END DO |
---|
| 281 | END SUBROUTINE strClean_m |
---|
| 282 | !============================================================================================================================== |
---|
| 283 | |
---|
| 284 | |
---|
| 285 | !============================================================================================================================== |
---|
| 286 | !=== strReduce_1(str1) : Remove duplicated elements of str1. =========================================================== |
---|
| 287 | !=== strReduce_2(str1,str2): Append str1 with new elements of str2. =========================================================== |
---|
| 288 | !============================================================================================================================== |
---|
[4067] | 289 | SUBROUTINE strReduce_1(str, nb) |
---|
[5001] | 290 | IMPLICIT NONE |
---|
[4067] | 291 | CHARACTER(LEN=*), ALLOCATABLE, INTENT(INOUT) :: str(:) |
---|
[4046] | 292 | INTEGER, OPTIONAL, INTENT(OUT) :: nb |
---|
[4349] | 293 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
[4046] | 294 | CHARACTER(LEN=maxlen), ALLOCATABLE :: s1(:) |
---|
[4068] | 295 | INTEGER :: k, n, n1 |
---|
| 296 | IF(PRESENT(nb)) nb = 0 |
---|
| 297 | CALL MOVE_ALLOC(FROM=str, TO=s1); CALL strClean(s1) |
---|
| 298 | n1 = SIZE(s1, DIM=1) !--- Total nb. of elements in "s1" |
---|
| 299 | n = COUNT( [( ALL(s1(1:k-1)/=s1(k)), k=1, n1 )] ) !--- Nb of unique elements in "s1" |
---|
| 300 | ALLOCATE(str(n)) |
---|
| 301 | IF(n==0) RETURN |
---|
| 302 | str(1) = s1(1) |
---|
[4069] | 303 | n=1; DO k=2,n1; IF(ANY(s1(1:k-1)==s1(k))) CYCLE; n=n+1; str(n)=s1(k); END DO |
---|
[4068] | 304 | IF(PRESENT(nb)) nb=n |
---|
[4046] | 305 | END SUBROUTINE strReduce_1 |
---|
| 306 | !============================================================================================================================== |
---|
| 307 | SUBROUTINE strReduce_2(str1, str2) |
---|
[5001] | 308 | IMPLICIT NONE |
---|
[4046] | 309 | CHARACTER(LEN=*), ALLOCATABLE, INTENT(INOUT) :: str1(:) |
---|
| 310 | CHARACTER(LEN=*), INTENT(IN) :: str2(:) |
---|
[4349] | 311 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
[4046] | 312 | CHARACTER(LEN=maxlen), ALLOCATABLE :: s1(:), s2(:) |
---|
| 313 | INTEGER :: k |
---|
| 314 | IF(SIZE(str2)==0) RETURN |
---|
| 315 | s2 = str2; CALL strClean(s2) |
---|
| 316 | IF(.NOT.ALLOCATED(s2)) RETURN |
---|
| 317 | IF(SIZE(s2) == 0) THEN; DEALLOCATE(s2); RETURN; END IF |
---|
| 318 | IF(.NOT.ALLOCATED(str1)) THEN |
---|
| 319 | str1 = s2 |
---|
| 320 | ELSE IF(SIZE(str1)==0) THEN |
---|
| 321 | str1 = s2 |
---|
| 322 | ELSE |
---|
| 323 | s1 = str1; CALL strClean(s1) |
---|
| 324 | str1 = [s1, PACK(s2, MASK= [( ALL(s1(:) /= s2(k)), k=1, SIZE(s2) )] ) ] |
---|
| 325 | END IF |
---|
| 326 | END SUBROUTINE strReduce_2 |
---|
| 327 | !============================================================================================================================== |
---|
| 328 | |
---|
| 329 | |
---|
| 330 | !============================================================================================================================== |
---|
[4349] | 331 | !=== GET THE INDEX OF THE FIRST APPEARANCE IN THE STRING VECTOR "str(:)" OF THE STRING(s) "s[(:)]" ============================ |
---|
| 332 | !=== OPTIONALY: GET THE NUMBER OF FOUND ELEMENTS "n". NB: UNFOUND => INDEX=0 ============================ |
---|
[4046] | 333 | !============================================================================================================================== |
---|
[5745] | 334 | INTEGER FUNCTION strIdx_1(str, s) RESULT(out) |
---|
[5001] | 335 | IMPLICIT NONE |
---|
[4046] | 336 | CHARACTER(LEN=*), INTENT(IN) :: str(:), s |
---|
| 337 | DO out = 1, SIZE(str); IF(str(out) == s) EXIT; END DO |
---|
| 338 | IF(out == 1+SIZE(str) .OR. SIZE(str)==0) out = 0 |
---|
| 339 | END FUNCTION strIdx_1 |
---|
| 340 | !============================================================================================================================== |
---|
| 341 | FUNCTION strIdx_m(str, s, n) RESULT(out) |
---|
[5001] | 342 | IMPLICIT NONE |
---|
[4046] | 343 | CHARACTER(LEN=*), INTENT(IN) :: str(:), s(:) |
---|
| 344 | INTEGER, OPTIONAL, INTENT(OUT) :: n |
---|
| 345 | INTEGER, ALLOCATABLE :: out(:) |
---|
[4349] | 346 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
[4046] | 347 | INTEGER :: k |
---|
| 348 | out = [(strIdx_1(str(:), s(k)), k=1, SIZE(s))] |
---|
| 349 | IF(PRESENT(n)) n = COUNT(out(:)/=0) |
---|
| 350 | END FUNCTION strIdx_m |
---|
| 351 | !============================================================================================================================== |
---|
| 352 | |
---|
| 353 | |
---|
| 354 | !============================================================================================================================== |
---|
| 355 | !=== GET THE INDEX LIST OF THE ELEMENTS OF "str(:)" EQUAL TO "s" AND OPTIONALY, ITS LENGTH "n" ================================ |
---|
| 356 | !============================================================================================================================== |
---|
[5001] | 357 | FUNCTION strFind_1(str, s, n) RESULT(out) |
---|
| 358 | IMPLICIT NONE |
---|
[4046] | 359 | CHARACTER(LEN=*), INTENT(IN) :: str(:), s |
---|
| 360 | INTEGER, OPTIONAL, INTENT(OUT) :: n |
---|
| 361 | INTEGER, ALLOCATABLE :: out(:) |
---|
[4349] | 362 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
[4046] | 363 | INTEGER :: k |
---|
| 364 | out = PACK( [(k, k=1, SIZE(str(:), DIM=1))], MASK = str(:) == s ) |
---|
| 365 | IF(PRESENT(n)) n = SIZE(out(:), DIM=1) |
---|
[5001] | 366 | END FUNCTION strFind_1 |
---|
[4046] | 367 | !============================================================================================================================== |
---|
[5001] | 368 | FUNCTION strFind_m(str, s, n) RESULT(out) |
---|
| 369 | IMPLICIT NONE |
---|
| 370 | CHARACTER(LEN=*), INTENT(IN) :: str(:), s(:) |
---|
| 371 | INTEGER, OPTIONAL, INTENT(OUT) :: n |
---|
| 372 | INTEGER, ALLOCATABLE :: out(:) |
---|
| 373 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
| 374 | INTEGER :: k |
---|
| 375 | out = [(strFind_1(str, s(k)), k=1, SIZE(s))] |
---|
| 376 | IF(PRESENT(n)) n = SIZE(out(:), DIM=1) |
---|
| 377 | END FUNCTION strFind_m |
---|
| 378 | !============================================================================================================================== |
---|
| 379 | FUNCTION intFind_1(i,j,n) RESULT(out) |
---|
| 380 | IMPLICIT NONE |
---|
[4046] | 381 | INTEGER, INTENT(IN) :: i(:), j |
---|
| 382 | INTEGER, OPTIONAL, INTENT(OUT) :: n |
---|
| 383 | INTEGER, ALLOCATABLE :: out(:) |
---|
[4349] | 384 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
[4046] | 385 | INTEGER :: k |
---|
| 386 | out = PACK( [(k, k=1, SIZE(i(:), DIM=1))], MASK = i(:) == j ) |
---|
| 387 | IF(PRESENT(n)) n = SIZE(out(:), DIM=1) |
---|
[5001] | 388 | END FUNCTION intFind_1 |
---|
[4046] | 389 | !============================================================================================================================== |
---|
[5001] | 390 | FUNCTION intFind_m(i,j,n) RESULT(out) |
---|
| 391 | IMPLICIT NONE |
---|
| 392 | INTEGER, INTENT(IN) :: i(:), j(:) |
---|
[4046] | 393 | INTEGER, OPTIONAL, INTENT(OUT) :: n |
---|
| 394 | INTEGER, ALLOCATABLE :: out(:) |
---|
[4349] | 395 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
[4046] | 396 | INTEGER :: k |
---|
[5001] | 397 | out = [(intFind_1(i, j(k)), k=1, SIZE(j))] |
---|
| 398 | IF(PRESENT(n)) n = SIZE(out(:), DIM=1) |
---|
| 399 | END FUNCTION intFind_m |
---|
| 400 | !============================================================================================================================== |
---|
| 401 | FUNCTION booFind(l,n) RESULT(out) |
---|
| 402 | IMPLICIT NONE |
---|
[5745] | 403 | LOGICAL, INTENT(IN) :: l(:) |
---|
[5001] | 404 | INTEGER, OPTIONAL, INTENT(OUT) :: n |
---|
| 405 | INTEGER, ALLOCATABLE :: out(:) |
---|
| 406 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
| 407 | INTEGER :: k |
---|
[4046] | 408 | out = PACK( [(k, k=1, SIZE(l(:), DIM=1))], MASK = l(:) ) |
---|
| 409 | IF(PRESENT(n)) n = SIZE(out(:), DIM=1) |
---|
[5001] | 410 | END FUNCTION booFind |
---|
[4046] | 411 | !============================================================================================================================== |
---|
| 412 | |
---|
| 413 | |
---|
| 414 | !============================================================================================================================== |
---|
[5747] | 415 | !=== DUPLICATE A VECTOR "v(:)" "n" times ====================================================================================== |
---|
| 416 | !============================================================================================================================== |
---|
| 417 | SUBROUTINE dupl_s(v, n, vdup) |
---|
| 418 | CHARACTER(LEN=*), INTENT(IN) :: v(:) |
---|
| 419 | INTEGER, INTENT(IN) :: n |
---|
| 420 | CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: vdup(:) |
---|
| 421 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
| 422 | INTEGER :: nv, i |
---|
| 423 | nv = SIZE(v) |
---|
| 424 | ALLOCATE(vdup(n*nv)) |
---|
| 425 | DO i = 1, n; vdup(1+(i-1)*nv:i*nv) = v; END DO |
---|
| 426 | END SUBROUTINE dupl_s |
---|
| 427 | !============================================================================================================================== |
---|
| 428 | SUBROUTINE dupl_i(v, n, vdup) |
---|
| 429 | INTEGER, INTENT(IN) :: v(:) |
---|
| 430 | INTEGER, INTENT(IN) :: n |
---|
| 431 | INTEGER, ALLOCATABLE, INTENT(OUT) :: vdup(:) |
---|
| 432 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
| 433 | INTEGER :: nv, i |
---|
| 434 | nv = SIZE(v) |
---|
| 435 | ALLOCATE(vdup(n*nv)) |
---|
| 436 | DO i = 1, n; vdup(1+(i-1)*nv:i*nv) = v; END DO |
---|
| 437 | END SUBROUTINE dupl_i |
---|
| 438 | !============================================================================================================================== |
---|
| 439 | SUBROUTINE dupl_r(v, n, vdup) |
---|
| 440 | REAL, INTENT(IN) :: v(:) |
---|
| 441 | INTEGER, INTENT(IN) :: n |
---|
| 442 | REAL, ALLOCATABLE, INTENT(OUT) :: vdup(:) |
---|
| 443 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
| 444 | INTEGER :: nv, i |
---|
| 445 | nv = SIZE(v) |
---|
| 446 | ALLOCATE(vdup(n*nv)) |
---|
| 447 | DO i = 1, n; vdup(1+(i-1)*nv:i*nv) = v; END DO |
---|
| 448 | END SUBROUTINE dupl_r |
---|
| 449 | !============================================================================================================================== |
---|
| 450 | SUBROUTINE dupl_l(v, n, vdup) |
---|
| 451 | LOGICAL, INTENT(IN) :: v(:) |
---|
| 452 | INTEGER, INTENT(IN) :: n |
---|
| 453 | LOGICAL, ALLOCATABLE, INTENT(OUT) :: vdup(:) |
---|
| 454 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
| 455 | INTEGER :: nv, i |
---|
| 456 | nv = SIZE(v) |
---|
| 457 | ALLOCATE(vdup(n*nv)) |
---|
| 458 | DO i = 1, n; vdup(1+(i-1)*nv:i*nv) = v; END DO |
---|
| 459 | END SUBROUTINE dupl_l |
---|
| 460 | !============================================================================================================================== |
---|
| 461 | |
---|
| 462 | |
---|
| 463 | !============================================================================================================================== |
---|
[4046] | 464 | !=== GET THE INDEX IN "rawList" OF THE 1ST APPEARANCE OF ONE OF THE "del(:)" SEPARATORS (0 IF NONE OF THEM ARE PRESENT) |
---|
| 465 | !=== IF lSc == .TRUE.: * SKIP HEAD SIGNS OR EXPONENTS SIGNS THAT SHOULD NOT BE CONFUSED WITH SEPARATORS |
---|
| 466 | !=== * THEN TEST WHETHER THE STRING FROM START TO THE FOUND SEPARATOR IS A CORRECTLY FORMATTED NUMBER |
---|
| 467 | !============================================================================================================================== |
---|
[5745] | 468 | LOGICAL FUNCTION strIdx_prv(rawList, del, ibeg, idx, idel, lSc) RESULT(lerr) |
---|
[5001] | 469 | IMPLICIT NONE |
---|
[4046] | 470 | CHARACTER(LEN=*), INTENT(IN) :: rawList !--- String in which delimiters have to be identified |
---|
| 471 | CHARACTER(LEN=*), INTENT(IN) :: del(:) !--- List of delimiters |
---|
| 472 | INTEGER, INTENT(IN) :: ibeg !--- Start index |
---|
| 473 | INTEGER, INTENT(OUT) :: idx !--- Index of the first identified delimiter in "rawList" |
---|
| 474 | INTEGER, INTENT(OUT) :: idel !--- Index of the identified delimiter (0 if idx==0) |
---|
[5745] | 475 | LOGICAL, OPTIONAL, INTENT(IN) :: lSc !--- Care about nbs with front sign or in scient. notation |
---|
[4348] | 476 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
[4363] | 477 | INTEGER :: idx0 !--- Used to display an identified non-numeric string |
---|
[4046] | 478 | lerr = .FALSE. |
---|
[4348] | 479 | idx = strIdx1(rawList, del, ibeg, idel) !--- idx/=0: del(idel) is at position "idx" in "rawList" |
---|
[4046] | 480 | IF(.NOT.PRESENT(lSc)) RETURN !--- No need to check exceptions for numbers => finished |
---|
| 481 | IF(.NOT. lSc ) RETURN !--- No need to check exceptions for numbers => finished |
---|
[4348] | 482 | |
---|
| 483 | !=== No delimiter found: the whole string must be a valid number |
---|
| 484 | IF(idx == 0) THEN !--- No element of "del" in "rawList" |
---|
[4349] | 485 | lerr = .NOT.is_numeric(rawList(ibeg:LEN_TRIM(rawList))) !--- String must be a number |
---|
[4348] | 486 | IF(lerr) idx = LEN_TRIM(rawList); RETURN !--- Set idx so that rawList(ibeg:idx-1) = whole string |
---|
[4046] | 487 | END IF |
---|
[4348] | 488 | |
---|
[5001] | 489 | lerr = idx == 1 .AND. INDEX('+-',del(idel)) /= 0; IF(lerr) RETURN !--- The front delimiter is different from +/-: error |
---|
| 490 | IF( idx /= 1 .AND. is_numeric(rawList(ibeg:idx-1))) RETURN !--- The input string head is a valid number |
---|
[4348] | 491 | |
---|
| 492 | !=== The string part in front of the 1st delimiter is not a valid number: search for next delimiter index "idx" |
---|
| 493 | idx0 = idx ; idx = strIdx1(rawList, del, idx+1, idel) !--- Keep start index because idx is recycled |
---|
[4046] | 494 | IF(idx == 0) THEN |
---|
[4349] | 495 | lerr = .NOT.is_numeric(rawList(ibeg:LEN_TRIM(rawList))) !--- No other delimiter: whole string must be a valid numb |
---|
[4046] | 496 | IF(lerr) idx = idx0; RETURN |
---|
| 497 | END IF |
---|
[4349] | 498 | lerr = .NOT.is_numeric(rawList(ibeg:idx-1)) |
---|
[4348] | 499 | |
---|
[4046] | 500 | CONTAINS |
---|
| 501 | |
---|
[4348] | 502 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
[5745] | 503 | INTEGER FUNCTION strIdx1(str, del, ib, id) RESULT(i) |
---|
[4348] | 504 | !--- Get the index of the first appereance of one of the delimiters "del(:)" in "str" starting from position "ib". |
---|
| 505 | !--- "id" is the index in "del(:)" of the first delimiter found. |
---|
[4349] | 506 | IMPLICIT NONE |
---|
[4348] | 507 | CHARACTER(LEN=*), INTENT(IN) :: str, del(:) |
---|
[4046] | 508 | INTEGER, INTENT(IN) :: ib |
---|
| 509 | INTEGER, INTENT(OUT) :: id |
---|
[4348] | 510 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
[4349] | 511 | DO i = ib, LEN_TRIM(str); id = strIdx(del, str(i:i)); IF(id /= 0) EXIT; END DO |
---|
| 512 | IF(i > LEN_TRIM(str)) THEN; i = 0; id = 0; END IF |
---|
[4046] | 513 | END FUNCTION strIdx1 |
---|
| 514 | |
---|
| 515 | END FUNCTION strIdx_prv |
---|
| 516 | !============================================================================================================================== |
---|
| 517 | |
---|
| 518 | |
---|
| 519 | !============================================================================================================================== |
---|
| 520 | !=== Count the number of elements separated by "delimiter" in list "rawList". ================================================= |
---|
| 521 | !============================================================================================================================== |
---|
[5745] | 522 | LOGICAL FUNCTION strCount_11(rawList, delimiter, nb, lSc) RESULT(lerr) |
---|
[5001] | 523 | IMPLICIT NONE |
---|
[4046] | 524 | CHARACTER(LEN=*), INTENT(IN) :: rawList |
---|
| 525 | CHARACTER(LEN=*), INTENT(IN) :: delimiter |
---|
| 526 | INTEGER, INTENT(OUT) :: nb |
---|
| 527 | LOGICAL, OPTIONAL, INTENT(IN) :: lSc |
---|
[4349] | 528 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
[4046] | 529 | LOGICAL :: ll |
---|
| 530 | ll = .FALSE.; IF(PRESENT(lSc)) ll = lSc |
---|
[4358] | 531 | lerr = strCount_1m(rawList, [delimiter], nb, ll) |
---|
[4046] | 532 | END FUNCTION strCount_11 |
---|
| 533 | !============================================================================================================================== |
---|
[5745] | 534 | LOGICAL FUNCTION strCount_m1(rawList, delimiter, nb, lSc) RESULT(lerr) |
---|
[5001] | 535 | IMPLICIT NONE |
---|
[4046] | 536 | CHARACTER(LEN=*), INTENT(IN) :: rawList(:) |
---|
| 537 | CHARACTER(LEN=*), INTENT(IN) :: delimiter |
---|
| 538 | INTEGER, ALLOCATABLE, INTENT(OUT) :: nb(:) |
---|
| 539 | LOGICAL, OPTIONAL, INTENT(IN) :: lSc |
---|
[4349] | 540 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
[4046] | 541 | LOGICAL :: ll |
---|
| 542 | INTEGER :: id |
---|
| 543 | ll = .FALSE.; IF(PRESENT(lSc)) ll = lSc .AND. INDEX('+-', delimiter) /= 0 |
---|
[4358] | 544 | lerr = .TRUE. |
---|
[4046] | 545 | ALLOCATE(nb(SIZE(rawList))) |
---|
| 546 | DO id = 1, SIZE(rawList) |
---|
[4358] | 547 | lerr = lerr .AND. strCount_1m(rawList(id), [delimiter], nb(id), ll) |
---|
[4046] | 548 | END DO |
---|
| 549 | END FUNCTION strCount_m1 |
---|
| 550 | !============================================================================================================================== |
---|
[5745] | 551 | LOGICAL FUNCTION strCount_1m(rawList, delimiter, nb, lSc) RESULT(lerr) |
---|
[5001] | 552 | IMPLICIT NONE |
---|
[4046] | 553 | CHARACTER(LEN=*), INTENT(IN) :: rawList |
---|
| 554 | CHARACTER(LEN=*), INTENT(IN) :: delimiter(:) |
---|
| 555 | INTEGER, INTENT(OUT) :: nb |
---|
| 556 | LOGICAL, OPTIONAL, INTENT(IN) :: lSc |
---|
[4349] | 557 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
[4046] | 558 | INTEGER :: ib, ie, jd, nr |
---|
| 559 | LOGICAL :: ll |
---|
| 560 | CHARACTER(LEN=1024) :: r |
---|
| 561 | lerr = .FALSE. |
---|
| 562 | ll = .FALSE.; IF(PRESENT(lSc)) ll = lSc |
---|
| 563 | r = TRIM(ADJUSTL(rawList)) |
---|
| 564 | nr = LEN_TRIM(r); IF(nr == 0) RETURN |
---|
| 565 | nb = 1; ib = 1 |
---|
| 566 | DO |
---|
| 567 | lerr = strIdx_prv(r, delimiter, ib, ie, jd, ll) |
---|
[5746] | 568 | CALL msg('"'//TRIM(r(ib:ie-1))//'" is not numeric', ll = lerr); IF(lerr) RETURN |
---|
[4349] | 569 | IF(ie == 0 .OR. jd == 0) EXIT |
---|
[4046] | 570 | ib = ie + LEN(delimiter(jd)) |
---|
| 571 | DO WHILE(r(ib:ib) == ' ' .AND. ib < nr); ib = ib + 1; END DO !--- Skip spaces before next chain |
---|
| 572 | nb = nb + 1 |
---|
| 573 | END DO |
---|
| 574 | END FUNCTION strCount_1m |
---|
| 575 | !============================================================================================================================== |
---|
| 576 | |
---|
| 577 | |
---|
| 578 | !============================================================================================================================== |
---|
| 579 | !=== Purpose: Parse "delimiter"-separated list "rawList" into the pair keys(:), vals(:). ==================================== |
---|
| 580 | !=== Corresponding "vals" remains empty if the element does not contain "=" sign. ==================================== |
---|
| 581 | !============================================================================================================================== |
---|
[5745] | 582 | LOGICAL FUNCTION strParse(rawList, delimiter, keys, n, vals) RESULT(lerr) |
---|
[5001] | 583 | IMPLICIT NONE |
---|
[4046] | 584 | CHARACTER(LEN=*), INTENT(IN) :: rawList, delimiter |
---|
| 585 | CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: keys(:) |
---|
[4348] | 586 | INTEGER, OPTIONAL, INTENT(OUT) :: n |
---|
[4046] | 587 | CHARACTER(LEN=maxlen), ALLOCATABLE, OPTIONAL, INTENT(OUT) :: vals(:) |
---|
[4348] | 588 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
| 589 | CHARACTER(LEN=1024) :: r |
---|
[4349] | 590 | INTEGER :: nr, nk |
---|
[4348] | 591 | lerr = .FALSE. |
---|
| 592 | r = TRIM(ADJUSTL(rawList)) |
---|
| 593 | nr = LEN_TRIM(r); IF(nr == 0) THEN; keys = ['']; RETURN; END IF |
---|
[5001] | 594 | nk = countK() !--- COUNT THE ELEMENTS |
---|
| 595 | CALL parseK(keys) !--- PARSE THE KEYS |
---|
| 596 | IF(PRESENT(vals)) CALL parseV(vals) !--- PARSE <key>=<val> PAIRS |
---|
| 597 | IF(PRESENT(n)) n = nk !--- RETURN THE NUMBER OF KEYS |
---|
[4348] | 598 | |
---|
| 599 | CONTAINS |
---|
| 600 | |
---|
[4349] | 601 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
[5745] | 602 | INTEGER FUNCTION countK() RESULT(nkeys) |
---|
[5001] | 603 | !--- Get the number of elements after parsing. |
---|
[4349] | 604 | IMPLICIT NONE |
---|
| 605 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
[5001] | 606 | INTEGER :: ib, ie, nl |
---|
| 607 | nkeys = 1; ib = 1; nl = LEN(delimiter) |
---|
[4348] | 608 | DO |
---|
| 609 | ie = INDEX(rawList(ib:nr), delimiter)+ib-1 !--- Determine the next separator start index |
---|
| 610 | IF(ie == ib-1) EXIT |
---|
[5001] | 611 | ib = ie + nl |
---|
| 612 | DO WHILE(ANY([0, 9, 32] == IACHAR(r(ib:ib))) .AND. ib < nr) !--- Skip blanks (ascii): NULL (0), TAB (9), SPACE (32) |
---|
| 613 | ib = ib + 1 |
---|
| 614 | END DO !--- Skip spaces before next chain |
---|
| 615 | nkeys = nkeys+1 |
---|
| 616 | END DO |
---|
| 617 | END FUNCTION countK |
---|
| 618 | |
---|
| 619 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
| 620 | SUBROUTINE parseK(keys) |
---|
| 621 | !--- Parse the string separated by "delimiter" from "rawList" into "keys(:)" |
---|
| 622 | IMPLICIT NONE |
---|
| 623 | CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: keys(:) |
---|
| 624 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
| 625 | INTEGER :: ib, ie, ik |
---|
| 626 | ALLOCATE(keys(nk)) |
---|
| 627 | ib = 1 |
---|
| 628 | DO ik = 1, nk |
---|
| 629 | ie = INDEX(rawList(ib:nr), delimiter)+ib-1 !--- Determine the next separator start index |
---|
| 630 | IF(ie == ib-1) EXIT |
---|
| 631 | keys(ik) = r(ib:ie-1) !--- Get the ikth key |
---|
[4348] | 632 | ib = ie + LEN(delimiter) |
---|
| 633 | DO WHILE(r(ib:ib) == ' ' .AND. ib < nr); ib = ib + 1; END DO !--- Skip spaces before next chain |
---|
| 634 | END DO |
---|
[5001] | 635 | keys(ik) = r(ib:nr) !--- Get the last key |
---|
| 636 | END SUBROUTINE parseK |
---|
[4348] | 637 | |
---|
[4349] | 638 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
[5001] | 639 | SUBROUTINE parseV(vals) |
---|
| 640 | !--- Parse the <key>=<val> pairs in "keys(:)" into "keys" and "vals" |
---|
| 641 | IMPLICIT NONE |
---|
| 642 | CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: vals(:) |
---|
[4349] | 643 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
[5001] | 644 | CHARACTER(LEN=maxlen) :: key |
---|
| 645 | INTEGER :: ik, ix |
---|
| 646 | ALLOCATE(vals(nk)) |
---|
| 647 | DO ik = 1, nk; key = keys(ik) |
---|
| 648 | vals(ik) = '' |
---|
| 649 | ix = INDEX(key, '='); IF(ix == 0) CYCLE !--- First "=" index in "key" |
---|
| 650 | vals(ik) = ADJUSTL(key(ix+1:LEN_TRIM(key))) |
---|
| 651 | keys(ik) = ADJUSTL(key(1:ix-1)) |
---|
| 652 | END DO |
---|
| 653 | END SUBROUTINE parseV |
---|
[4348] | 654 | |
---|
| 655 | END FUNCTION strParse |
---|
[4046] | 656 | !============================================================================================================================== |
---|
[5745] | 657 | LOGICAL FUNCTION strParse_m(rawList, delimiter, keys, n, vals, lSc, id) RESULT(lerr) |
---|
[5001] | 658 | IMPLICIT NONE |
---|
[4046] | 659 | CHARACTER(LEN=*), INTENT(IN) :: rawList, delimiter(:) |
---|
| 660 | CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: keys(:) !--- Parsed keys vector |
---|
[4348] | 661 | INTEGER, OPTIONAL, INTENT(OUT) :: n !--- Length of the parsed vector |
---|
| 662 | CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: vals(:) !--- Values for <name>=<value> keys |
---|
[4046] | 663 | LOGICAL, OPTIONAL, INTENT(IN) :: lSc !--- Take care about numbers in scientific notation |
---|
| 664 | INTEGER, OPTIONAL, ALLOCATABLE, INTENT(OUT) :: id(:) !--- Indexes of the separators in "delimiter(:)" vector |
---|
[4348] | 665 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
[4046] | 666 | CHARACTER(LEN=1024) :: r |
---|
| 667 | INTEGER :: nr, ik, nk, ib, ie, jd |
---|
| 668 | LOGICAL :: ll |
---|
| 669 | ll = .FALSE.; IF(PRESENT(lSc)) ll = lSc |
---|
[5001] | 670 | lerr = strCount_1m(rawList, delimiter, nk, ll) |
---|
| 671 | CALL msg("Couldn't parse list: non-numerical strings were found", ll=lerr); IF(lerr) RETURN |
---|
[4046] | 672 | |
---|
| 673 | !--- FEW ALLOCATIONS |
---|
| 674 | ALLOCATE(keys(nk)) |
---|
| 675 | IF(PRESENT(vals)) ALLOCATE(vals(nk)) |
---|
| 676 | IF(PRESENT(id)) ALLOCATE(id(nk-1)) |
---|
| 677 | IF(PRESENT(n)) n = nk |
---|
| 678 | |
---|
| 679 | !--- PARSING |
---|
| 680 | r = TRIM(ADJUSTL(rawList)) |
---|
| 681 | nr = LEN_TRIM(r); IF(nr == 0) RETURN |
---|
| 682 | ib = 1 |
---|
| 683 | DO ik = 1, nk-1 |
---|
[5001] | 684 | lerr = strIdx_prv(r, delimiter, ib, ie, jd, ll) |
---|
| 685 | CALL msg('Non-numeric values found', ll=lerr); IF(lerr) RETURN |
---|
[4046] | 686 | keys(ik) = r(ib:ie-1) |
---|
| 687 | IF(PRESENT(vals)) CALL parseKeys(keys(ik), vals(ik)) !--- Parse a <key>=<val> pair |
---|
| 688 | IF(PRESENT(id )) id(ik) = jd !--- Index in "delimiter(:)" of the "ik"th delimiter |
---|
| 689 | ib = ie + LEN_TRIM( delimiter(jd) ) !--- Length of the current delimiter |
---|
| 690 | DO WHILE(r(ib:ib) == ' ' .AND. ib < nr); ib = ib + 1; END DO !--- Skip spaces before next chain |
---|
| 691 | END DO |
---|
| 692 | keys(nk) = r(ib:nr) |
---|
| 693 | IF(PRESENT(vals)) CALL parseKeys(keys(nk), vals(nk)) !--- Parse a <key>=<val> pair |
---|
| 694 | |
---|
| 695 | CONTAINS |
---|
| 696 | |
---|
[4349] | 697 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
[4046] | 698 | SUBROUTINE parseKeys(key, val) |
---|
[5001] | 699 | IMPLICIT NONE |
---|
[4046] | 700 | CHARACTER(LEN=*), INTENT(INOUT) :: key |
---|
| 701 | CHARACTER(LEN=*), INTENT(OUT) :: val |
---|
[4349] | 702 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
[4046] | 703 | INTEGER :: ix |
---|
| 704 | ix = INDEX(key, '='); IF(ix == 0) RETURN !--- First "=" index in "key" |
---|
| 705 | val = ADJUSTL(key(ix+1:LEN_TRIM(key))) |
---|
| 706 | key = ADJUSTL(key(1:ix-1)) |
---|
| 707 | END SUBROUTINE parseKeys |
---|
| 708 | |
---|
| 709 | END FUNCTION strParse_m |
---|
| 710 | !============================================================================================================================== |
---|
| 711 | |
---|
| 712 | |
---|
| 713 | !============================================================================================================================== |
---|
| 714 | !=== String substitution: replace "key" by "val" each time it appears in "str". |
---|
| 715 | !============================================================================================================================== |
---|
| 716 | SUBROUTINE strReplace_1(str, key, val, lsurr) |
---|
[5001] | 717 | IMPLICIT NONE |
---|
[4046] | 718 | CHARACTER(LEN=*), INTENT(INOUT) :: str !--- Main string |
---|
| 719 | CHARACTER(LEN=*), INTENT(IN) :: key, val !--- "key" will be replaced by "val" |
---|
| 720 | LOGICAL, OPTIONAL, INTENT(IN) :: lsurr !--- TRUE => key must be surrounded by special characters to be substituted |
---|
[4349] | 721 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
[4046] | 722 | INTEGER :: i0, ix, nk, ns |
---|
| 723 | LOGICAL :: lsur, lb, le |
---|
| 724 | lsur = .FALSE.; IF(PRESENT(lsurr)) lsur = lsurr |
---|
| 725 | nk = LEN_TRIM(key) |
---|
| 726 | i0 = 1 |
---|
| 727 | DO |
---|
| 728 | ns = LEN_TRIM(str) |
---|
| 729 | ix = INDEX(str(i0:ns), TRIM(key)) !--- First appearance index of "key" in "s", starting from index "i0" |
---|
| 730 | IF(ix == 0) EXIT |
---|
| 731 | ix = ix + i0 -1 |
---|
| 732 | IF(lsur) THEN !--- Key must be surrounded by special characters |
---|
| 733 | !--- lb=.TRUE.: key is at the very beginning of "str" or located after a special character |
---|
| 734 | lb = ix ==1; IF(.NOT.lb) lb = INDEX('+-*/()^', str(ix-1 :ix-1 ))/=0 |
---|
| 735 | !--- le=.TRUE.: key is at the very end of "str" or located before a special character |
---|
| 736 | le = ix+nk-1==ns; IF(.NOT.le) le = INDEX('+-*/()^', str(ix+nk:ix+nk))/=0 |
---|
| 737 | IF(.NOT.(lb.AND.le)) THEN; i0 = i0 + nk; CYCLE; END IF |
---|
| 738 | END IF |
---|
| 739 | str = str(1:ix-1)//TRIM(val)//str(ix+nk:ns) |
---|
| 740 | END DO |
---|
| 741 | END SUBROUTINE strReplace_1 |
---|
| 742 | !============================================================================================================================== |
---|
| 743 | SUBROUTINE strReplace_m(str, key, val, lsurr) |
---|
[5001] | 744 | IMPLICIT NONE |
---|
[4046] | 745 | CHARACTER(LEN=*), INTENT(INOUT) :: str(:) !--- Main strings vector |
---|
| 746 | CHARACTER(LEN=*), INTENT(IN) :: key, val !--- "key" will be replaced by "val" |
---|
| 747 | LOGICAL, OPTIONAL, INTENT(IN) :: lsurr !--- TRUE => key must be surrounded by special characters to be substituted |
---|
| 748 | INTEGER :: k |
---|
| 749 | LOGICAL :: ll |
---|
| 750 | ll=.FALSE.; IF(PRESENT(lsurr)) ll=lsurr |
---|
| 751 | DO k=1, SIZE(str); CALL strReplace_1(str(k),key,val,ll); END DO |
---|
| 752 | END SUBROUTINE strReplace_m |
---|
| 753 | !============================================================================================================================== |
---|
| 754 | |
---|
| 755 | |
---|
| 756 | !============================================================================================================================== |
---|
| 757 | !=== Contatenate horizontally scalars/vectors of strings/integers/reals into a vector/array =================================== |
---|
| 758 | !============================================================================================================================== |
---|
[5749] | 759 | FUNCTION horzcat_s00(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) |
---|
[5001] | 760 | IMPLICIT NONE |
---|
[5750] | 761 | CHARACTER(LEN=*), INTENT(IN) :: v0 |
---|
| 762 | CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: v1, v2, v3, v4, v5, v6, v7, v8, v9 |
---|
[4046] | 763 | CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:) |
---|
[5750] | 764 | INTEGER :: ncol, iv, i |
---|
[5001] | 765 | LOGICAL :: pre(9) |
---|
[4349] | 766 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
[5749] | 767 | pre(:) = [PRESENT(v1),PRESENT(v2),PRESENT(v3),PRESENT(v4),PRESENT(v5),PRESENT(v6),PRESENT(v7),PRESENT(v8),PRESENT(v9)] |
---|
| 768 | ncol = 1+COUNT(pre) |
---|
| 769 | ALLOCATE(out(ncol)) |
---|
| 770 | out(1) = v0 |
---|
[5750] | 771 | i = 2 |
---|
| 772 | DO iv = i, ncol; IF(.NOT.pre(iv-1)) CYCLE |
---|
[5749] | 773 | SELECT CASE(iv-1) |
---|
[5750] | 774 | CASE(1); out(i) = v1; CASE(2); out(i) = v2; CASE(3); out(i) = v3; CASE(4); out(i) = v4; CASE(5); out(i) = v5 |
---|
| 775 | CASE(6); out(i) = v6; CASE(7); out(i) = v7; CASE(8); out(i) = v8; CASE(9); out(i) = v9 |
---|
[5749] | 776 | END SELECT |
---|
[5750] | 777 | i = i+1 |
---|
[4046] | 778 | END DO |
---|
[5001] | 779 | END FUNCTION horzcat_s00 |
---|
[4046] | 780 | !============================================================================================================================== |
---|
[5749] | 781 | FUNCTION horzcat_s10(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) |
---|
[5001] | 782 | IMPLICIT NONE |
---|
[5749] | 783 | CHARACTER(LEN=*), INTENT(IN) :: v0(:), v1 |
---|
| 784 | CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: v2, v3, v4, v5, v6, v7, v8, v9 |
---|
[5001] | 785 | CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:), tmp(:) |
---|
[5750] | 786 | tmp = horzcat_s00(v1, v2, v3, v4, v5, v6, v7, v8, v9) |
---|
| 787 | out = [v0 , tmp] |
---|
[5001] | 788 | END FUNCTION horzcat_s10 |
---|
| 789 | !============================================================================================================================== |
---|
[5749] | 790 | FUNCTION horzcat_s11(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) |
---|
[5001] | 791 | IMPLICIT NONE |
---|
[5750] | 792 | CHARACTER(LEN=*), INTENT(IN) :: v0(:) |
---|
| 793 | CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: v1(:), v2(:), v3(:), v4(:), v5(:), v6(:), v7(:), v8(:), v9(:) |
---|
[4046] | 794 | CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:,:) |
---|
[5750] | 795 | INTEGER :: nrow, ncol, iv, i |
---|
[5749] | 796 | LOGICAL :: pre(9) |
---|
[4349] | 797 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
[5749] | 798 | pre(:) = [PRESENT(v1),PRESENT(v2),PRESENT(v3),PRESENT(v4),PRESENT(v5),PRESENT(v6),PRESENT(v7),PRESENT(v8),PRESENT(v9)] |
---|
| 799 | nrow = SIZE(v0) |
---|
[5001] | 800 | ncol = 1+COUNT(pre) |
---|
[5750] | 801 | IF(pre(1)) nrow = MAX(nrow,SIZE(v1)); IF(pre(2)) nrow = MAX(nrow,SIZE(v2)); IF(pre(3)) nrow = MAX(nrow,SIZE(v3)) |
---|
| 802 | IF(pre(4)) nrow = MAX(nrow,SIZE(v4)); IF(pre(5)) nrow = MAX(nrow,SIZE(v5)); IF(pre(6)) nrow = MAX(nrow,SIZE(v6)) |
---|
| 803 | IF(pre(7)) nrow = MAX(nrow,SIZE(v7)); IF(pre(8)) nrow = MAX(nrow,SIZE(v8)); IF(pre(9)) nrow = MAX(nrow,SIZE(v9)) |
---|
| 804 | ALLOCATE(out(nrow, ncol)); out(:,:) = '' |
---|
| 805 | out(1:SIZE(v0),1) = v0 |
---|
| 806 | i = 2 |
---|
| 807 | DO iv = i, ncol; IF(.NOT.pre(iv-1)) CYCLE |
---|
[5749] | 808 | SELECT CASE(iv-1) |
---|
[5750] | 809 | CASE(1); out(1:SIZE(v1),i) = v1; CASE(2); out(1:SIZE(v2),i) = v2; CASE(3); out(1:SIZE(v3),i) = v3 |
---|
| 810 | CASE(4); out(1:SIZE(v4),i) = v4; CASE(5); out(1:SIZE(v5),i) = v5; CASE(6); out(1:SIZE(v5),i) = v6 |
---|
| 811 | CASE(7); out(1:SIZE(v7),i) = v7; CASE(8); out(1:SIZE(v8),i) = v8; CASE(9); out(1:SIZE(v9),i) = v9 |
---|
[5749] | 812 | END SELECT |
---|
[5750] | 813 | i = i+1 |
---|
[4046] | 814 | END DO |
---|
[5001] | 815 | END FUNCTION horzcat_s11 |
---|
[4046] | 816 | !============================================================================================================================== |
---|
[5749] | 817 | FUNCTION horzcat_s21(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) |
---|
[5001] | 818 | IMPLICIT NONE |
---|
[5749] | 819 | CHARACTER(LEN=*), INTENT(IN) :: v0(:,:), v1(:) |
---|
| 820 | CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: v2(:), v3(:), v4(:), v5(:), v6(:), v7(:), v8(:), v9(:) |
---|
[5750] | 821 | CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:,:), tmp(:,:) |
---|
| 822 | tmp = horzcat_s11(v1, v2, v3, v4, v5, v6, v7, v8, v9) |
---|
| 823 | out = horzcat_s22(v0, tmp) |
---|
[5001] | 824 | END FUNCTION horzcat_s21 |
---|
| 825 | !============================================================================================================================== |
---|
[5750] | 826 | FUNCTION horzcat_s22(v0, v1) RESULT(out) |
---|
| 827 | IMPLICIT NONE |
---|
| 828 | CHARACTER(LEN=*), INTENT(IN) :: v0(:,:), v1(:,:) |
---|
| 829 | CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:,:), pk(:), tmp(:,:) |
---|
| 830 | INTEGER :: n0, n1, nrow |
---|
| 831 | n0 = SIZE(v0,1) |
---|
| 832 | n1 = SIZE(v1,1) |
---|
| 833 | nrow = MAX(n0, n1) |
---|
| 834 | IF(n0 == n1) THEN |
---|
| 835 | pk = PACK(v0, .TRUE.); pk = [pk, PACK(v1, .TRUE.)] |
---|
| 836 | ELSE IF(n0 /= nrow) THEN |
---|
| 837 | ALLOCATE(tmp(nrow,SIZE(v0,2))); tmp(:,:) = ''; tmp(1:n0,:) = v0(:,:); pk = PACK(tmp, .TRUE.); pk = [pk, PACK(v1, .TRUE.)] |
---|
| 838 | ELSE |
---|
| 839 | ALLOCATE(tmp(nrow,SIZE(v1,2))); tmp(:,:) = ''; tmp(1:n1,:) = v1(:,:); pk = PACK(tmp, .TRUE.); pk = [PACK(v0, .TRUE.), pk] |
---|
| 840 | END IF |
---|
| 841 | out = RESHAPE(pk, SHAPE=[nrow, SIZE(v0, 2) + SIZE(v1, 2)]) |
---|
| 842 | END FUNCTION horzcat_s22 |
---|
| 843 | !============================================================================================================================== |
---|
[5749] | 844 | FUNCTION horzcat_i00(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) |
---|
[5001] | 845 | IMPLICIT NONE |
---|
[5750] | 846 | INTEGER, INTENT(IN) :: v0 |
---|
| 847 | INTEGER, OPTIONAL, INTENT(IN) :: v1, v2, v3, v4, v5, v6, v7, v8, v9 |
---|
[4046] | 848 | INTEGER, ALLOCATABLE :: out(:) |
---|
[5750] | 849 | INTEGER :: ncol, iv, i |
---|
[5001] | 850 | LOGICAL :: pre(9) |
---|
[4349] | 851 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
[5749] | 852 | pre(:) = [PRESENT(v1),PRESENT(v2),PRESENT(v3),PRESENT(v4),PRESENT(v5),PRESENT(v6),PRESENT(v7),PRESENT(v8),PRESENT(v9)] |
---|
[5750] | 853 | ncol = 1+COUNT(pre) |
---|
[5001] | 854 | ALLOCATE(out(ncol)) |
---|
[5749] | 855 | out(1) = v0 |
---|
[5750] | 856 | i = 2 |
---|
| 857 | DO iv = i, ncol; IF(.NOT.pre(iv-1)) CYCLE |
---|
[5749] | 858 | SELECT CASE(iv-1) |
---|
[5750] | 859 | CASE(1); out(i) = v1; CASE(2); out(i) = v2; CASE(3); out(i) = v3; CASE(4); out(i) = v4; CASE(5); out(i) = v5 |
---|
| 860 | CASE(6); out(i) = v6; CASE(7); out(i) = v7; CASE(8); out(i) = v8; CASE(9); out(i) = v9 |
---|
[5749] | 861 | END SELECT |
---|
[5750] | 862 | i = i+1 |
---|
[4046] | 863 | END DO |
---|
[5001] | 864 | END FUNCTION horzcat_i00 |
---|
[4046] | 865 | !============================================================================================================================== |
---|
[5749] | 866 | FUNCTION horzcat_i10(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) |
---|
[5001] | 867 | IMPLICIT NONE |
---|
[5749] | 868 | INTEGER, INTENT(IN) :: v0(:), v1 |
---|
| 869 | INTEGER, OPTIONAL, INTENT(IN) :: v2, v3, v4, v5, v6, v7, v8, v9 |
---|
[5001] | 870 | INTEGER, ALLOCATABLE :: out(:), tmp(:) |
---|
[5750] | 871 | tmp = horzcat_i00(v1, v2, v3, v4, v5, v6, v7, v8, v9) |
---|
| 872 | out = [v0, tmp] |
---|
[5001] | 873 | END FUNCTION horzcat_i10 |
---|
| 874 | !============================================================================================================================== |
---|
[5749] | 875 | FUNCTION horzcat_i11(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) |
---|
[5001] | 876 | IMPLICIT NONE |
---|
[5750] | 877 | INTEGER, INTENT(IN) :: v0(:) |
---|
| 878 | INTEGER, OPTIONAL, INTENT(IN) :: v1(:), v2(:), v3(:), v4(:), v5(:), v6(:), v7(:), v8(:), v9(:) |
---|
[4046] | 879 | INTEGER, ALLOCATABLE :: out(:,:) |
---|
[5750] | 880 | INTEGER :: siz(9), nrow, ncol, iv, i, n |
---|
| 881 | LOGICAL :: pre(9) |
---|
[4349] | 882 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
[5749] | 883 | pre(:) = [PRESENT(v1),PRESENT(v2),PRESENT(v3),PRESENT(v4),PRESENT(v5),PRESENT(v6),PRESENT(v7),PRESENT(v8),PRESENT(v9)] |
---|
| 884 | nrow = SIZE(v0) |
---|
[5001] | 885 | ncol = 1+COUNT(pre) |
---|
[4046] | 886 | ALLOCATE(out(nrow, ncol)) |
---|
[5749] | 887 | out(:,1) = v0 |
---|
[5750] | 888 | i = 2 |
---|
| 889 | DO iv = i, ncol; IF(.NOT.pre(iv-1)) CYCLE |
---|
[5749] | 890 | SELECT CASE(iv-1) |
---|
[5750] | 891 | CASE(1); n = SIZE(v1); CASE(2); n = SIZE(v2); CASE(3); n = SIZE(v3); CASE(4); n = SIZE(v4); CASE(5); n = SIZE(v5) |
---|
| 892 | CASE(6); n = SIZE(v6); CASE(7); n = SIZE(v7); CASE(8); n = SIZE(v8); CASE(9); n = SIZE(v9) |
---|
[5749] | 893 | END SELECT |
---|
[5750] | 894 | IF(n /= nrow) THEN; CALL msg("Can't concatenate integer vectors of differing lengths"); STOP; END IF |
---|
| 895 | SELECT CASE(iv-1) |
---|
| 896 | CASE(1); out(:,i) = v1; CASE(2); out(:,i) = v2; CASE(3); out(:,i) = v3; CASE(4); out(:,i) = v4; CASE(5); out(:,i) = v5 |
---|
| 897 | CASE(6); out(:,i) = v6; CASE(7); out(:,i) = v7; CASE(8); out(:,i) = v8; CASE(9); out(:,i) = v9 |
---|
| 898 | END SELECT |
---|
| 899 | i = i+1 |
---|
[4046] | 900 | END DO |
---|
[5001] | 901 | END FUNCTION horzcat_i11 |
---|
[4046] | 902 | !============================================================================================================================== |
---|
[5749] | 903 | FUNCTION horzcat_i21(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) |
---|
[5001] | 904 | IMPLICIT NONE |
---|
[5749] | 905 | INTEGER, INTENT(IN) :: v0(:,:), v1(:) |
---|
| 906 | INTEGER, OPTIONAL, INTENT(IN) :: v2(:), v3(:), v4(:), v5(:), v6(:), v7(:), v8(:), v9(:) |
---|
[5001] | 907 | INTEGER, ALLOCATABLE :: out(:,:), tmp(:,:) |
---|
[5750] | 908 | tmp = horzcat_i11(v1, v2, v3, v4, v5, v6, v7, v8, v9) |
---|
| 909 | out = horzcat_i22(v0, tmp) |
---|
[5001] | 910 | END FUNCTION horzcat_i21 |
---|
| 911 | !============================================================================================================================== |
---|
[5750] | 912 | FUNCTION horzcat_i22(v0, v1) RESULT(out) |
---|
| 913 | IMPLICIT NONE |
---|
| 914 | INTEGER, INTENT(IN) :: v0(:,:), v1(:,:) |
---|
| 915 | INTEGER, ALLOCATABLE :: out(:,:), pk(:) |
---|
| 916 | INTEGER :: nrow, ncol |
---|
| 917 | nrow = SIZE(v0,1) |
---|
| 918 | ncol = SIZE(v0,2)+SIZE(v1,2) |
---|
| 919 | IF(nrow /= SIZE(v1,1)) THEN; CALL msg("Can't concatenate integer arrays of differing rows numbers"); STOP; END IF |
---|
| 920 | ALLOCATE(out(nrow, ncol)) |
---|
| 921 | pk = PACK(v0, .TRUE.) |
---|
| 922 | pk = [pk, PACK(v1, .TRUE.)] |
---|
| 923 | out = RESHAPE(pk, SHAPE=[nrow, ncol]) |
---|
| 924 | END FUNCTION horzcat_i22 |
---|
| 925 | !============================================================================================================================== |
---|
[5749] | 926 | FUNCTION horzcat_r00(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) |
---|
[5001] | 927 | IMPLICIT NONE |
---|
[5750] | 928 | REAL(KIND=REAL32), INTENT(IN) :: v0 |
---|
| 929 | REAL(KIND=REAL32), OPTIONAL, INTENT(IN) :: v1, v2, v3, v4, v5, v6, v7, v8, v9 |
---|
[5748] | 930 | REAL(KIND=REAL32), ALLOCATABLE :: out(:) |
---|
[5750] | 931 | INTEGER :: ncol, iv, i |
---|
[5001] | 932 | LOGICAL :: pre(9) |
---|
[4349] | 933 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
[5749] | 934 | pre(:) = [PRESENT(v1),PRESENT(v2),PRESENT(v3),PRESENT(v4),PRESENT(v5),PRESENT(v6),PRESENT(v7),PRESENT(v8),PRESENT(v9)] |
---|
[5001] | 935 | ncol = 1+COUNT(pre) |
---|
| 936 | ALLOCATE(out(ncol)) |
---|
[5749] | 937 | out(1) = v0 |
---|
[5750] | 938 | i = 2 |
---|
| 939 | DO iv = i, ncol; IF(.NOT.pre(iv-1)) CYCLE |
---|
[5749] | 940 | SELECT CASE(iv-1) |
---|
[5750] | 941 | CASE(1); out(i) = v1; CASE(2); out(i) = v2; CASE(3); out(i) = v3; CASE(4); out(i) = v4; CASE(5); out(i) = v5 |
---|
| 942 | CASE(6); out(i) = v6; CASE(7); out(i) = v7; CASE(8); out(i) = v8; CASE(9); out(i) = v9 |
---|
[5749] | 943 | END SELECT |
---|
[5750] | 944 | i = i+1 |
---|
[4046] | 945 | END DO |
---|
[5001] | 946 | END FUNCTION horzcat_r00 |
---|
[4046] | 947 | !============================================================================================================================== |
---|
[5749] | 948 | FUNCTION horzcat_r10(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) |
---|
[5001] | 949 | IMPLICIT NONE |
---|
[5749] | 950 | REAL(KIND=REAL32), INTENT(IN) :: v0(:), v1 |
---|
| 951 | REAL(KIND=REAL32), OPTIONAL, INTENT(IN) :: v2, v3, v4, v5, v6, v7, v8, v9 |
---|
[5748] | 952 | REAL(KIND=REAL32), ALLOCATABLE :: out(:), tmp(:) |
---|
[5750] | 953 | tmp = horzcat_r00(v1, v2, v3, v4, v5, v6, v7, v8, v9) |
---|
| 954 | out = [v0 , tmp] |
---|
[5001] | 955 | END FUNCTION horzcat_r10 |
---|
| 956 | !============================================================================================================================== |
---|
[5749] | 957 | FUNCTION horzcat_r11(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) |
---|
[5001] | 958 | IMPLICIT NONE |
---|
[5750] | 959 | REAL(KIND=REAL32), INTENT(IN) :: v0(:) |
---|
| 960 | REAL(KIND=REAL32), OPTIONAL, INTENT(IN) :: v1(:), v2(:), v3(:), v4(:), v5(:), v6(:), v7(:), v8(:), v9(:) |
---|
[5748] | 961 | REAL(KIND=REAL32), ALLOCATABLE :: out(:,:) |
---|
[5750] | 962 | INTEGER :: siz(9), nrow, ncol, iv, i, n |
---|
[5748] | 963 | LOGICAL :: pre(9) |
---|
[4349] | 964 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
[5749] | 965 | pre(:) = [PRESENT(v1),PRESENT(v2),PRESENT(v3),PRESENT(v4),PRESENT(v5),PRESENT(v6),PRESENT(v7),PRESENT(v8),PRESENT(v9)] |
---|
| 966 | nrow = SIZE(v0) |
---|
[5001] | 967 | ncol = 1+COUNT(pre) |
---|
[4046] | 968 | ALLOCATE(out(nrow, ncol)) |
---|
[5749] | 969 | out(:,1) = v0 |
---|
[5750] | 970 | i = 2 |
---|
| 971 | DO iv = i, ncol; IF(.NOT.pre(iv-1)) CYCLE |
---|
[5749] | 972 | SELECT CASE(iv-1) |
---|
[5750] | 973 | CASE(1); n = SIZE(v1); CASE(2); n = SIZE(v2); CASE(3); n = SIZE(v3); CASE(4); n = SIZE(v4); CASE(5); n = SIZE(v5) |
---|
| 974 | CASE(6); n = SIZE(v6); CASE(7); n = SIZE(v7); CASE(8); n = SIZE(v8); CASE(9); n = SIZE(v9) |
---|
[5749] | 975 | END SELECT |
---|
[5750] | 976 | IF(n /= nrow) THEN; CALL msg("Can't concatenate real vectors of differing lengths"); STOP; END IF |
---|
| 977 | SELECT CASE(iv-1) |
---|
| 978 | CASE(1); out(:,i) = v1; CASE(2); out(:,i) = v2; CASE(3); out(:,i) = v3; CASE(4); out(:,i) = v4; CASE(5); out(:,i) = v5 |
---|
| 979 | CASE(6); out(:,i) = v6; CASE(7); out(:,i) = v7; CASE(8); out(:,i) = v8; CASE(9); out(:,i) = v9 |
---|
| 980 | END SELECT |
---|
| 981 | i = i+1 |
---|
[4046] | 982 | END DO |
---|
[5001] | 983 | END FUNCTION horzcat_r11 |
---|
[4046] | 984 | !============================================================================================================================== |
---|
[5749] | 985 | FUNCTION horzcat_r21(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) |
---|
[5001] | 986 | IMPLICIT NONE |
---|
[5749] | 987 | REAL(KIND=REAL32), INTENT(IN) :: v0(:,:), v1(:) |
---|
| 988 | REAL(KIND=REAL32), OPTIONAL, INTENT(IN) :: v2(:), v3(:), v4(:), v5(:), v6(:), v7(:), v8(:), v9(:) |
---|
[5748] | 989 | REAL(KIND=REAL32), ALLOCATABLE :: out(:,:), tmp(:,:) |
---|
[5749] | 990 | tmp = horzcat_r11(v1, v2, v3, v4, v5, v6, v7, v8, v9) |
---|
[5750] | 991 | out = horzcat_r22(v0, tmp) |
---|
[5001] | 992 | END FUNCTION horzcat_r21 |
---|
| 993 | !============================================================================================================================== |
---|
[5750] | 994 | FUNCTION horzcat_r22(v0, v1) RESULT(out) |
---|
| 995 | IMPLICIT NONE |
---|
| 996 | REAL(KIND=REAL32), INTENT(IN) :: v0(:,:), v1(:,:) |
---|
| 997 | REAL(KIND=REAL32), ALLOCATABLE :: out(:,:), pk(:) |
---|
| 998 | INTEGER :: nrow, ncol |
---|
| 999 | nrow = SIZE(v0,1) |
---|
| 1000 | ncol = SIZE(v0,2)+SIZE(v1,2) |
---|
| 1001 | IF(nrow /= SIZE(v1,1)) THEN; CALL msg("Can't concatenate real arrays of differing rows numbers"); STOP; END IF |
---|
| 1002 | ALLOCATE(out(nrow, ncol)) |
---|
| 1003 | pk = PACK(v0, .TRUE.) |
---|
| 1004 | pk = [pk, PACK(v1, .TRUE.)] |
---|
| 1005 | out = RESHAPE(pk, SHAPE=[nrow, ncol]) |
---|
| 1006 | END FUNCTION horzcat_r22 |
---|
| 1007 | !============================================================================================================================== |
---|
[5749] | 1008 | FUNCTION horzcat_d00(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) |
---|
[5001] | 1009 | IMPLICIT NONE |
---|
[5750] | 1010 | REAL(KIND=REAL64), INTENT(IN) :: v0 |
---|
| 1011 | REAL(KIND=REAL64), OPTIONAL, INTENT(IN) :: v1, v2, v3, v4, v5, v6, v7, v8, v9 |
---|
[5748] | 1012 | REAL(KIND=REAL64), ALLOCATABLE :: out(:) |
---|
[5750] | 1013 | INTEGER :: ncol, iv, i |
---|
| 1014 | LOGICAL :: pre(9) |
---|
[4349] | 1015 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
[5749] | 1016 | pre(:) = [PRESENT(v1),PRESENT(v2),PRESENT(v3),PRESENT(v4),PRESENT(v5),PRESENT(v6),PRESENT(v7),PRESENT(v8),PRESENT(v9)] |
---|
[5001] | 1017 | ncol = 1+COUNT(pre) |
---|
| 1018 | ALLOCATE(out(ncol)) |
---|
[5749] | 1019 | out(1) = v0 |
---|
[5750] | 1020 | i = 2 |
---|
| 1021 | DO iv = i, ncol; IF(.NOT.pre(iv-1)) CYCLE |
---|
[5749] | 1022 | SELECT CASE(iv-1) |
---|
[5750] | 1023 | CASE(1); out(i) = v1; CASE(2); out(i) = v2; CASE(3); out(i) = v3; CASE(4); out(i) = v4; CASE(5); out(i) = v5 |
---|
| 1024 | CASE(6); out(i) = v6; CASE(7); out(i) = v7; CASE(8); out(i) = v8; CASE(9); out(i) = v9 |
---|
[5749] | 1025 | END SELECT |
---|
[5750] | 1026 | i = i+1 |
---|
[4046] | 1027 | END DO |
---|
[5001] | 1028 | END FUNCTION horzcat_d00 |
---|
[4046] | 1029 | !============================================================================================================================== |
---|
[5749] | 1030 | FUNCTION horzcat_d10(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) |
---|
[5001] | 1031 | IMPLICIT NONE |
---|
[5749] | 1032 | REAL(KIND=REAL64), INTENT(IN) :: v0(:), v1 |
---|
| 1033 | REAL(KIND=REAL64), OPTIONAL, INTENT(IN) :: v2, v3, v4, v5, v6, v7, v8, v9 |
---|
[5748] | 1034 | REAL(KIND=REAL64), ALLOCATABLE :: out(:), tmp(:) |
---|
[5750] | 1035 | tmp = horzcat_d00(v1, v2, v3, v4, v5, v6, v7, v8, v9) |
---|
| 1036 | out = [v0 , tmp] |
---|
[5001] | 1037 | END FUNCTION horzcat_d10 |
---|
| 1038 | !============================================================================================================================== |
---|
[5749] | 1039 | FUNCTION horzcat_d11(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) |
---|
[5001] | 1040 | IMPLICIT NONE |
---|
[5750] | 1041 | REAL(KIND=REAL64), INTENT(IN) :: v0(:) |
---|
| 1042 | REAL(KIND=REAL64), OPTIONAL, INTENT(IN) :: v1(:), v2(:), v3(:), v4(:), v5(:), v6(:), v7(:), v8(:), v9(:) |
---|
[5748] | 1043 | REAL(KIND=REAL64), ALLOCATABLE :: out(:,:) |
---|
[5750] | 1044 | INTEGER :: siz(9), nrow, ncol, iv, i, n |
---|
[5749] | 1045 | LOGICAL :: pre(9) |
---|
[4349] | 1046 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
[5749] | 1047 | pre(:) = [PRESENT(v1),PRESENT(v2),PRESENT(v3),PRESENT(v4),PRESENT(v5),PRESENT(v6),PRESENT(v7),PRESENT(v8),PRESENT(v9)] |
---|
| 1048 | nrow = SIZE(v0) |
---|
[5001] | 1049 | ncol = 1+COUNT(pre) |
---|
[4046] | 1050 | ALLOCATE(out(nrow, ncol)) |
---|
[5750] | 1051 | out(:,1) = v0 |
---|
| 1052 | i = 2 |
---|
| 1053 | DO iv = i, ncol; IF(.NOT.pre(iv-1)) CYCLE |
---|
[5749] | 1054 | SELECT CASE(iv-1) |
---|
[5750] | 1055 | CASE(1); n = SIZE(v1); CASE(2); n = SIZE(v2); CASE(3); n = SIZE(v3); CASE(4); n = SIZE(v4); CASE(5); n = SIZE(v5) |
---|
| 1056 | CASE(6); n = SIZE(v6); CASE(7); n = SIZE(v7); CASE(8); n = SIZE(v8); CASE(9); n = SIZE(v9) |
---|
[5749] | 1057 | END SELECT |
---|
[5750] | 1058 | IF(n /= nrow) THEN; CALL msg("Can't concatenate double vectors of differing lengths"); STOP; END IF |
---|
| 1059 | SELECT CASE(iv-1) |
---|
| 1060 | CASE(1); out(:,i) = v1; CASE(2); out(:,i) = v2; CASE(3); out(:,i) = v3; CASE(4); out(:,i) = v4; CASE(5); out(:,i) = v5 |
---|
| 1061 | CASE(6); out(:,i) = v6; CASE(7); out(:,i) = v7; CASE(8); out(:,i) = v8; CASE(9); out(:,i) = v9 |
---|
| 1062 | END SELECT |
---|
| 1063 | i = i+1 |
---|
[4046] | 1064 | END DO |
---|
[5001] | 1065 | END FUNCTION horzcat_d11 |
---|
[4046] | 1066 | !============================================================================================================================== |
---|
[5749] | 1067 | FUNCTION horzcat_d21(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) |
---|
[5001] | 1068 | IMPLICIT NONE |
---|
[5749] | 1069 | REAL(KIND=REAL64), INTENT(IN) :: v0(:,:), v1(:) |
---|
| 1070 | REAL(KIND=REAL64), OPTIONAL, INTENT(IN) :: v2(:), v3(:), v4(:), v5(:), v6(:), v7(:), v8(:), v9(:) |
---|
[5748] | 1071 | REAL(KIND=REAL64), ALLOCATABLE :: out(:,:), tmp(:,:) |
---|
[5750] | 1072 | tmp = horzcat_d11(v1, v2, v3, v4, v5, v6, v7, v8, v9) |
---|
| 1073 | out = horzcat_d22(v0, tmp) |
---|
[5001] | 1074 | END FUNCTION horzcat_d21 |
---|
| 1075 | !============================================================================================================================== |
---|
[5750] | 1076 | FUNCTION horzcat_d22(v0, v1) RESULT(out) |
---|
| 1077 | IMPLICIT NONE |
---|
| 1078 | REAL(KIND=REAL64), INTENT(IN) :: v0(:,:), v1(:,:) |
---|
| 1079 | REAL(KIND=REAL64), ALLOCATABLE :: out(:,:), pk(:) |
---|
| 1080 | INTEGER :: nrow, ncol |
---|
| 1081 | nrow = SIZE(v0,1) |
---|
| 1082 | ncol = SIZE(v0,2)+SIZE(v1,2) |
---|
| 1083 | IF(nrow /= SIZE(v1,1)) THEN; CALL msg("Can't concatenate double arrays of differing rows numbers"); STOP; END IF |
---|
| 1084 | ALLOCATE(out(nrow, ncol)) |
---|
| 1085 | pk = PACK(v0, .TRUE.) |
---|
| 1086 | pk = [pk, PACK(v1, .TRUE.)] |
---|
| 1087 | out = RESHAPE(pk, SHAPE=[nrow, ncol]) |
---|
| 1088 | END FUNCTION horzcat_d22 |
---|
| 1089 | !============================================================================================================================== |
---|
| 1090 | FUNCTION horzcat_l00(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) |
---|
| 1091 | IMPLICIT NONE |
---|
| 1092 | LOGICAL, INTENT(IN) :: v0 |
---|
| 1093 | LOGICAL, OPTIONAL, INTENT(IN) :: v1, v2, v3, v4, v5, v6, v7, v8, v9 |
---|
| 1094 | LOGICAL, ALLOCATABLE :: out(:) |
---|
| 1095 | INTEGER :: ncol, iv, i |
---|
| 1096 | LOGICAL :: pre(9) |
---|
| 1097 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
| 1098 | pre(:) = [PRESENT(v1),PRESENT(v2),PRESENT(v3),PRESENT(v4),PRESENT(v5),PRESENT(v6),PRESENT(v7),PRESENT(v8),PRESENT(v9)] |
---|
| 1099 | ncol = 1+COUNT(pre) |
---|
| 1100 | ALLOCATE(out(ncol)) |
---|
| 1101 | out(1) = v0 |
---|
| 1102 | i = 2 |
---|
| 1103 | DO iv = i, ncol; IF(.NOT.pre(iv-1)) CYCLE |
---|
| 1104 | SELECT CASE(iv-1) |
---|
| 1105 | CASE(1); out(i) = v1; CASE(2); out(i) = v2; CASE(3); out(i) = v3; CASE(4); out(i) = v4; CASE(5); out(i) = v5 |
---|
| 1106 | CASE(6); out(i) = v6; CASE(7); out(i) = v7; CASE(8); out(i) = v8; CASE(9); out(i) = v9 |
---|
| 1107 | END SELECT |
---|
| 1108 | i = i+1 |
---|
| 1109 | END DO |
---|
| 1110 | END FUNCTION horzcat_l00 |
---|
| 1111 | !============================================================================================================================== |
---|
| 1112 | FUNCTION horzcat_l10(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) |
---|
| 1113 | IMPLICIT NONE |
---|
| 1114 | LOGICAL, INTENT(IN) :: v0(:), v1 |
---|
| 1115 | LOGICAL, OPTIONAL, INTENT(IN) :: v2, v3, v4, v5, v6, v7, v8, v9 |
---|
| 1116 | LOGICAL, ALLOCATABLE :: out(:), tmp(:) |
---|
| 1117 | tmp = horzcat_l00(v1, v2, v3, v4, v5, v6, v7, v8, v9) |
---|
| 1118 | out = [v0, tmp] |
---|
| 1119 | END FUNCTION horzcat_l10 |
---|
| 1120 | !============================================================================================================================== |
---|
| 1121 | FUNCTION horzcat_l11(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) |
---|
| 1122 | IMPLICIT NONE |
---|
| 1123 | LOGICAL, INTENT(IN) :: v0(:) |
---|
| 1124 | LOGICAL, OPTIONAL, INTENT(IN) :: v1(:), v2(:), v3(:), v4(:), v5(:), v6(:), v7(:), v8(:), v9(:) |
---|
| 1125 | LOGICAL, ALLOCATABLE :: out(:,:) |
---|
| 1126 | INTEGER :: siz(9), nrow, ncol, iv, i, n |
---|
| 1127 | LOGICAL :: pre(9) |
---|
| 1128 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
| 1129 | pre(:) = [PRESENT(v1),PRESENT(v2),PRESENT(v3),PRESENT(v4),PRESENT(v5),PRESENT(v6),PRESENT(v7),PRESENT(v8),PRESENT(v9)] |
---|
| 1130 | ncol = 1+COUNT(pre) |
---|
| 1131 | nrow = SIZE(v0) |
---|
| 1132 | ALLOCATE(out(nrow, ncol)) |
---|
| 1133 | out(:,1) = v0 |
---|
| 1134 | i = 2 |
---|
| 1135 | DO iv = i, ncol; IF(.NOT.pre(iv-1)) CYCLE |
---|
| 1136 | SELECT CASE(iv-1) |
---|
| 1137 | CASE(1); n = SIZE(v1); CASE(2); n = SIZE(v2); CASE(3); n = SIZE(v3); CASE(4); n = SIZE(v4); CASE(5); n = SIZE(v5) |
---|
| 1138 | CASE(6); n = SIZE(v6); CASE(7); n = SIZE(v7); CASE(8); n = SIZE(v8); CASE(9); n = SIZE(v9) |
---|
| 1139 | END SELECT |
---|
| 1140 | IF(n /= nrow) THEN; CALL msg("Can't concatenate logical vectors of differing lengths"); STOP; END IF |
---|
| 1141 | SELECT CASE(iv-1) |
---|
| 1142 | CASE(1); out(:,i) = v1; CASE(2); out(:,i) = v2; CASE(3); out(:,i) = v3; CASE(4); out(:,i) = v4; CASE(5); out(:,i) = v5 |
---|
| 1143 | CASE(6); out(:,i) = v6; CASE(7); out(:,i) = v7; CASE(8); out(:,i) = v8; CASE(9); out(:,i) = v9 |
---|
| 1144 | END SELECT |
---|
| 1145 | i = i+1 |
---|
| 1146 | END DO |
---|
| 1147 | END FUNCTION horzcat_l11 |
---|
| 1148 | !============================================================================================================================== |
---|
| 1149 | FUNCTION horzcat_l21(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) |
---|
| 1150 | IMPLICIT NONE |
---|
| 1151 | LOGICAL, INTENT(IN) :: v0(:,:), v1(:) |
---|
| 1152 | LOGICAL, OPTIONAL, INTENT(IN) :: v2(:), v3(:), v4(:), v5(:), v6(:), v7(:), v8(:), v9(:) |
---|
| 1153 | LOGICAL, ALLOCATABLE :: out(:,:), tmp(:,:) |
---|
| 1154 | tmp = horzcat_l11(v1, v2, v3, v4, v5, v6, v7, v8, v9) |
---|
| 1155 | out = horzcat_l22(v0, tmp) |
---|
| 1156 | END FUNCTION horzcat_l21 |
---|
| 1157 | !============================================================================================================================== |
---|
| 1158 | FUNCTION horzcat_l22(v0, v1) RESULT(out) |
---|
| 1159 | IMPLICIT NONE |
---|
| 1160 | LOGICAL, INTENT(IN) :: v0(:,:), v1(:,:) |
---|
| 1161 | LOGICAL, ALLOCATABLE :: out(:,:), pk(:) |
---|
| 1162 | INTEGER :: nrow, ncol |
---|
| 1163 | nrow = SIZE(v0,1) |
---|
| 1164 | ncol = SIZE(v0,2)+SIZE(v1,2) |
---|
| 1165 | IF(nrow /= SIZE(v1,1)) THEN; CALL msg("Can't concatenate logical arrays of differing rows numbers"); STOP; END IF |
---|
| 1166 | ALLOCATE(out(nrow, ncol)) |
---|
| 1167 | pk = PACK(v0, .TRUE.) |
---|
| 1168 | pk = [pk, PACK(v1, .TRUE.)] |
---|
| 1169 | out = RESHAPE(pk, SHAPE=[nrow, ncol]) |
---|
| 1170 | END FUNCTION horzcat_l22 |
---|
| 1171 | !============================================================================================================================== |
---|
[4046] | 1172 | |
---|
| 1173 | |
---|
| 1174 | !============================================================================================================================== |
---|
[5751] | 1175 | !=== DISPLAY A TABLE COMPOSED OF HORIZONTALLY CONCATENATED COLUMN VECTORS ===================================================== |
---|
| 1176 | !============================================================================================================================== |
---|
[4046] | 1177 | !=== The profile "p" describe in which order to pick up the columns from "s", "i" and "r" for display. |
---|
[4193] | 1178 | !=== * nRowMax lines are displayed (default: all lines) |
---|
[5751] | 1179 | !=== * nColMax characters (default: as long as needed) are displayed at most on a line. |
---|
| 1180 | !=== - narrow tables are stacked horizontally as much as possible (ie: total width must stay lower than nColMax) . |
---|
| 1181 | !=== - wide tables are cut into several sub-tables of columns subsets, with the first nHead columns repeated. |
---|
| 1182 | !=== * titles can be a vector (one element each column) or an array (dim 1: number of lines ; dim 2: number of columns) |
---|
[4046] | 1183 | !============================================================================================================================== |
---|
[5751] | 1184 | LOGICAL FUNCTION dispTable_1(p, titles, s, i, r, rFmt, nRowMax, nColMax, nHead, unit, sub) RESULT(lerr) |
---|
[5001] | 1185 | IMPLICIT NONE |
---|
[5751] | 1186 | CHARACTER(LEN=*), INTENT(IN) :: p !--- DISPLAY MAP: s/i/r |
---|
| 1187 | CHARACTER(LEN=*), INTENT(IN) :: titles(:) !--- TITLES (one each column, single line) |
---|
| 1188 | CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: s(:,:) !--- STRINGS |
---|
| 1189 | INTEGER, OPTIONAL, INTENT(IN) :: i(:,:) !--- INTEGERS |
---|
| 1190 | REAL, OPTIONAL, INTENT(IN) :: r(:,:) !--- REALS |
---|
| 1191 | CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: rFmt !--- Format for reals |
---|
| 1192 | INTEGER, OPTIONAL, INTENT(IN) :: nRowMax !--- Display at most "nRowMax" rows |
---|
| 1193 | INTEGER, OPTIONAL, INTENT(IN) :: nColMax !--- Display at most "nColMax" characters each line |
---|
| 1194 | INTEGER, OPTIONAL, INTENT(IN) :: nHead !--- Head columns repeated for multiple tables display |
---|
| 1195 | INTEGER, OPTIONAL, INTENT(IN) :: unit !--- Output unit (default: screen) |
---|
| 1196 | CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sub !--- Subroutine name |
---|
[4349] | 1197 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
[5751] | 1198 | lerr = dispTable_2(p, RESHAPE(titles, [1,SIZE(titles)]), s, i, r, rFmt, nRowMax, nColMax, nHead, unit, sub) |
---|
| 1199 | END FUNCTION dispTable_1 |
---|
| 1200 | !============================================================================================================================== |
---|
| 1201 | LOGICAL FUNCTION dispTable_2(p, titles, s, i, r, rFmt, nRowMax, nColMax, nHead, unit, sub) RESULT(lerr) |
---|
| 1202 | IMPLICIT NONE |
---|
| 1203 | CHARACTER(LEN=*), INTENT(IN) :: p !--- DISPLAY MAP: s/i/r |
---|
| 1204 | CHARACTER(LEN=*), INTENT(IN) :: titles(:,:) !--- TITLES (one each column, possibly more than one line) |
---|
| 1205 | CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: s(:,:) !--- STRINGS |
---|
| 1206 | INTEGER, OPTIONAL, INTENT(IN) :: i(:,:) !--- INTEGERS |
---|
| 1207 | REAL, OPTIONAL, INTENT(IN) :: r(:,:) !--- REALS |
---|
| 1208 | CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: rFmt !--- Format for reals |
---|
| 1209 | INTEGER, OPTIONAL, INTENT(IN) :: nRowMax !--- Display at most "nRowMax" rows |
---|
| 1210 | INTEGER, OPTIONAL, INTENT(IN) :: nColMax !--- Display at most "nColMax" characters each line |
---|
| 1211 | INTEGER, OPTIONAL, INTENT(IN) :: nHead !--- Head columns repeated for multiple tables display |
---|
| 1212 | INTEGER, OPTIONAL, INTENT(IN) :: unit !--- Output unit (default: screen) |
---|
| 1213 | CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sub !--- Subroutine name |
---|
| 1214 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
| 1215 | INTEGER, PARAMETER :: nm = 1 |
---|
| 1216 | INTEGER, ALLOCATABLE :: n(:), nmx(:) |
---|
| 1217 | INTEGER :: nRmx, nCmx, nHd, unt, ib, ic, ie, it, nt, ncol, k, l, l0 |
---|
| 1218 | CHARACTER(LEN=maxlen), ALLOCATABLE :: c(:,:), c1(:,:), m(:) |
---|
| 1219 | CHARACTER(LEN=maxlen) :: subn |
---|
| 1220 | |
---|
| 1221 | !=== CONVERT THE ELEMENTS INTO A STRINGS ARRAY |
---|
| 1222 | lerr = convertTable(p, titles, c, s, i, r, rFmt, sub); IF(lerr) RETURN |
---|
| 1223 | |
---|
| 1224 | !=== GET VALUES FOR REMAINING OPTIONAL ARGUMENTS |
---|
| 1225 | nRmx= SIZE(c, 1); IF(PRESENT(nRowMax)) nRmx=MIN(nRmx,nRowMax) !--- Maximum number of lines to print |
---|
| 1226 | nCmx= maxTableWidth; IF(PRESENT(nColMax)) nCmx=MIN(nCmx,nColMax) !--- Maximum number of characters each line |
---|
| 1227 | nHd = 0; IF(PRESENT(nHead)) nHd = nHead !--- Number of front columns to duplicate |
---|
| 1228 | unt = lunout; IF(PRESENT(unit)) unt = unit !--- Unit to print messages |
---|
| 1229 | subn= 'dispTable'; IF(PRESENT(sub)) subn= sub !--- Calling subroutine name |
---|
| 1230 | |
---|
| 1231 | !=== SMALL WIDTH TABLE: STACK AS MUCH VERTICAL SECTIONS HORIZONTALLY AS POSSIBLE CONSIDERING nColMax. UNTOUCHED OTHERWISE. |
---|
| 1232 | n = tableCellsWidth(c)+2*nm |
---|
| 1233 | c1 = gatherTable(c, n, SIZE(titles, 1), nRmx, nCmx, subn) |
---|
| 1234 | ncol = SIZE(c1, DIM=2) |
---|
| 1235 | IF(ncol /= SIZE(c,2)) n = tableCellsWidth(c1)+2*nm !--- UPDATE "n(:)" IF "c" HAS BEEN STACKED |
---|
| 1236 | |
---|
| 1237 | nCmx = 48 |
---|
| 1238 | |
---|
| 1239 | !=== HIGH WIDTH TABLE: CUT IT INTO SUB-TABLES, WITH THE FIRST "nHead" COLUMNS REPEATED IN EACH OF THEM |
---|
| 1240 | !--- Build the vector of max column index in case the rows are too long (table must be displayed in multiple parts) |
---|
| 1241 | IF(SUM(n+1)-1 > nCmx .AND. ncol > 1) THEN |
---|
| 1242 | l0 = 1 + LEN_TRIM(subn) + SUM(n(1:nHd)+1) |
---|
| 1243 | |
---|
| 1244 | !=== DETERMINE THE NUMBER "nt" OF SUB-TABLES |
---|
| 1245 | nt=1; l=l0; DO ic = nHd+1, ncol; IF(l+n(ic)+1 >= nCmx) THEN; l=l0; nt=nt+1; END IF; l = l+n(ic)+1; END DO |
---|
| 1246 | |
---|
| 1247 | !=== GET THE INDEX OF THE LAST COLUMN FOR EACH SUB-TABLE |
---|
| 1248 | ALLOCATE(nmx(nt)) |
---|
| 1249 | it=0; l=l0; DO ic = nHd+1, ncol; IF(l+n(ic)+1 >= nCmx) THEN; l=l0; it=it+1; nmx(it)=ic-1; END IF; l = l+n(ic)+1; END DO |
---|
| 1250 | nmx(nt) = ncol |
---|
| 1251 | |
---|
| 1252 | !=== DISPLAY THE SUB-TABLES |
---|
| 1253 | DO it = 1, nt |
---|
| 1254 | ie = nmx(it); ib = nHd+1; IF(it > 1) ib = nmx(it-1)+1 |
---|
| 1255 | m = buildTable(cat(c1(:,1:nHd),c1(:,ib:ie)), nm, SIZE(titles, 1)) |
---|
| 1256 | DO k = 1, SIZE(m); CALL msg(TRIM(m(k)), subn, unit=unt); END DO; CALL msg('', subn, unit=unt) |
---|
| 1257 | END DO |
---|
| 1258 | ELSE |
---|
| 1259 | !=== DISPLAY THE SINGLE TABLE |
---|
| 1260 | m = buildTable(c1, nm, SIZE(titles,1)) |
---|
| 1261 | DO k = 1, SIZE(m); CALL msg(TRIM(m(k)), subn, unit=unt); END DO |
---|
| 1262 | END IF |
---|
| 1263 | |
---|
| 1264 | CONTAINS |
---|
| 1265 | |
---|
| 1266 | FUNCTION tableCellsWidth(t) RESULT(n) !=== COMPUTE FOR EACH COLUMN THE MIMIMUM WIDTH TO DISPLAY ELEMENTS WITHOUT TRUNCATION |
---|
| 1267 | CHARACTER(LEN=*), INTENT(IN) :: t(:,:) |
---|
| 1268 | INTEGER, ALLOCATABLE :: n(:) |
---|
| 1269 | INTEGER :: i, j |
---|
| 1270 | n = [(MAXVAL([(LEN_TRIM(t(i,j)), i=1, SIZE(t,1))], DIM=1), j=1, SIZE(t,2))] |
---|
| 1271 | END FUNCTION tableCellsWidth |
---|
| 1272 | |
---|
| 1273 | END FUNCTION dispTable_2 |
---|
| 1274 | !============================================================================================================================== |
---|
| 1275 | |
---|
| 1276 | |
---|
| 1277 | !============================================================================================================================== |
---|
| 1278 | !--- Concatenate horizontally the table d0(:,:) so that: |
---|
| 1279 | !=== * total width (number of characters per line) remains lower than nColMax (default: 256 characters) |
---|
| 1280 | !=== * total number of lines remains lower than nRowMax (default: all lines are kept) |
---|
| 1281 | !=== If the table d0 starts with nTitle /= 0 lines for titles, they are duplicated at each section top. |
---|
| 1282 | !============================================================================================================================== |
---|
| 1283 | FUNCTION gatherTable(d0, n, nTitle, nRowMax, nColMax, sub) RESULT(d1) |
---|
| 1284 | IMPLICIT NONE |
---|
| 1285 | CHARACTER(LEN=*), INTENT(IN) :: d0(:,:) !--- Input strings array |
---|
| 1286 | INTEGER, INTENT(IN) :: n(:) !--- Maximum width of elements in each column (excluding separator) |
---|
| 1287 | INTEGER, OPTIONAL, INTENT(IN) :: nTitle !--- Number of rows for titles |
---|
| 1288 | INTEGER, OPTIONAL, INTENT(IN) :: nRowMax !--- Maximum number of rows |
---|
| 1289 | INTEGER, OPTIONAL, INTENT(IN) :: nColMax !--- Maximum number of characters each line |
---|
| 1290 | CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sub !--- Subroutine name |
---|
| 1291 | CHARACTER(LEN=maxlen), ALLOCATABLE :: d1(:,:) !--- Array of horizontally gathered sections |
---|
| 1292 | INTEGER :: nr0, nc0, nr1, nc1 !--- Row and columns numbers for original and gathered array |
---|
| 1293 | INTEGER :: ih, nh, nv !--- Index and number of stacked sections |
---|
| 1294 | INTEGER :: nttl, nrMx, ncMx !--- Titles number and effective max. row and columns numbers |
---|
| 1295 | INTEGER :: nrem, nr, ir0, icb, ice |
---|
| 1296 | nr0 = SIZE(d0, DIM=1) |
---|
| 1297 | nc0 = SIZE(d0, DIM=2) |
---|
| 1298 | nttl = 0; IF(PRESENT(nTitle)) nttl = nTitle |
---|
| 1299 | ncMx = 256; IF(PRESENT(nColMax)) ncMx = MIN(nCmx, nColMax) |
---|
| 1300 | nrMx = nr0; IF(PRESENT(nRowMax)) nrMx = MIN(nrMx, nRowMax) |
---|
| 1301 | nh = MAX(1, ncMx/SUM(n+1)) !--- Max. horiz. stackabled sections for ncMx (+1: last separator) |
---|
| 1302 | nv = 1+(nr0-nttl-1)/nh !--- Corresponding number ofvertical elements per section |
---|
| 1303 | nh = 1+(nr0-nttl-1)/nv !--- Effective number of sections |
---|
| 1304 | nr1 = MIN(nrMx,1+ nttl+(nr0-nttl-1)/nh); nc1 = nc0*nh !--- Shape of the stacked array |
---|
| 1305 | ALLOCATE(d1(nr1,nc1)) |
---|
| 1306 | nrem = nr0 !--- Remaining values to fill in |
---|
| 1307 | DO ih = 1, nh |
---|
| 1308 | nr = MAX(0,MIN(nr1,nrem)-nttl); nrem=nrem-nr !--- Number of copied rows in ith section (excluding titles) |
---|
| 1309 | ir0 = nttl+(ih-1)*(nr1-nttl) !--- Row start index in d1 |
---|
| 1310 | ice = ih*nc0; icb = ice-nc0+1 !--- Column end and start indices in d1 |
---|
| 1311 | d1(1:nttl, icb:ice) = d0(1:nttl, :) !--- Copy titles line(s) |
---|
| 1312 | d1(1+nttl:nr+nttl,icb:ice) = d0(1+ir0:nr+ir0,:) !--- Copy ith section |
---|
| 1313 | IF(nr1 == nr + nttl) CYCLE |
---|
| 1314 | d1(1+nr+nttl:nr1, icb:ice) =' ' !--- Fill missing cells with a space |
---|
| 1315 | END DO |
---|
| 1316 | END FUNCTION gatherTable |
---|
| 1317 | !============================================================================================================================== |
---|
| 1318 | |
---|
| 1319 | |
---|
| 1320 | !============================================================================================================================== |
---|
| 1321 | !--- Convert a set of columns of different natures ("s"trings, "i"ntegers, "r"eals) into a strings table. Default value |
---|
| 1322 | !=== * p: profile giving the order to pick up columns from "s", "i" and "r" to construct "c(:,:)". mandatory |
---|
| 1323 | !=== * t: titles, one per variable (2nd index), possibly on several lines (1st index). mandatory |
---|
| 1324 | !=== * c: assembled array mandatory |
---|
| 1325 | !=== * s: horizontally stacked string column vectors of values / |
---|
| 1326 | !=== * i: horizontally stacked integer column vectors of values / |
---|
| 1327 | !=== * r: horizontally stacked real column vectors of values / |
---|
| 1328 | !=== * rFmt: format for real conversion * |
---|
| 1329 | !=== * sub: calling subroutine name (for error messages) / |
---|
| 1330 | !=== NOTE: The vectors s, i and r do not have necessarly the same length. Empty elements are filled at the end. |
---|
| 1331 | !============================================================================================================================== |
---|
| 1332 | LOGICAL FUNCTION convertTable(p, t, c, s, i, r, rFmt, sub) RESULT(lerr) |
---|
| 1333 | IMPLICIT NONE |
---|
| 1334 | CHARACTER(LEN=*), INTENT(IN) :: p !--- DISPLAY MAP: s/i/r |
---|
| 1335 | CHARACTER(LEN=*), INTENT(IN) :: t(:,:) !--- TITLES (ONE EACH COLUMN) |
---|
| 1336 | CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: c(:,:) !--- CONVERTED STRINGS TABLE |
---|
| 1337 | CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: s(:,:) !--- STRINGS |
---|
| 1338 | INTEGER, OPTIONAL, INTENT(IN) :: i(:,:) !--- INTEGERS |
---|
| 1339 | REAL, OPTIONAL, INTENT(IN) :: r(:,:) !--- REALS |
---|
| 1340 | CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: rFmt !--- Format for reals |
---|
| 1341 | CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sub !--- Subroutine name |
---|
| 1342 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
[4046] | 1343 | CHARACTER(LEN=maxlen), ALLOCATABLE :: d(:,:) |
---|
[5751] | 1344 | CHARACTER(LEN=maxlen) :: rFm, subn |
---|
| 1345 | CHARACTER(LEN=1) :: sp = '|' !--- Table cells separator |
---|
| 1346 | INTEGER :: it, is, ii, ir, ic, nmx |
---|
| 1347 | INTEGER :: nt, ns, ni, nr, ncol |
---|
| 1348 | LOGICAL :: ls, li, lr, ll |
---|
| 1349 | rFm = '*'; IF(PRESENT(rFmt)) rFm = rFmt !--- Specified format for reals |
---|
[4120] | 1350 | subn = ''; IF(PRESENT(sub)) subn = sub |
---|
[4046] | 1351 | ls = PRESENT(s); li = PRESENT(i); lr = PRESENT(r) |
---|
[5751] | 1352 | ns = 0; ni = 0; nr = 0; ncol = 0 |
---|
| 1353 | ncol = LEN_TRIM(p) !--- Number of columns of the table |
---|
| 1354 | nt = SIZE(t,1) |
---|
[4046] | 1355 | |
---|
| 1356 | !--- CHECK ARGUMENTS COHERENCE |
---|
[5751] | 1357 | lerr = .NOT.ANY([ls,li,lr]) |
---|
| 1358 | CALL msg('missing argument(s) "s", "i" and/or "r"', subn, lerr) |
---|
| 1359 | IF(lerr) RETURN |
---|
| 1360 | lerr = ncol /= SIZE(t,2) |
---|
| 1361 | CALL msg('display map "p" length and titles number mismatch', subn, lerr) |
---|
| 1362 | IF(lerr) RETURN |
---|
| 1363 | IF(ls) THEN; ns = SIZE(s,1) |
---|
| 1364 | lerr = COUNT([(p(ic:ic)=='s', ic=1, ncol)]) /= SIZE(s,2) |
---|
| 1365 | CALL msg('display map "p" and string arguments mismatch: nb(p=="s")/=SIZE(s,2)', subn, lerr) |
---|
| 1366 | IF(lerr) RETURN |
---|
[4046] | 1367 | END IF |
---|
[5751] | 1368 | IF(li) THEN; ni = SIZE(i,1) |
---|
| 1369 | lerr = COUNT([(p(ic:ic)=='i', ic=1, ncol)]) /= SIZE(i,2) |
---|
| 1370 | CALL msg('display map "p" and integer arguments mismatch: nb(p=="i")/=SIZE(i,2)', subn, lerr) |
---|
| 1371 | IF(lerr) RETURN |
---|
[4046] | 1372 | END IF |
---|
[5751] | 1373 | IF(lr) THEN; nr = SIZE(r,1) |
---|
| 1374 | lerr = COUNT([(p(ic:ic)=='r', ic=1, ncol)]) /= SIZE(r,2) |
---|
| 1375 | CALL msg('display map "p" and real arguments mismatch: nb(p=="r")/=SIZE(r,2)', subn, lerr) |
---|
| 1376 | IF(lerr) RETURN |
---|
[4046] | 1377 | END IF |
---|
[5751] | 1378 | ! lerr = (ls.AND.li .AND. ns /= ni) .OR. (li.AND.lr .AND. ni /= nr) .OR. (lr.AND.ls .AND. nr /= ns) |
---|
| 1379 | ! CALL msg('mismatching rows numbers for at least "s", "i" or "r"', subn, lerr) |
---|
| 1380 | ! IF(lerr) RETURN |
---|
| 1381 | nmx = MAX(ns, ni, nr) + nt |
---|
[4046] | 1382 | |
---|
| 1383 | !--- Assemble the vectors into a strings array in the order indicated by "pattern" |
---|
[5751] | 1384 | ALLOCATE(c(nmx,ncol)) |
---|
[4046] | 1385 | is = 1; ii = 1; ir = 1 |
---|
| 1386 | DO ic = 1, ncol |
---|
[5751] | 1387 | c(1:nt,ic) = t(1:nt,ic) !--- Add titles line(s) |
---|
[4046] | 1388 | SELECT CASE(p(ic:ic)) |
---|
[5751] | 1389 | CASE('s'); c(1+nt:nmx,ic) = s(:,is) ; is = is + 1 !--- Add string elements |
---|
| 1390 | CASE('i'); c(1+nt:nmx,ic) = num2str(i(:,ii) ); ii = ii + 1 !--- Add integer elements |
---|
| 1391 | CASE('r'); c(1+nt:nmx,ic) = num2str(r(:,ir),rFm); ir = ir + 1 !--- Add real elements |
---|
[4046] | 1392 | END SELECT |
---|
[4193] | 1393 | END DO |
---|
[5751] | 1394 | CALL cleanZeros(c) !--- Remove useless zeros in converted numbers |
---|
[4046] | 1395 | |
---|
[5751] | 1396 | END FUNCTION convertTable |
---|
| 1397 | !============================================================================================================================== |
---|
| 1398 | |
---|
| 1399 | |
---|
| 1400 | !============================================================================================================================== |
---|
| 1401 | !--- Build a table from the string array "d(:,:)" as a vector of assembled lines (to be printed as messages). |
---|
| 1402 | !=== * each column has the minimum width "n(j)" needed to display the elements "d(:,j)" with at least "nm" spaces each side. |
---|
| 1403 | !=== * the structure of a cell is: <n1 spaces><TRIM(d(i,j))><n2 spaces>| (pay attention to the end separator "|") |
---|
| 1404 | !=== * n1 and n2 depend on the justification (three methods available) and give a total width of "n(j)", as expected. |
---|
| 1405 | !=== * each cell ends with the separator "|", except the last one |
---|
| 1406 | !=== * nTitle/=0 means that the first "nTitle" lines will be separated from the rest of the table with an underline. |
---|
| 1407 | !============================================================================================================================== |
---|
| 1408 | FUNCTION buildTable(d, nm, nTitle) RESULT(m) |
---|
| 1409 | IMPLICIT NONE |
---|
| 1410 | CHARACTER(LEN=*), INTENT(IN) :: d(:,:) !--- Input array |
---|
| 1411 | INTEGER, INTENT(IN) :: nm !--- Number of spaces before and after values |
---|
| 1412 | INTEGER, OPTIONAL, INTENT(IN) :: nTitle !--- Number of rows for titles |
---|
| 1413 | CHARACTER(LEN=10*maxlen), ALLOCATABLE :: m(:) !--- Lines to issue as messages to display the table |
---|
| 1414 | CHARACTER(LEN=1) :: sp = '|' !--- Separator |
---|
| 1415 | INTEGER :: ir, ic, nr, nc, i, j, n(SIZE(d,2)), nttl, id, p |
---|
| 1416 | nr = SIZE(d, DIM=1); nc = SIZE(d, DIM=2) !--- Dimensions of the table |
---|
| 1417 | nttl = 0; IF(PRESENT(nTitle)) nttl = nTitle |
---|
| 1418 | n = [(MAXVAL([(LEN_TRIM(d(i,j)), i=1, nr)], DIM=1), j=1, nc)] + 2*nm |
---|
| 1419 | ALLOCATE(m(nr+1)) !--- Allocate the vector (+1 for header line) |
---|
| 1420 | i = 1 |
---|
| 1421 | DO ir = 1, nr |
---|
| 1422 | IF(ir <= nttl) CALL centerJustified(d(ir,:), n, i, m(i)) |
---|
| 1423 | IF(ir == nttl) CALL headerLine( n, i, m(i)) |
---|
| 1424 | IF(ir > nttl) CALL leftJustified(d(ir,:), n, i, m(i)) |
---|
[4046] | 1425 | END DO |
---|
| 1426 | |
---|
[5751] | 1427 | CONTAINS |
---|
| 1428 | |
---|
| 1429 | SUBROUTINE leftJustified(d, n, i, r) |
---|
| 1430 | CHARACTER(LEN=*), INTENT(IN) :: d(:) |
---|
| 1431 | INTEGER, INTENT(IN) :: n(:) |
---|
| 1432 | CHARACTER(LEN=*), INTENT(INOUT) :: r |
---|
| 1433 | INTEGER, INTENT(INOUT) :: i |
---|
| 1434 | r = '' |
---|
| 1435 | DO id = 1, nc; r = TRIM(r)//REPEAT(' ',nm)//TRIM(d(id))//REPEAT(' ',n(id)-LEN_TRIM(d(id))-nm)//sp; END DO |
---|
| 1436 | r = r(1:LEN_TRIM(r)-1); i = i+1 !--- Final separator removed |
---|
| 1437 | END SUBROUTINE leftJustified |
---|
| 1438 | |
---|
| 1439 | SUBROUTINE centerJustified(d, n, i, r) |
---|
| 1440 | CHARACTER(LEN=*), INTENT(IN) :: d(:) |
---|
| 1441 | INTEGER, INTENT(IN) :: n(:) |
---|
| 1442 | INTEGER, INTENT(INOUT) :: i |
---|
| 1443 | CHARACTER(LEN=*), INTENT(INOUT) :: r |
---|
| 1444 | INTEGER :: p |
---|
| 1445 | r = ''; DO id = 1, nc; p=n(id)-LEN_TRIM(d(id)); r = TRIM(r)//REPEAT(' ', p - p/2)//TRIM(d(id))//REPEAT(' ', p/2)//sp; END DO |
---|
| 1446 | r = r(1:LEN_TRIM(r)-1); i = i+1 !--- Final separator removed |
---|
| 1447 | END SUBROUTINE centerJustified |
---|
| 1448 | |
---|
| 1449 | SUBROUTINE rightJustified(d, n, i, r) |
---|
| 1450 | CHARACTER(LEN=*), INTENT(IN) :: d(:) |
---|
| 1451 | INTEGER, INTENT(IN) :: n(:) |
---|
| 1452 | INTEGER, INTENT(INOUT) :: i |
---|
| 1453 | CHARACTER(LEN=*), INTENT(INOUT) :: r |
---|
| 1454 | r = ''; DO id = 1, nc; r = TRIM(r)//REPEAT(' ',n(id)-LEN_TRIM(d(id))-nm)//TRIM(d(id))//REPEAT(' ',nm)//sp; END DO |
---|
| 1455 | r = r(1:LEN_TRIM(r)-1); i = i+1 !--- Final separator removed |
---|
| 1456 | END SUBROUTINE rightJustified |
---|
| 1457 | |
---|
| 1458 | SUBROUTINE headerLine(n, i, r) |
---|
| 1459 | INTEGER, INTENT(IN) :: n(:) |
---|
| 1460 | INTEGER, INTENT(INOUT) :: i |
---|
| 1461 | CHARACTER(LEN=*), INTENT(INOUT) :: r |
---|
| 1462 | r = ''; DO id= 1 , nc; r = TRIM(r)//REPEAT('-',n(id))//'+'; END DO |
---|
| 1463 | r = r(1:LEN_TRIM(r)-1); i = i+1 !--- Final '+' removed |
---|
| 1464 | END SUBROUTINE headerLine |
---|
| 1465 | |
---|
| 1466 | END FUNCTION buildTable |
---|
[4046] | 1467 | !============================================================================================================================== |
---|
| 1468 | |
---|
[5751] | 1469 | |
---|
[4046] | 1470 | !============================================================================================================================== |
---|
[5745] | 1471 | LOGICAL FUNCTION dispNamelist(unt, p, titles, s, i, r, rFmt, llast) RESULT(lerr) |
---|
[5001] | 1472 | IMPLICIT NONE |
---|
[4046] | 1473 | INTEGER, INTENT(IN) :: unt !--- Output unit |
---|
| 1474 | CHARACTER(LEN=*), INTENT(IN) :: p !--- DISPLAY MAP: s/i/r |
---|
| 1475 | CHARACTER(LEN=*), INTENT(IN) :: titles(:) !--- TITLES (ONE EACH COLUMN) |
---|
| 1476 | CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: s(:,:) !--- STRINGS |
---|
| 1477 | INTEGER, OPTIONAL, INTENT(IN) :: i(:,:) !--- INTEGERS |
---|
| 1478 | REAL, OPTIONAL, INTENT(IN) :: r(:,:) !--- REALS |
---|
| 1479 | CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: rFmt !--- Format for reals |
---|
| 1480 | LOGICAL, OPTIONAL, INTENT(IN) :: llast !--- Last variable: no final ',' |
---|
[4349] | 1481 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
[4046] | 1482 | CHARACTER(LEN=maxlen) :: rFm, el |
---|
| 1483 | CHARACTER(LEN=maxlen), ALLOCATABLE :: d(:,:) |
---|
| 1484 | CHARACTER(LEN=:), ALLOCATABLE :: sp, row |
---|
| 1485 | INTEGER :: is, ii, ir, nrow, ic |
---|
| 1486 | INTEGER :: ns, ni, nr, ncol, np |
---|
| 1487 | INTEGER, ALLOCATABLE :: n(:) |
---|
| 1488 | LOGICAL :: ls, li, lr, la |
---|
| 1489 | rFm = '*'; IF(PRESENT(rFmt)) rFm = rFmt !--- Specified format for reals |
---|
| 1490 | ls = PRESENT(s); li = PRESENT(i); lr = PRESENT(r) |
---|
| 1491 | lerr = .FALSE.; IF(.NOT.ANY([ls,li,lr])) RETURN !--- Nothing to do |
---|
| 1492 | la = .FALSE.; IF(PRESENT(llast)) la = llast |
---|
| 1493 | |
---|
| 1494 | !--- CHECK ARGUMENTS COHERENCE |
---|
| 1495 | ns = 0; ni = 0; nr = 0; np = LEN_TRIM(p); ncol = 0 |
---|
| 1496 | IF(ls) THEN; ns = SIZE(s, DIM=1); ncol = ncol + SIZE(s, DIM=2) |
---|
| 1497 | lerr = COUNT([(p(ic:ic)=='s', ic=1, np)]) /= SIZE(s, DIM=2) |
---|
| 1498 | END IF |
---|
| 1499 | IF(li) THEN; ni = SIZE(i, DIM=1); ncol = ncol + SIZE(i, DIM=2) |
---|
| 1500 | lerr = COUNT([(p(ic:ic)=='i', ic=1, np)]) /= SIZE(i, DIM=2) |
---|
| 1501 | END IF |
---|
| 1502 | IF(lr) THEN; nr = SIZE(r, DIM=1); ncol = ncol + SIZE(r, DIM=2) |
---|
| 1503 | lerr = COUNT([(p(ic:ic)=='r', ic=1, np)]) /= SIZE(r, DIM=2) |
---|
| 1504 | END IF |
---|
[5746] | 1505 | CALL msg('display map "p" length and arguments number mismatch', ll=lerr); IF(lerr) RETURN |
---|
| 1506 | lerr = ncol /= SIZE(titles); CALL msg('"titles" length and arguments number mismatch', ll=lerr); IF(lerr) RETURN |
---|
| 1507 | lerr = ls.AND.li.AND.ns/=ni; CALL msg('string and integer arguments lengths mismatch', ll=lerr); IF(lerr) RETURN |
---|
| 1508 | lerr = ls.AND.lr.AND.ns/=nr; CALL msg( 'string and real arguments lengths mismatch', ll=lerr); IF(lerr) RETURN |
---|
| 1509 | lerr = li.AND.lr.AND.ni/=nr; CALL msg( 'integer and real arguments lengths mismatch', ll=lerr); IF(lerr) RETURN |
---|
[4046] | 1510 | |
---|
| 1511 | !--- Allocate the assembled quantities array |
---|
| 1512 | nrow = MAX(ns,ni,nr)+1 |
---|
| 1513 | ALLOCATE(d(nrow,ncol), n(ncol)) |
---|
| 1514 | |
---|
| 1515 | !--- Assemble the vectors into a strings array in the order indicated by "pattern" |
---|
| 1516 | is = 1; ii = 1; ir = 1 |
---|
| 1517 | DO ic = 1, ncol |
---|
| 1518 | d(1,ic) = TRIM(titles(ic)) |
---|
| 1519 | SELECT CASE(p(ic:ic)) |
---|
[5748] | 1520 | CASE('s'); d(2:nrow,ic) = s(:,is) ; is = is + 1 |
---|
| 1521 | CASE('i'); d(2:nrow,ic) = num2str(i(:,ii) ); ii = ii + 1 |
---|
| 1522 | CASE('r'); d(2:nrow,ic) = num2str(r(:,ir),rFm); ir = ir + 1 |
---|
[4046] | 1523 | END SELECT |
---|
[4193] | 1524 | END DO |
---|
| 1525 | CALL cleanZeros(d) |
---|
| 1526 | DO ic = 1, ncol |
---|
[4046] | 1527 | n(ic) = 0; DO ir=1, nrow; n(ic)=MAX(n(ic), LEN_TRIM(d(ir,ic))); END DO |
---|
| 1528 | IF(needQuotes(d(2,ic)) .AND. ic/=1) n(ic) = n(ic) + 2 !--- For quotes, using second line only |
---|
| 1529 | END DO |
---|
| 1530 | |
---|
| 1531 | !--- Display the strings array as a table |
---|
| 1532 | DO ir = 1, nrow |
---|
| 1533 | row = ''; sp = ' '; IF(TRIM(d(ir,1)) /= '') sp = ' = ' |
---|
| 1534 | DO ic = 1, ncol |
---|
| 1535 | el = d(ir,ic); IF(ic /= 1) el = addQuotes_1(el) |
---|
| 1536 | row = row//TRIM(el)//REPEAT(' ',n(ic)-LEN_TRIM(el))//sp |
---|
| 1537 | sp = ' '; IF(ic /= ncol-1) CYCLE |
---|
| 1538 | IF(TRIM(d(MIN(ir+1,nrow),1)) /= '' .AND. (ir /= nrow .OR. .NOT.la)) sp = ' , ' |
---|
| 1539 | END DO |
---|
| 1540 | WRITE(unt,'(a)')TRIM(row) |
---|
| 1541 | END DO |
---|
| 1542 | |
---|
| 1543 | !--- End of section |
---|
| 1544 | IF(la) THEN |
---|
| 1545 | WRITE(unt,'(a)')'/' |
---|
| 1546 | WRITE(unt,'(a)') |
---|
| 1547 | END IF |
---|
| 1548 | |
---|
| 1549 | END FUNCTION dispNameList |
---|
| 1550 | !============================================================================================================================== |
---|
| 1551 | |
---|
| 1552 | |
---|
| 1553 | !============================================================================================================================== |
---|
[5753] | 1554 | !=== DISPLAY OUTLIERS IN TABLES =============================================================================================== |
---|
| 1555 | !============================================================================================================================== |
---|
| 1556 | !=== lerr = dispOutliers_1(ll(:), a(:[:]), n(:), err_msg, nam(:), sub, nRowmax, nColMax, unit) |
---|
| 1557 | !=== * ll linearized mask of outliers |
---|
| 1558 | !=== * a linearized fields: |
---|
| 1559 | !=== a(:) all the fields are linearized (all contane |
---|
| 1560 | !=== Behaviour depends on ll(:), n(:) and nam(:). We note hereafter nv = SIZE(nam). |
---|
| 1561 | !=== |
---|
| 1562 | !=== 1) if SIZE(ll) == PRODUCT(n) and nv==1 or "nam" is unspecified: outliers of a single variable are displayed |
---|
| 1563 | !=== i[,j[,k]] | nam | |
---|
| 1564 | !=== ----------+-----------------+ |
---|
| 1565 | !=== *[,*[,*]] | val(i[,j[,k]]) | |
---|
| 1566 | !=== ... | ... | |
---|
| 1567 | !=== |
---|
| 1568 | !=== |
---|
| 1569 | !=== 2) if SIZE(ll) == PRODUCT(n) and nv>1: "nv" tables of outliers are displayed, each having its own mask |
---|
| 1570 | !=== i[,j] | var(1) |
---|
| 1571 | !=== ------+-------------- |
---|
| 1572 | !=== *[,*] | val(i[,j],1) |
---|
| 1573 | !=== ... | ... |
---|
| 1574 | !=== |
---|
| 1575 | !=== ... |
---|
| 1576 | !=== |
---|
| 1577 | !=== i[,j] | var(nv) |
---|
| 1578 | !=== ------+--------------- |
---|
| 1579 | !=== *[,*] | val(i[,j],nv) |
---|
| 1580 | !=== ... | ... |
---|
| 1581 | !=== |
---|
| 1582 | !=== |
---|
| 1583 | !=== 3) if SIZE(ll) = PRODUCT(n(1:SIZE(n)-1): outliers of "nv" variables are displayed, all with mask "ll(:)" |
---|
| 1584 | !=== i[,j] | var(1) | var(2) | ... | var(nv) |
---|
| 1585 | !=== ------+--------------+---------------+-- ... --+--------------- |
---|
| 1586 | !=== *[,*] | val(i[,j],1) | val(i[,j],2) | ... | val(i[,j],nv) |
---|
| 1587 | !=== ... | ... | ... | ... | ... |
---|
| 1588 | !=== |
---|
| 1589 | !=== NOTES: |
---|
| 1590 | !=== * in cases 2 and 3, SIZE(nam) MUST be equal to n(SIZE(n)). |
---|
| 1591 | !=== * for the sake of readability, narrow tables (compared to the max. width "nColMax") are horizontally stacked. |
---|
| 1592 | !=== Here is the result in the case 1: |
---|
| 1593 | !=== i[,j[,k]] | nam | i[,j[,k]] | nam | ... | i[,j[,k]] | nam |
---|
| 1594 | !=== ----------+-----------------+-----------+-----------------+-- ... --+-----------+----------------- |
---|
| 1595 | !=== *[,*[,*]] | val(i[,j[,k]]) | *[,*[,*]] | val(i[,j[,k]]) | ... | *[,*[,*]] | val(i[,j[,k]]) |
---|
| 1596 | !=== ... | ... | ... | ... | ... | ... | ... |
---|
| 1597 | !=== * conversly, in case 3, too wide tables are displayed as several sub-tables. |
---|
| 1598 | !=== * too long tables are truncated to nRowMax lines (excluding titles lines). |
---|
| 1599 | !============================================================================================================================== |
---|
| 1600 | LOGICAL FUNCTION dispOutliers_1(ll, a, n, err_msg, nam, sub, nRowmax, nColMax, unit) RESULT(lerr) |
---|
| 1601 | IMPLICIT NONE |
---|
| 1602 | ! Display outliers list in tables |
---|
| 1603 | ! If "nam" is supplied, it means the last index is for tracers => one table each tracer for rank > 2. |
---|
| 1604 | LOGICAL, INTENT(IN) :: ll(:) !--- Linearized mask of outliers |
---|
| 1605 | REAL, INTENT(IN) :: a(:) !--- Linearized array of values |
---|
| 1606 | INTEGER, INTENT(IN) :: n(:) !--- Profile before linearization |
---|
| 1607 | CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: err_msg, nam(:), sub !--- Error message, variables and calling subroutine names |
---|
| 1608 | INTEGER, OPTIONAL, INTENT(IN) :: nRowMax !--- Maximum number of lines to display (default: all) |
---|
| 1609 | INTEGER, OPTIONAL, INTENT(IN) :: nColMax !--- Maximum number of characters per line (default: 2048) |
---|
| 1610 | INTEGER, OPTIONAL, INTENT(IN) :: unit !--- Output unit (def: lunout) |
---|
| 1611 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
| 1612 | CHARACTER(LEN=maxlen), ALLOCATABLE :: t(:), vnm(:), c(:,:) |
---|
| 1613 | LOGICAL, ALLOCATABLE :: m(:), ld(:) |
---|
| 1614 | INTEGER, ALLOCATABLE :: ki(:), kj(:) |
---|
| 1615 | INTEGER :: rk, ib, ie, itr, nm, unt, nRmx, nCmx, iv, nv, np |
---|
| 1616 | CHARACTER(LEN=maxlen) :: mes, subn, fm='(f12.9)', p |
---|
| 1617 | lerr = .FALSE. |
---|
| 1618 | |
---|
| 1619 | IF(.NOT.ANY(ll)) RETURN !--- No outliers -> finished |
---|
| 1620 | |
---|
| 1621 | mes = 'outliers found'; IF(PRESENT(err_msg)) mes = err_msg !--- Error message |
---|
| 1622 | vnm = ['a']; IF(PRESENT(nam)) vnm = nam !--- Variables names |
---|
| 1623 | subn= 'dispOutliers'; IF(PRESENT(sub)) subn= sub !--- Calling subroutine name |
---|
| 1624 | nRmx= SIZE(a); IF(PRESENT(nRowMax)) nRmx=MIN(nRmx,nRowMax)!--- Maximum number of lines to print |
---|
| 1625 | nCmx= 2048; IF(PRESENT(nColMax)) nCmx=MIN(nCmx,nColMax)!--- Maximum number of characters each line |
---|
| 1626 | unt = lunout; IF(PRESENT(unit)) unt = unit !--- Unit to print messages |
---|
| 1627 | |
---|
| 1628 | rk = SIZE(n) !--- Rank of "a" before linearization |
---|
| 1629 | nv = SIZE(vnm) !--- Number of variables |
---|
| 1630 | np = PRODUCT(n(1:rk-1)) !--- Number of points per var (in the multiple vars case) |
---|
| 1631 | lerr = rk>3; CALL msg('can display field with rank <=3 only !', subn, lerr, unt); IF(lerr) RETURN |
---|
| 1632 | lerr = n(rk) == 1; CALL msg('degenerated last dim: n(SIZE(n)) = 1 !', subn, lerr, unt); IF(lerr) RETURN |
---|
| 1633 | lerr = nv/=1 .AND. nv/=n(rk); CALL msg('SIZE(nam) /= 1 and /= last "n" element', subn, lerr, unt); IF(lerr) RETURN |
---|
| 1634 | lerr = SIZE(a) /= PRODUCT(n); CALL msg('profile "n" does not match "a" and "ll', subn, lerr, unt); IF(lerr) RETURN |
---|
| 1635 | lerr = ALL([PRODUCT(n),np] /= SIZE(ll)) |
---|
| 1636 | CALL msg('ll" length must be either PROD(n) or PROD(n(1:rk-1))', subn, lerr, unt); IF(lerr) RETURN |
---|
| 1637 | |
---|
| 1638 | !============================================================================================================================ |
---|
| 1639 | IF(SIZE(ll) == PRODUCT(n)) THEN !=== ll(:) IS A MASK FOR THE WHOLE a(:) VECTOR =========== |
---|
| 1640 | !============================================================================================================================ |
---|
| 1641 | p = 's'//REPEAT('r',nv) !--- Display map: one string, "nv" reals |
---|
| 1642 | IF(nv == 1) THEN !=== SINGLE VARIABLE |
---|
| 1643 | CALL buildTitle(n, vnm, t) !--- Build titles list "t" for a single variable |
---|
| 1644 | CALL buildCoord(n, ll, c) !--- Masked ("ll") coordinates vector "c" |
---|
| 1645 | lerr = dispTable(p, t, s=c, r=cat(PACK(a,ll)), rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=1, unit=unt, sub=subn) |
---|
| 1646 | ELSE !=== MULTIPLE VARIABLES |
---|
| 1647 | DO iv = 1, nv |
---|
| 1648 | CALL buildTitle(n, vnm(iv:iv), t) !--- Titles list "t" for the "iv"th variables |
---|
| 1649 | CALL buildCoord(n(1:rk-1), ll, c) !--- Masked ("ll") coordinates vector "c" |
---|
| 1650 | ib = 1+(iv-1)*np; ie = ib+np |
---|
| 1651 | lerr = dispTable(p, t, s=c, r=cat(PACK(a(ib:ie),ll(ib:ie))), rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=1, & |
---|
| 1652 | unit=unt, sub=subn) |
---|
| 1653 | CALL msg("can't display outliers table", subn, lerr, unt); IF(lerr) RETURN |
---|
| 1654 | END DO |
---|
| 1655 | END IF |
---|
| 1656 | !============================================================================================================================ |
---|
| 1657 | ELSE !=== ll(:) IS A MASK FOR EACH TRACER STACKED IN a(:) VECTOR |
---|
| 1658 | !============================================================================================================================ |
---|
| 1659 | CALL buildTitle(n, vnm, t) !--- Build titles list "t" for all the variable |
---|
| 1660 | CALL duplicate(ll, nv, ld) !--- "ll" concatenated "nv" times |
---|
| 1661 | CALL buildCoord(n(1:rk-1), ll, c) !--- Masked ("ll") coordinates vector "c" |
---|
| 1662 | lerr = dispTable(p, t, s=c, r=RESHAPE(PACK(a,ld),[np,nv]), rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=1,unit=unt,sub=subn) |
---|
| 1663 | !============================================================================================================================ |
---|
| 1664 | END IF |
---|
| 1665 | !============================================================================================================================ |
---|
| 1666 | CALL msg("can't display outliers table", subn, lerr, unt) |
---|
| 1667 | |
---|
| 1668 | CONTAINS |
---|
| 1669 | |
---|
| 1670 | SUBROUTINE buildTitle(n, vname, title) !=== BUILD TITLES: [COORD. NAME, THE VARIABLE(S) NAME(S)] |
---|
| 1671 | INTEGER, INTENT(IN) :: n(:) |
---|
| 1672 | CHARACTER(LEN=maxlen), INTENT(IN) :: vname(:) |
---|
| 1673 | CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: title(:) |
---|
| 1674 | INTEGER :: rk |
---|
| 1675 | rk = SIZE(n) |
---|
| 1676 | ALLOCATE(title(1+SIZE(vname))) |
---|
| 1677 | title(2:SIZE(vname)+1) = vname |
---|
| 1678 | title(1) = 'i' |
---|
| 1679 | IF(rk >= 2) title(1) = TRIM(title(1))//', j' |
---|
| 1680 | IF(rk >= 3) title(1) = TRIM(title(1))//', k' |
---|
| 1681 | END SUBROUTINE buildTitle |
---|
| 1682 | |
---|
| 1683 | SUBROUTINE buildCoord(n, mask, coord) !=== BUILD MASKED COORDINATES OK FOR "s" ARG OF dispTable |
---|
| 1684 | INTEGER, INTENT(IN) :: n(:) |
---|
| 1685 | LOGICAL, INTENT(IN) :: mask(:) |
---|
| 1686 | CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: coord(:,:) |
---|
| 1687 | CHARACTER(LEN=maxlen) :: sj, sk |
---|
| 1688 | INTEGER :: i, j, k, m(3), rk, ic |
---|
| 1689 | rk = SIZE(n) |
---|
| 1690 | m(:) = 1; m(1:rk) = n(:) |
---|
| 1691 | ALLOCATE(coord(1,COUNT(mask))) |
---|
| 1692 | ic = 0 |
---|
| 1693 | DO k = 1, m(3); sk = ', '//num2str(k) |
---|
| 1694 | DO j = 1, m(2); sj = ', '//num2str(j) |
---|
| 1695 | DO i = 1, m(1) |
---|
| 1696 | IF(.NOT.mask(i+m(1)*(j+m(2)*k))) CYCLE |
---|
| 1697 | ic = ic+1 |
---|
| 1698 | coord(ic,1) = num2str(i) |
---|
| 1699 | IF(rk >= 2) coord(ic,1) = TRIM(coord(ic,1))//TRIM(sj) |
---|
| 1700 | IF(rk >= 3) coord(ic,1) = TRIM(coord(ic,1))//TRIM(sk) |
---|
| 1701 | END DO |
---|
| 1702 | END DO |
---|
| 1703 | END DO |
---|
| 1704 | END SUBROUTINE buildCoord |
---|
| 1705 | |
---|
| 1706 | END FUNCTION dispOutliers_1 |
---|
| 1707 | !============================================================================================================================== |
---|
| 1708 | LOGICAL FUNCTION dispOutliers_2(ll, a, n, err_msg, nam, sub, nRowmax, nColMax, unit) RESULT(lerr) |
---|
| 1709 | IMPLICIT NONE |
---|
| 1710 | ! Display outliers list in tables |
---|
| 1711 | ! If "nam" is supplied, it means the last index is for tracers => one table each tracer for rank > 2. |
---|
| 1712 | LOGICAL, INTENT(IN) :: ll(:) !--- Linearized mask of outliers |
---|
| 1713 | REAL, INTENT(IN) :: a(:,:) !--- Linearized array of values |
---|
| 1714 | INTEGER, INTENT(IN) :: n(:) !--- Profile before linearization |
---|
| 1715 | CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: err_msg, nam(:), sub !--- Error message, variables and calling subroutine names |
---|
| 1716 | INTEGER, OPTIONAL, INTENT(IN) :: nRowMax !--- Maximum number of lines to display (default: all) |
---|
| 1717 | INTEGER, OPTIONAL, INTENT(IN) :: nColMax !--- Maximum number of characters per line (default: 2048) |
---|
| 1718 | INTEGER, OPTIONAL, INTENT(IN) :: unit !--- Output unit (def: lunout) |
---|
| 1719 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
| 1720 | lerr = dispOutliers_1(ll, PACK(a, MASK=.TRUE.), n, err_msg, nam, sub, nRowmax, nColMax, unit) |
---|
| 1721 | END FUNCTION dispOutliers_2 |
---|
| 1722 | !============================================================================================================================== |
---|
| 1723 | |
---|
| 1724 | |
---|
| 1725 | !============================================================================================================================== |
---|
[4046] | 1726 | !=== Reduce an algebrical expression (basic operations and parenthesis) to a single number (string format) ==================== |
---|
| 1727 | !============================================================================================================================== |
---|
[5745] | 1728 | LOGICAL FUNCTION reduceExpr_1(str, val) RESULT(lerr) |
---|
[5001] | 1729 | IMPLICIT NONE |
---|
[4046] | 1730 | CHARACTER(LEN=*), INTENT(IN) :: str |
---|
| 1731 | CHARACTER(LEN=maxlen), INTENT(OUT) :: val |
---|
[4349] | 1732 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
[4046] | 1733 | CHARACTER(LEN=maxlen) :: v |
---|
| 1734 | CHARACTER(LEN=1024) :: s, vv |
---|
| 1735 | CHARACTER(LEN=1024), ALLOCATABLE :: vl(:) |
---|
| 1736 | INTEGER, ALLOCATABLE :: ip(:) |
---|
| 1737 | INTEGER :: nl, nn, i, j, im, ix |
---|
| 1738 | LOGICAL :: ll |
---|
| 1739 | s = str |
---|
| 1740 | |
---|
| 1741 | !--- Check wether the parenthesis are correctly formed |
---|
| 1742 | ll = strCount(s,'(',nl) |
---|
| 1743 | ll = strCount(s,')',nn) |
---|
| 1744 | lerr = nl /= nn |
---|
[5746] | 1745 | CALL msg('Mismatching number of opening and closing parenthesis: '//TRIM(s), ll=lerr); IF(lerr) RETURN |
---|
[4046] | 1746 | nl = 2*nl-1 |
---|
| 1747 | |
---|
| 1748 | !--- Build vectors ; vl: parenthesis-separated elements ; ip: parenthesis types (1: opening, 2: closing) |
---|
| 1749 | ALLOCATE(ip(nl-1),vl(nl)) |
---|
| 1750 | j = 1; im = 1 |
---|
| 1751 | DO i = 1, LEN_TRIM(str) |
---|
| 1752 | ix = INDEX('()', str(i:i)) |
---|
| 1753 | IF(ix == 0) CYCLE |
---|
| 1754 | ip(j) = ix |
---|
| 1755 | vl(j) = str(im:i-1) |
---|
| 1756 | j = j + 1; im = i + 1 |
---|
| 1757 | END DO |
---|
| 1758 | vl(j) = str(im:LEN_TRIM(str)) |
---|
| 1759 | |
---|
| 1760 | !--- Search for each opening/closing parenthesis pair |
---|
| 1761 | DO WHILE(nl > 1) |
---|
| 1762 | i = 1; DO WHILE(ip(i) /= 1 .OR. ip(i+1) /= 2); i = i + 1; END DO !IF(i > SIZE(ip)+1) EXIT;END DO |
---|
[5001] | 1763 | lerr = reduceExpr_basic(vl(i+1), v); IF(lerr) RETURN |
---|
[4046] | 1764 | v = TRIM(vl(i))//TRIM(v); IF(i+2<=nl) v=TRIM(v)//TRIM(vl(i+2)) |
---|
| 1765 | vv = v//REPEAT(' ',768) |
---|
| 1766 | IF(i == 1) THEN; ip = ip(3:nl-1); vl = [ vv, vl(4 :nl)] |
---|
| 1767 | ELSE IF(i == nl-1) THEN; ip = ip(1:nl-2); vl = [vl(1:nl-3), vv ] |
---|
| 1768 | ELSE; ip = [ip(1: i-1), ip(i+2:nl-1)]; vl = [vl(1: i-1), vv, vl(i+3:nl)]; END IF |
---|
| 1769 | nl = SIZE(vl) |
---|
| 1770 | END DO |
---|
| 1771 | lerr = reduceExpr_basic(vl(1), val) |
---|
| 1772 | END FUNCTION reduceExpr_1 |
---|
| 1773 | |
---|
| 1774 | |
---|
| 1775 | !============================================================================================================================== |
---|
| 1776 | !=== Reduce a simple algebrical expression (basic operations, no parenthesis) to a single number (string format) ============== |
---|
| 1777 | !============================================================================================================================== |
---|
[5745] | 1778 | LOGICAL FUNCTION reduceExpr_basic(str, val) RESULT(lerr) |
---|
[5001] | 1779 | IMPLICIT NONE |
---|
[4046] | 1780 | CHARACTER(LEN=*), INTENT(IN) :: str |
---|
| 1781 | CHARACTER(LEN=*), INTENT(OUT) :: val |
---|
[5748] | 1782 | REAL(KIND=REAL64), ALLOCATABLE :: vl(:) |
---|
[4046] | 1783 | INTEGER, ALLOCATABLE :: id(:) |
---|
| 1784 | CHARACTER(LEN=maxlen), ALLOCATABLE :: ky(:) |
---|
| 1785 | CHARACTER(LEN=1), ALLOCATABLE :: op(:) |
---|
[4349] | 1786 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
[4046] | 1787 | CHARACTER(LEN=1024) :: s |
---|
[5748] | 1788 | REAL(KIND=REAL64) :: v, vm, vp |
---|
[4046] | 1789 | INTEGER :: i, ni, io |
---|
| 1790 | lerr = .FALSE. |
---|
| 1791 | IF(is_numeric(str)) THEN; val=TRIM(str); RETURN; END IF |
---|
| 1792 | op = ['^','/','*','+','-'] !--- List of recognized operations |
---|
| 1793 | s = str |
---|
[5001] | 1794 | lerr = strParse_m(s, op, ky, lSc=.TRUE., id = id) !--- Parse the values |
---|
| 1795 | IF(lerr) RETURN !--- Problem with the parsing |
---|
[4046] | 1796 | vl = str2dble(ky) !--- Conversion to doubles |
---|
[5748] | 1797 | lerr = ANY(vl >= HUGE(1._REAL64)) |
---|
[5001] | 1798 | CALL msg('Some values are non-numeric in: '//TRIM(s), ll=lerr) |
---|
| 1799 | IF(lerr) RETURN !--- Non-numerical values found |
---|
[4046] | 1800 | DO io = 1, SIZE(op) !--- Loop on known operators (order matters !) |
---|
| 1801 | DO i = SIZE(id), 1, -1 !--- Loop on found operators |
---|
| 1802 | ni = SIZE(id) |
---|
| 1803 | IF(id(i) /= io) CYCLE !--- Current found operator is not op(io) |
---|
| 1804 | vm = vl(i); vp = vl(i+1) !--- Couple of values used for current operation |
---|
[5001] | 1805 | SELECT CASE(op(io)) !--- Perform operation on the two values |
---|
[4349] | 1806 | CASE('^'); v = vm**vp |
---|
| 1807 | CASE('/'); v = vm/vp |
---|
| 1808 | CASE('*'); v = vm*vp |
---|
| 1809 | CASE('+'); v = vm+vp |
---|
| 1810 | CASE('-'); v = vm-vp |
---|
[4046] | 1811 | END SELECT |
---|
| 1812 | IF(i == ni) THEN; vl = [vl(1:ni-1), v]; ELSE; vl = [vl(1:i-1), v, vl(i+2:ni+1)]; END IF |
---|
| 1813 | IF(i == ni) THEN; id = id(1:ni-1); ELSE; id = [id(1:i-1), id(i+1:ni )]; END IF |
---|
| 1814 | END DO |
---|
| 1815 | END DO |
---|
[5748] | 1816 | val = num2str(vl(1)) |
---|
[4046] | 1817 | |
---|
| 1818 | END FUNCTION reduceExpr_basic |
---|
| 1819 | !============================================================================================================================== |
---|
| 1820 | |
---|
| 1821 | !============================================================================================================================== |
---|
| 1822 | FUNCTION reduceExpr_m(str, val) RESULT(lerr) |
---|
[5001] | 1823 | IMPLICIT NONE |
---|
[4046] | 1824 | LOGICAL, ALLOCATABLE :: lerr(:) |
---|
| 1825 | CHARACTER(LEN=*), INTENT(IN) :: str(:) |
---|
| 1826 | CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: val(:) |
---|
[4349] | 1827 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
[4046] | 1828 | INTEGER :: i |
---|
| 1829 | ALLOCATE(lerr(SIZE(str)),val(SIZE(str))) |
---|
| 1830 | lerr(:) = [(reduceExpr_1(str(i), val(i)), i=1, SIZE(str))] |
---|
| 1831 | END FUNCTION reduceExpr_m |
---|
| 1832 | !============================================================================================================================== |
---|
| 1833 | |
---|
| 1834 | |
---|
| 1835 | !============================================================================================================================== |
---|
| 1836 | !=== Check whether a string is a number or not ================================================================================ |
---|
| 1837 | !============================================================================================================================== |
---|
[5745] | 1838 | ELEMENTAL LOGICAL FUNCTION is_numeric(str) RESULT(out) |
---|
[5001] | 1839 | IMPLICIT NONE |
---|
[4046] | 1840 | CHARACTER(LEN=*), INTENT(IN) :: str |
---|
| 1841 | REAL :: x |
---|
| 1842 | INTEGER :: e |
---|
| 1843 | CHARACTER(LEN=12) :: fmt |
---|
| 1844 | IF(TRIM(str) == '') THEN; out = .FALSE.; RETURN; END IF |
---|
| 1845 | WRITE(fmt,'("(f",i0,".0)")') LEN_TRIM(str) |
---|
| 1846 | READ(str,fmt,IOSTAT=e) x |
---|
| 1847 | out = e==0 .AND. INDEX('Ee',str(LEN_TRIM(str):LEN_TRIM(str)))==0 |
---|
| 1848 | END FUNCTION is_numeric |
---|
| 1849 | !============================================================================================================================== |
---|
| 1850 | |
---|
| 1851 | |
---|
| 1852 | !============================================================================================================================== |
---|
| 1853 | !=== Convert a string into a logical/integer integer or an integer/real into a string ========================================= |
---|
| 1854 | !============================================================================================================================== |
---|
[5745] | 1855 | ELEMENTAL INTEGER FUNCTION str2bool(str) RESULT(out) !--- Result: 0/1 for .FALSE./.TRUE., -1 if not a valid boolean |
---|
[4987] | 1856 | IMPLICIT NONE |
---|
[4046] | 1857 | CHARACTER(LEN=*), INTENT(IN) :: str |
---|
| 1858 | INTEGER :: ierr |
---|
[4987] | 1859 | LOGICAL :: lout |
---|
| 1860 | READ(str,*,IOSTAT=ierr) lout |
---|
| 1861 | out = -HUGE(1) |
---|
| 1862 | IF(ierr /= 0) THEN |
---|
| 1863 | IF(ANY(['.false.', 'false ', 'no ', 'f ', 'n '] == strLower(str))) out = 0 |
---|
| 1864 | IF(ANY(['.true. ', 'true ', 'yes ', 't ', 'y '] == strLower(str))) out = 1 |
---|
| 1865 | ELSE |
---|
| 1866 | out = 0; IF(lout) out = 1 |
---|
| 1867 | END IF |
---|
[4046] | 1868 | END FUNCTION str2bool |
---|
| 1869 | !============================================================================================================================== |
---|
[5745] | 1870 | ELEMENTAL INTEGER FUNCTION str2int(str) RESULT(out) |
---|
[5001] | 1871 | IMPLICIT NONE |
---|
[4046] | 1872 | CHARACTER(LEN=*), INTENT(IN) :: str |
---|
| 1873 | INTEGER :: ierr |
---|
| 1874 | READ(str,*,IOSTAT=ierr) out |
---|
| 1875 | IF(ierr/=0) out = -HUGE(1) |
---|
| 1876 | END FUNCTION str2int |
---|
| 1877 | !============================================================================================================================== |
---|
[5748] | 1878 | ELEMENTAL REAL(KIND=REAL32) FUNCTION str2real(str) RESULT(out) |
---|
[5001] | 1879 | IMPLICIT NONE |
---|
[4046] | 1880 | CHARACTER(LEN=*), INTENT(IN) :: str |
---|
| 1881 | INTEGER :: ierr |
---|
| 1882 | READ(str,*,IOSTAT=ierr) out |
---|
[5748] | 1883 | IF(ierr/=0) out = -HUGE(1._REAL32) |
---|
[4046] | 1884 | END FUNCTION str2real |
---|
| 1885 | !============================================================================================================================== |
---|
[5748] | 1886 | ELEMENTAL REAL(KIND=REAL64) FUNCTION str2dble(str) RESULT(out) |
---|
[5001] | 1887 | IMPLICIT NONE |
---|
[4046] | 1888 | CHARACTER(LEN=*), INTENT(IN) :: str |
---|
| 1889 | INTEGER :: ierr |
---|
| 1890 | READ(str,*,IOSTAT=ierr) out |
---|
[5748] | 1891 | IF(ierr/=0) out = -HUGE(1._REAL64) |
---|
[4046] | 1892 | END FUNCTION str2dble |
---|
| 1893 | !============================================================================================================================== |
---|
[5745] | 1894 | ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION bool2str(b) RESULT(out) |
---|
[5001] | 1895 | IMPLICIT NONE |
---|
[4046] | 1896 | LOGICAL, INTENT(IN) :: b |
---|
| 1897 | WRITE(out,*)b |
---|
| 1898 | out = ADJUSTL(out) |
---|
| 1899 | END FUNCTION bool2str |
---|
| 1900 | !============================================================================================================================== |
---|
[5745] | 1901 | ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION int2str(i, nDigits) RESULT(out) |
---|
[5001] | 1902 | IMPLICIT NONE |
---|
[4046] | 1903 | INTEGER, INTENT(IN) :: i |
---|
| 1904 | INTEGER, OPTIONAL, INTENT(IN) :: nDigits |
---|
[4349] | 1905 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
[4046] | 1906 | WRITE(out,*)i |
---|
| 1907 | out = ADJUSTL(out) |
---|
| 1908 | IF(.NOT.PRESENT(nDigits)) RETURN |
---|
| 1909 | IF(nDigits > LEN_TRIM(out)) out = REPEAT('0', nDigits - LEN_TRIM(out))//TRIM(out) |
---|
| 1910 | END FUNCTION int2str |
---|
| 1911 | !============================================================================================================================== |
---|
[5745] | 1912 | ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION real2str(r,fmt) RESULT(out) |
---|
[5001] | 1913 | IMPLICIT NONE |
---|
[5748] | 1914 | REAL(KIND=REAL32), INTENT(IN) :: r |
---|
[4046] | 1915 | CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: fmt |
---|
[4349] | 1916 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
[4046] | 1917 | IF( PRESENT(fmt)) WRITE(out,fmt)r |
---|
| 1918 | IF(.NOT.PRESENT(fmt)) WRITE(out, * )r |
---|
| 1919 | out = ADJUSTL(out) |
---|
| 1920 | END FUNCTION real2str |
---|
| 1921 | !============================================================================================================================== |
---|
[5745] | 1922 | ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION dble2str(d,fmt) RESULT(out) |
---|
[5001] | 1923 | IMPLICIT NONE |
---|
[5748] | 1924 | REAL(KIND=REAL64), INTENT(IN) :: d |
---|
[4046] | 1925 | CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: fmt |
---|
[4349] | 1926 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
[4046] | 1927 | IF( PRESENT(fmt)) WRITE(out,fmt)d |
---|
| 1928 | IF(.NOT.PRESENT(fmt)) WRITE(out, * )d |
---|
| 1929 | out = ADJUSTL(out) |
---|
| 1930 | END FUNCTION dble2str |
---|
| 1931 | !============================================================================================================================== |
---|
[4193] | 1932 | ELEMENTAL SUBROUTINE cleanZeros(s) |
---|
[5001] | 1933 | IMPLICIT NONE |
---|
[4193] | 1934 | CHARACTER(LEN=*), INTENT(INOUT) :: s |
---|
| 1935 | INTEGER :: ls, ix, i |
---|
| 1936 | IF(is_numeric(s)) THEN |
---|
| 1937 | ls = LEN_TRIM(s) |
---|
| 1938 | ix = MAX(INDEX(s,'E'),INDEX(s,'e'),INDEX(s,'D'),INDEX(s,'d')) |
---|
| 1939 | IF(ix == 0) THEN |
---|
| 1940 | DO ix = ls,1,-1; IF(s(ix:ix) /= '0') EXIT; END DO; s=s(1:ix+1) |
---|
| 1941 | ELSE IF(INDEX(s,'.')/=0) THEN |
---|
| 1942 | i = ix-1; DO WHILE(s(i:i) == '0'); i = i-1; END DO; s=s(1:i)//s(ix:ls) |
---|
| 1943 | END IF |
---|
| 1944 | END IF |
---|
| 1945 | END SUBROUTINE cleanZeros |
---|
| 1946 | !============================================================================================================================== |
---|
[4046] | 1947 | |
---|
[4349] | 1948 | |
---|
[4046] | 1949 | !============================================================================================================================== |
---|
| 1950 | FUNCTION addQuotes_1(s) RESULT(out) |
---|
[5001] | 1951 | IMPLICIT NONE |
---|
[4046] | 1952 | CHARACTER(LEN=*), INTENT(IN) :: s |
---|
| 1953 | CHARACTER(LEN=:), ALLOCATABLE :: out |
---|
| 1954 | IF(needQuotes(s)) THEN; out = "'"//TRIM(s)//"'"; ELSE; out = s; END IF |
---|
| 1955 | END FUNCTION addQuotes_1 |
---|
| 1956 | !============================================================================================================================== |
---|
| 1957 | FUNCTION addQuotes_m(s) RESULT(out) |
---|
[5001] | 1958 | IMPLICIT NONE |
---|
[4046] | 1959 | CHARACTER(LEN=*), INTENT(IN) :: s(:) |
---|
| 1960 | CHARACTER(LEN=:), ALLOCATABLE :: out(:) |
---|
[4349] | 1961 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
[4046] | 1962 | INTEGER :: k, n |
---|
| 1963 | n = MAXVAL(LEN_TRIM(s), MASK=.TRUE.) |
---|
| 1964 | ALLOCATE(CHARACTER(LEN=n) :: out(SIZE(s))) |
---|
| 1965 | DO k=1,SIZE(s) |
---|
| 1966 | IF(needQuotes(s(k))) THEN; out(k) = "'"//TRIM(s(k))//"'"; ELSE; out(k) = s(k); END IF |
---|
| 1967 | END DO |
---|
| 1968 | END FUNCTION addQuotes_m |
---|
| 1969 | !============================================================================================================================== |
---|
[5745] | 1970 | ELEMENTAL LOGICAL FUNCTION needQuotes(s) RESULT(out) |
---|
[5001] | 1971 | IMPLICIT NONE |
---|
[4046] | 1972 | CHARACTER(LEN=*), INTENT(IN) :: s |
---|
| 1973 | CHARACTER(LEN=1) :: b, e |
---|
[4349] | 1974 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
[4046] | 1975 | out = .TRUE.; IF(TRIM(s) == '') RETURN |
---|
| 1976 | b = s(1:1); e = s(MAX(1,LEN_TRIM(s)):MAX(1,LEN_TRIM(s))) |
---|
| 1977 | out = .NOT.is_numeric(s) .AND. (b /= "'" .OR. e /= "'") .AND. ( b /= '"' .OR. e /= '"') |
---|
| 1978 | END FUNCTION needQuotes |
---|
| 1979 | !============================================================================================================================== |
---|
| 1980 | |
---|
| 1981 | |
---|
| 1982 | !============================================================================================================================== |
---|
| 1983 | !=== DISPLAY "<message>: the following <items> are <reason>" FOLLOWED BY THE LIST OF <str> FOR WHICH <lerr>==T. =============== |
---|
| 1984 | !============================================================================================================================== |
---|
[5745] | 1985 | LOGICAL FUNCTION checkList(str, lerr, message, items, reason, nmax) RESULT(out) |
---|
[5001] | 1986 | IMPLICIT NONE |
---|
[4046] | 1987 | ! Purpose: Messages in case a list contains wrong elements (indicated by lerr boolean vector). |
---|
| 1988 | ! Note: Return value "out" is .TRUE. if there are errors (ie at least one element of "lerr" is TRUE). |
---|
| 1989 | CHARACTER(LEN=*), INTENT(IN) :: str(:) |
---|
| 1990 | LOGICAL, INTENT(IN) :: lerr(:) |
---|
| 1991 | CHARACTER(LEN=*), INTENT(IN) :: message, items, reason |
---|
| 1992 | INTEGER, OPTIONAL, INTENT(IN) :: nmax |
---|
[4349] | 1993 | !------------------------------------------------------------------------------------------------------------------------------ |
---|
[4046] | 1994 | CHARACTER(LEN=maxlen), ALLOCATABLE :: s(:) |
---|
| 1995 | INTEGER :: i, nmx |
---|
| 1996 | nmx = 256; IF(PRESENT(nmax)) nmx=nmax |
---|
| 1997 | out = ANY(lerr); IF(.NOT.out) RETURN |
---|
| 1998 | CALL msg(TRIM(message)//': the following '//TRIM(items)//' are '//TRIM(reason)//':') |
---|
| 1999 | s = strStackm(PACK(str, MASK=lerr), ', ',nmx) |
---|
| 2000 | DO i=1,SIZE(s,DIM=1); CALL msg(s(i)); END DO |
---|
| 2001 | END FUNCTION checkList |
---|
| 2002 | !============================================================================================================================== |
---|
| 2003 | |
---|
| 2004 | |
---|
| 2005 | !============================================================================================================================== |
---|
| 2006 | !=== Remove comment in line "str", ie all the characters from the first "#" sign found in "str". ============================== |
---|
| 2007 | !============================================================================================================================== |
---|
| 2008 | SUBROUTINE removeComment(str) |
---|
[5001] | 2009 | IMPLICIT NONE |
---|
[4046] | 2010 | CHARACTER(LEN=*), INTENT(INOUT) :: str |
---|
| 2011 | INTEGER :: ix |
---|
| 2012 | ix = INDEX(str,'# '); IF(ix /= 0) str = str(1:ix-1)//REPEAT(' ',LEN(str)-ix+1) |
---|
| 2013 | END SUBROUTINE removeComment |
---|
| 2014 | !============================================================================================================================== |
---|
| 2015 | |
---|
| 2016 | |
---|
| 2017 | END MODULE strings_mod |
---|