Branch data Line data Source code
1 : : !!****m* ABINIT/m_fstrings
2 : : !! NAME
3 : : !! m_fstrings
4 : : !!
5 : : !! FUNCTION
6 : : !! This module contains basic tools to operate on Fortran strings.
7 : : !!
8 : : !! COPYRIGHT
9 : : !! Copyright (C) 2008-2026 ABINIT group (MG, XG, MT, DC)
10 : : !! This file is distributed under the terms of the
11 : : !! GNU General Public License, see ~abinit/COPYING
12 : : !! or http://www.gnu.org/copyleft/gpl.txt .
13 : : !!
14 : : !! SOURCE
15 : :
16 : : #if defined HAVE_CONFIG_H
17 : : #include "config.h"
18 : : #endif
19 : :
20 : : #include "abi_common.h"
21 : :
22 : : MODULE m_fstrings
23 : :
24 : : use, intrinsic :: iso_c_binding
25 : :
26 : : use defs_basis, only : sp, dp, std_out, ch10
27 : :
28 : : implicit none
29 : :
30 : : private
31 : :
32 : : public :: is_letter ! Returns .TRUE. if ch is a letter and .FALSE. otherwise
33 : : public :: is_digit ! Returns .TRUE. if ch is a digit (0,1,...,9) and .FALSE. otherwise
34 : : public :: find_digit ! Returns the position of the first digit in string. 0 if not found.
35 : : public :: upper ! Convert lower case letters to UPPER CASE
36 : : public :: toupper ! Convert lower case letters to UPPER CASE (function version)
37 : : public :: lower ! Convert UPPER CASE letters to lower case
38 : : public :: tolower ! Convert UPPER CASE letters to lower case (function version)
39 : : public :: removesp ! Removes spaces, tabs, and control characters in string str
40 : : public :: replace_ch0 ! Replace final '\0' with whitespaces
41 : : public :: lstrip ! Remove leading spaces from string
42 : : public :: replace ! Replace chars in string.
43 : : public :: ljust ! Return a left-justified string of length width.
44 : : public :: lpad ! Pad a string adding repeat characters fillchar on the left side.
45 : : public :: round_brackets ! Return a new string enclosed in parentheses if not already present.
46 : : public :: quote ! Return a new string enclosed by quotation marks.
47 : : public :: rmquotes ! Remove quotation marks from a string. Return new string
48 : : public :: write_num ! Writes a number to a string using format fmt
49 : : public :: trimzero ! Deletes nonsignificant trailing zeroes from a number string.
50 : : public :: writeq ! Writes a string of the form <name> = value to unit
51 : : public :: strcat ! Concatenate strings (function version)
52 : : public :: sjoin ! Joins strings with a space separator.
53 : : public :: yesno ! Convert boolean to "yes", "no"
54 : : public :: itoa ! Convert an integer into a string
55 : : public :: ftoa ! Convert a float into a string
56 : : public :: ktoa ! Convert a k-point into a string.
57 : : public :: stoa ! Convert a spin index into a string
58 : : public :: ltoa ! Convert a list into a string.
59 : : public :: atoi ! Convert a string into a integer
60 : : public :: atof ! Convert a string into a floating-point number.
61 : : public :: basename ! Returns the final component of a pathname.
62 : : public :: firstchar ! Returns .TRUE. is the first character in a string belongs to a gives set.
63 : : public :: startswith ! Returns .TRUE. is the string starts with the specified prefix.
64 : : public :: endswith ! Returns .True if the string ends with the specified suffix.
65 : : public :: indent ! Indent text
66 : : public :: string_in ! Compare input str with a list of comma-separated strings
67 : : public :: prep_char ! Prepend `char` to each line in a string.
68 : : public :: int2char4 ! Convert a positive integer number (zero included) to a character(len=*)
69 : : ! with trailing zeros if the number is <=9999
70 : : public :: int2char10 ! Convert a positive integer number (zero included) to a character(len=10)
71 : : ! with trailing blanks
72 : : public :: char_count ! Count the occurrences of a character in a string.
73 : : public :: next_token ! Tokenize a string made of whitespace-separated tokens.
74 : : public :: inupper ! Maps all characters in string to uppercase except for tokens between quotation marks.
75 : : public :: find_and_select ! Find substring and select value in list depending on substring
76 : :
77 : : !TODO method to center a string
78 : : interface itoa
79 : : module procedure itoa_1b
80 : : module procedure itoa_4b
81 : : end interface itoa
82 : :
83 : : interface ftoa
84 : : module procedure ftoa_dp
85 : : module procedure ftoa_sp
86 : : end interface ftoa
87 : :
88 : : interface write_num
89 : : module procedure write_rdp_0D
90 : : module procedure write_int_0D
91 : : end interface write_num
92 : :
93 : : interface writeq
94 : : module procedure writeq_rdp_0D
95 : : module procedure writeq_int_0D
96 : : end interface writeq
97 : :
98 : : interface is_digit
99 : : module procedure is_digit_0D
100 : : end interface is_digit
101 : :
102 : : interface firstchar
103 : : module procedure firstchar_0d
104 : : module procedure firstchar_1d
105 : : end interface firstchar
106 : :
107 : : interface sjoin
108 : : module procedure sjoin_2
109 : : module procedure sjoin_3
110 : : module procedure sjoin_4
111 : : module procedure sjoin_5
112 : : module procedure sjoin_6
113 : : module procedure sjoin_7
114 : : module procedure sjoin_8
115 : : module procedure sjoin_9
116 : : end interface sjoin
117 : :
118 : : interface strcat
119 : : module procedure strcat_2
120 : : module procedure strcat_3
121 : : module procedure strcat_4
122 : : module procedure strcat_5
123 : : end interface strcat
124 : :
125 : : interface ltoa
126 : : module procedure ltoa_int
127 : : module procedure ltoa_dp
128 : : end interface ltoa
129 : :
130 : : character(len=1),parameter :: BLANK=' '
131 : : character(len=1),parameter :: NCHAR = char(10)
132 : : character(len=1),parameter :: DIR_SEPARATOR = '/'
133 : :
134 : : integer,parameter :: ASCII_A=ICHAR('A')
135 : : integer,parameter :: ASCII_Z=ICHAR('Z')
136 : : integer,parameter :: ASCII_aa=ICHAR('a')
137 : : integer,parameter :: ASCII_zz=ICHAR('z')
138 : : integer,parameter :: SHIFT=ASCII_aa-ASCII_A ! Capital letters have smaller Dec value in the ASCII table.
139 : : integer,parameter :: ASCII_0=ICHAR('0')
140 : : integer,parameter :: ASCII_9=ICHAR('9')
141 : :
142 : : integer,parameter :: MAX_SLEN = 500
143 : :
144 : :
145 : : CONTAINS !===========================================================
146 : : !!***
147 : :
148 : : !!****f* m_fstrings/is_letter
149 : : !! NAME
150 : : !! is_letter
151 : : !!
152 : : !! FUNCTION
153 : : !! Returns .TRUE. if ch is a letter and .FALSE. otherwise.
154 : : !!
155 : : !! SOURCE
156 : :
157 : 0 : pure function is_letter(ch) result(ans)
158 : :
159 : : character(len=1),intent(in) :: ch
160 : : logical :: ans
161 : : ! *********************************************************************
162 : :
163 : 0 : select case (ICHAR(ch))
164 : : case (ASCII_A:ASCII_Z,ASCII_aa:ASCII_zz)
165 : 0 : ans=.TRUE.
166 : : case DEFAULT
167 [ # # ]: 0 : ans=.FALSE.
168 : : end select
169 : :
170 : 0 : end function is_letter
171 : : !!***
172 : :
173 : : !!****f* m_fstrings/is_digit_0D
174 : : !! NAME
175 : : !! is_digit_0D
176 : : !!
177 : : !! FUNCTION
178 : : !! Returns .TRUE. if ch is a digit (0,1,...,9) and .FALSE. otherwise.
179 : : !!
180 : : !! SOURCE
181 : :
182 : 846 : pure function is_digit_0D(ch) result(ans)
183 : :
184 : : !Arguments ------------------------------------
185 : : character(len=1),intent(in) :: ch
186 : : logical :: ans
187 : : ! *********************************************************************
188 : :
189 : 846 : select case (ICHAR(ch))
190 : : case(ASCII_0:ASCII_9)
191 : 0 : ans=.TRUE.
192 : : case default
193 [ # # ]: 0 : ans=.FALSE.
194 : : end select
195 : :
196 : 0 : end function is_digit_0D
197 : : !!***
198 : :
199 : : !!****f* m_fstrings/find_digit
200 : : !! NAME
201 : : !! find_digit
202 : : !!
203 : : !! FUNCTION
204 : : !! Returns the position of the first digit in string. 0 if not found.
205 : : !!
206 : : !! SOURCE
207 : :
208 : 582 : integer pure function find_digit(string) result(ii)
209 : :
210 : : !Arguments ------------------------------------
211 : : character(len=*),intent(in) :: string
212 : : ! *********************************************************************
213 : :
214 [ + + ]: 1428 : do ii=1,len_trim(string)
215 [ + - ]: 1428 : if (is_digit(string(ii:ii))) return
216 : : end do
217 : 582 : ii = 0
218 : :
219 : : end function find_digit
220 : : !!***
221 : :
222 : : !!****f* m_fstrings/upper
223 : : !! NAME
224 : : !! upper
225 : : !!
226 : : !! FUNCTION
227 : : !! Convert lower case letters to UPPER CASE.
228 : : !!
229 : : !! SOURCE
230 : :
231 : 0 : pure subroutine upper(str)
232 : :
233 : : character(len=*),intent(inout) :: str
234 : :
235 : : !Local variables-------------------------------
236 : : integer :: ic,iasc
237 : : ! *********************************************************************
238 : :
239 [ # # ]: 0 : do ic=1,LEN_TRIM(str)
240 : 0 : iasc=IACHAR(str(ic:ic))
241 [ # # ]: 0 : if (iasc>=ASCII_aa.and.iasc<=ASCII_zz) str(ic:ic)=ACHAR(iasc-SHIFT)
242 : : end do
243 : :
244 : 0 : end subroutine upper
245 : : !!***
246 : :
247 : : !----------------------------------------------------------------------
248 : :
249 : : !!****f* m_fstrings/toupper
250 : : !! NAME
251 : : !! toupper
252 : : !!
253 : : !! FUNCTION
254 : : !! Convert lower case letters to UPPER CASE (function version).
255 : : !!
256 : : !! SOURCE
257 : :
258 : 116904016 : pure function toupper(str_in) result(str_out)
259 : :
260 : : character(len=*),intent(in) :: str_in
261 : : character(len=LEN_TRIM(str_in)) :: str_out
262 : :
263 : : !Local variables-------------------------------
264 : : integer :: ic,iasc
265 : : ! *********************************************************************
266 : :
267 [ + + ]: 235280096 : do ic=1,LEN_TRIM(str_in)
268 : 118376080 : iasc=IACHAR(str_in(ic:ic))
269 [ + + ]: 235280096 : if (iasc>=ASCII_aa.and.iasc<=ASCII_zz) then
270 : 367 : str_out(ic:ic)=ACHAR(iasc-SHIFT)
271 : : else
272 : 118375713 : str_out(ic:ic)=str_in(ic:ic)
273 : : end if
274 : : end do
275 : :
276 : 116904016 : end function toupper
277 : : !!***
278 : :
279 : : !----------------------------------------------------------------------
280 : :
281 : : !!****f* m_fstrings/lower
282 : : !! NAME
283 : : !! lower
284 : : !!
285 : : !! FUNCTION
286 : : !! Convert UPPER CASE letters to lower case.
287 : : !!
288 : : !! SOURCE
289 : :
290 : 19 : pure subroutine lower(str)
291 : :
292 : : character(len=*),intent(inout) :: str
293 : :
294 : : !Local variables-------------------------------
295 : : integer :: ic,iasc
296 : : ! *********************************************************************
297 : :
298 [ + + ]: 141 : do ic=1,LEN_TRIM(str)
299 : 122 : iasc=IACHAR(str(ic:ic))
300 [ - + ]: 141 : if (iasc>=ASCII_A.and.iasc<=ASCII_Z) str(ic:ic)=ACHAR(iasc+SHIFT)
301 : : end do
302 : :
303 : 19 : end subroutine lower
304 : : !!***
305 : :
306 : : !----------------------------------------------------------------------
307 : :
308 : : !!****f* m_fstrings/tolower
309 : : !! NAME
310 : : !! tolower
311 : : !!
312 : : !! FUNCTION
313 : : !! Convert UPPER CASE letters to lower case (function version).
314 : : !!
315 : : !! SOURCE
316 : :
317 : 122973 : pure function tolower(str_in) result(str_out)
318 : :
319 : : character(len=*),intent(in) :: str_in
320 : : character(len=LEN_TRIM(str_in)) :: str_out
321 : :
322 : : !Local variables-------------------------------
323 : : integer :: ic,iasc
324 : : ! *********************************************************************
325 : :
326 [ + + ]: 628602 : do ic=1,LEN_TRIM(str_in)
327 : 505629 : iasc=IACHAR(str_in(ic:ic))
328 [ + + ]: 628602 : if (iasc>=ASCII_A.and.iasc<=ASCII_Z) then
329 : 53 : str_out(ic:ic)=ACHAR(iasc+SHIFT)
330 : : else
331 : 505576 : str_out(ic:ic)=str_in(ic:ic)
332 : : end if
333 : : end do
334 : :
335 : 122973 : end function tolower
336 : : !!***
337 : :
338 : : !----------------------------------------------------------------------
339 : :
340 : : !!****f* m_fstrings/removesp
341 : : !! NAME
342 : : !! removesp
343 : : !!
344 : : !! FUNCTION
345 : : !! Removes spaces, tabs, and control characters in string str.
346 : : !!
347 : : !! INPUTS
348 : : !!
349 : : !! OUTPUT
350 : : !!
351 : : !! SOURCE
352 : :
353 : 0 : subroutine removesp(str)
354 : :
355 : : character(len=*),intent(inout) :: str
356 : :
357 : : !Local variables-------------------------------
358 : : integer :: i,k,lenstr,ich
359 : : character(len=1):: ch
360 : 0 : character(len=LEN_TRIM(str)):: outstr
361 : : ! *********************************************************************
362 : :
363 [ # # ]: 0 : str=ADJUSTL(str) ; lenstr=LEN_TRIM(str)
364 : :
365 [ # # ]: 0 : outstr=BLANK ; k=0
366 [ # # ]: 0 : do i=1,lenstr
367 : 0 : ch=str(i:i)
368 : 0 : ich=IACHAR(ch)
369 : 0 : select case(ich)
370 : : case(0:32) ! space, tab, or control character
371 : 0 : CYCLE
372 : : case(33:)
373 : 0 : k=k+1
374 [ # # ]: 0 : outstr(k:k)=ch
375 : : end select
376 : : end do
377 : :
378 [ # # # # ]: 0 : str=ADJUSTL(outstr)
379 : :
380 : 0 : end subroutine removesp
381 : : !!***
382 : :
383 : : !!****m* m_fstrings/replace_ch0
384 : : !! NAME
385 : : !! replace_ch0
386 : : !!
387 : : !! FUNCTION
388 : : !! Little tool to change all final '\0' (end of string in C) characters to ' ' (space).
389 : : !!
390 : : !! SIDE EFFECTS
391 : : !! * string = the string to convert. It is done in-place.
392 : : !!
393 : : !! SOURCE
394 : :
395 : 40923 : elemental subroutine replace_ch0(string)
396 : :
397 : : character(len=*), intent(inout) :: string
398 : :
399 : : integer :: i, l
400 : :
401 : 40923 : i = index(string, char(0))
402 [ + + ]: 40923 : if (i > 0) then
403 : 91 : l = len(string)
404 [ - + + + : 12251 : string(i:l) = repeat(" ", l - i + 1)
+ - - + ]
405 : : end if
406 : :
407 : 40923 : end subroutine replace_ch0
408 : : !!***
409 : :
410 : : !!****m* m_fstrings/replace
411 : : !! NAME
412 : : !! replace
413 : : !!
414 : : !! FUNCTION
415 : : !! Replace `text` with `rep` in string `s`. Return new string.
416 : : !!
417 : : !! NOTES:
418 : : !! The length of the output string is increased by 500 but this could not be enough
419 : : !! if len_trim(text) > len_trim(re) and there are several occurrences of `text` in s.
420 : : !!
421 : : !! SOURCE
422 : :
423 : 85 : function replace(s, text, rep) result(outs)
424 : :
425 : : character(len=*),intent(in) :: s, text, rep
426 : : character(len(s)+500) :: outs ! provide outs with extra 500 char len
427 : :
428 : : !Local variables-------------------------------
429 : : integer :: i, j, nt, nr, last
430 : : ! *********************************************************************
431 : :
432 [ + - ]: 85 : outs = s; nt = len_trim(text); nr = len_trim(rep); last = 1
433 : : do
434 [ + + ]: 130 : i = index(outs(last:), text(1:nt)); if (i == 0) exit
435 : 45 : j = last + i - 1; last = j + nr
436 [ - + ]: 130 : if (j - 1 < 1) then
437 [ # # # # ]: 0 : outs = rep(:nr) // outs(j+nt:)
438 : : else
439 [ + - + + ]: 45 : outs = outs(:j-1) // rep(:nr) // outs(j+nt:)
440 : : end if
441 : : end do
442 : :
443 [ + - ]: 85 : end function replace
444 : : !!***
445 : :
446 : : !----------------------------------------------------------------------
447 : :
448 : : !!****f* m_fstrings/lstrip
449 : : !! NAME
450 : : !! lstrip
451 : : !!
452 : : !! FUNCTION
453 : : !! Removes leading spaces from the input string.
454 : : !!
455 : : !! SOURCE
456 : :
457 : 2428162 : pure function lstrip(istr) result(ostr)
458 : :
459 : : character(len=*),intent(in) :: istr
460 : : character(len=len(istr)) :: ostr
461 : :
462 : : !Local variables-------------------------------
463 : : integer :: ii,jj,lg
464 : : ! *********************************************************************
465 : :
466 : 2428162 : lg=LEN(istr)
467 [ + - ]: 3417188 : do ii=1,lg
468 [ + + ]: 3417188 : if (istr(ii:ii)/=BLANK) EXIT
469 : : end do
470 : :
471 [ + - ]: 2428162 : ostr = " "
472 [ + + ]: 217414302 : do jj=1,lg-ii+1
473 : 214986140 : ostr(jj:jj) = istr(ii:ii)
474 : 217414302 : ii=ii+1
475 : : end do
476 : :
477 : 2428162 : end function lstrip
478 : : !!***
479 : :
480 : : !----------------------------------------------------------------------
481 : :
482 : : !!****f* m_fstrings/ljust
483 : : !! NAME
484 : : !! ljust
485 : : !!
486 : : !! FUNCTION
487 : : !! Return S left-justified in a string of length width. Padding is
488 : : !! done using the specified fill character (default is a space).
489 : : !!
490 : : !! SOURCE
491 : :
492 : 11782 : pure function ljust(istr, width, fillchar) result(ostr)
493 : :
494 : : character(len=*),intent(in) :: istr
495 : : integer,intent(in) :: width
496 : : character(len=width) :: ostr
497 : : character(len=1),optional,intent(in) :: fillchar
498 : :
499 : : !Local variables-------------------------------
500 : : integer :: ii
501 : : ! *********************************************************************
502 : :
503 [ + - + + ]: 11782 : ostr = ADJUSTL(istr)
504 : :
505 [ - + ]: 11782 : if (PRESENT(fillchar)) then
506 [ # # ]: 0 : do ii=LEN_TRIM(ostr)+1,width
507 : 0 : ostr(ii:ii) = fillchar
508 : : end do
509 : : end if
510 : :
511 : 11782 : end function ljust
512 : : !!***
513 : :
514 : : !----------------------------------------------------------------------
515 : :
516 : : !!****f* m_fstrings/lpad
517 : : !! NAME
518 : : !! lpad
519 : : !!
520 : : !! FUNCTION
521 : : !! Pad a string adding repeat characters fillchar on the left side.
522 : : !! Padding is done using the specified fill character (default is a blanck character).
523 : : !!
524 : : !! INPUTS
525 : : !!
526 : : !! OUTPUT
527 : : !!
528 : : !! SOURCE
529 : :
530 : 0 : pure function lpad(istr, repeat, fillchar) result(ostr)
531 : :
532 : : character(len=*),intent(in) :: istr
533 : : integer,intent(in) :: repeat
534 : : character(len=LEN_TRIM(istr) + repeat) :: ostr
535 : : character(len=1),optional,intent(in) :: fillchar
536 : :
537 : : !Local variables-------------------------------
538 : : integer :: ii
539 : : character(len=1) :: ch
540 : : ! *********************************************************************
541 : :
542 [ # # ]: 0 : ostr(repeat+1:) = TRIM(istr)
543 : :
544 [ # # ]: 0 : ch = " "; if (PRESENT(fillchar)) ch = fillchar
545 [ # # ]: 0 : do ii=1,repeat
546 : 0 : ostr(ii:ii) = ch
547 : : end do
548 : :
549 [ # # ]: 0 : end function lpad
550 : : !!***
551 : :
552 : : !----------------------------------------------------------------------
553 : :
554 : : !!****f* m_fstrings/round_brackets
555 : : !! NAME
556 : : !! round_brackets
557 : : !!
558 : : !! FUNCTION
559 : : !! Return a new string enclosed in parentheses if not already present.
560 : : !!
561 : : !! SOURCE
562 : :
563 : 6099 : pure function round_brackets(istr) result(ostr)
564 : :
565 : : character(len=*),intent(in) :: istr
566 : : character(len=LEN_TRIM(istr)+2) :: ostr
567 : :
568 : : !Local variables-------------------------------
569 : : integer :: ii
570 : : character(len=1) :: qq
571 : 6099 : character(len=LEN(istr)+2) :: tmp
572 : : ! *********************************************************************
573 : :
574 [ + - ]: 6099 : do ii=1,LEN(istr)
575 [ - + ]: 6099 : if (istr(ii:ii)/=BLANK) EXIT
576 : : end do
577 : :
578 : 6099 : qq = istr(ii:ii)
579 : :
580 [ + + ]: 6099 : if (qq == "(") then
581 : : ! Don't add quotation marks if they already present.
582 [ + - + - ]: 37 : tmp = istr
583 : 37 : ii = LEN_TRIM(tmp)
584 : : ! If the string is not closed, fix it.
585 [ - + ]: 37 : if (tmp(ii:ii) /= ")") tmp(ii+1:ii+1) = ")"
586 [ + - - + ]: 37 : ostr = TRIM(tmp)
587 : :
588 : : else
589 : 6062 : qq = '('
590 : 6062 : ostr(1:1) = qq
591 [ + - + - ]: 6062 : ostr(2:) = TRIM(istr)
592 : 6062 : ii = LEN_TRIM(ostr)+1
593 : 6062 : ostr(ii:ii) = ")"
594 : : end if
595 : :
596 : 6099 : end function round_brackets
597 : : !!***
598 : :
599 : : !----------------------------------------------------------------------
600 : :
601 : : !!****f* m_fstrings/quote
602 : : !! NAME
603 : : !! quote
604 : : !!
605 : : !! FUNCTION
606 : : !! Return a new string enclosed by quotation marks.
607 : : !!
608 : : !! SOURCE
609 : :
610 : 0 : pure function quote(istr) result(ostr)
611 : :
612 : : character(len=*),intent(in) :: istr
613 : : character(len=LEN_TRIM(istr)+2) :: ostr
614 : :
615 : : !Local variables-------------------------------
616 : : integer :: ii
617 : : character(len=1) :: qq
618 : 0 : character(len=LEN(istr)+2) :: tmp
619 : : ! *********************************************************************
620 : :
621 [ # # ]: 0 : do ii=1,LEN(istr)
622 [ # # ]: 0 : if (istr(ii:ii)/=BLANK) EXIT
623 : : end do
624 : :
625 : 0 : qq = istr(ii:ii)
626 : :
627 [ # # ]: 0 : if (qq == "'" .or. qq == '"') then
628 : : ! Don't add quotation marks if they already present.
629 [ # # # # ]: 0 : tmp = istr
630 : 0 : ii = LEN_TRIM(tmp)
631 : : ! If the string is not closed, fix it.
632 [ # # ]: 0 : if (tmp(ii:ii) /= qq) tmp(ii+1:ii+1) = qq
633 [ # # # # ]: 0 : ostr = TRIM(tmp)
634 : :
635 : : else
636 : 0 : qq = '"'
637 : 0 : ostr(1:1) = qq
638 [ # # # # ]: 0 : ostr(2:) = TRIM(istr)
639 : 0 : ii = LEN_TRIM(ostr)+1
640 : 0 : ostr(ii:ii) = qq
641 : : end if
642 : :
643 : 0 : end function quote
644 : : !!***
645 : :
646 : : !----------------------------------------------------------------------
647 : :
648 : : !!****f* m_fstrings/rmquotes
649 : : !! NAME
650 : : !! rmquotes
651 : : !!
652 : : !! FUNCTION
653 : : !! Remove quotation marks from a string. Return new string
654 : : !!
655 : : !! SOURCE
656 : :
657 : 299 : pure function rmquotes(istr) result(ostr)
658 : :
659 : : character(len=*),intent(in) :: istr
660 : : character(len=len(istr)) :: ostr
661 : :
662 : : !Local variables-------------------------------
663 : : integer :: ii,cnt
664 : : ! *********************************************************************
665 : :
666 [ + - ]: 299 : ostr = ""; cnt = 0
667 [ + + ]: 6115 : do ii=1,len_trim(istr)
668 [ + + + + : 17442 : if (any(istr(ii:ii) == ["'", '"'])) cycle
+ + ]
669 : 5810 : cnt = cnt + 1
670 : 6115 : ostr(cnt:cnt) = istr(ii:ii)
671 : : end do
672 : :
673 : 299 : end function rmquotes
674 : : !!***
675 : :
676 : : !----------------------------------------------------------------------
677 : :
678 : : !!****f* m_fstrings/write_rdp_0d
679 : : !! NAME
680 : : !! write_rdp_0d
681 : : !!
682 : : !! FUNCTION
683 : : !! Writes a number to a string using format fmt.
684 : : !!
685 : : !! SOURCE
686 : :
687 : 108 : subroutine write_rdp_0d(rnum,str,fmt)
688 : :
689 : : !Arguments ------------------------------------
690 : : real(dp),intent(in) :: rnum
691 : : character(len=*),intent(in) :: fmt
692 : : character(len=*),intent(out) :: str
693 : :
694 : : !Local variables-------------------------------
695 : 108 : character(len=LEN(fmt)+2) :: formt
696 : : ! *********************************************************************
697 : :
698 [ + - - + ]: 108 : formt='('//TRIM(fmt)//')'
699 : 108 : write(str,formt)rnum
700 [ + - ]: 108 : str=ADJUSTL(str)
701 : :
702 : 108 : end subroutine write_rdp_0D
703 : : !!***
704 : :
705 : : !----------------------------------------------------------------------
706 : :
707 : : !!****f* m_fstrings/write_int_0d
708 : : !! NAME
709 : : !! write_int_0d
710 : : !!
711 : : !! FUNCTION
712 : : !! Writes a number to a string using format fmt.
713 : : !!
714 : : !! SOURCE
715 : :
716 : 0 : subroutine write_int_0D(inum,str,fmt)
717 : :
718 : : !Arguments ------------------------------------
719 : : integer,intent(in) :: inum
720 : : character(len=*),intent(in) :: fmt
721 : : character(len=*),intent(out) :: str
722 : :
723 : : !Local variables-------------------------------
724 : 0 : character(len=LEN(fmt)+2) :: formt
725 : : ! *********************************************************************
726 : :
727 [ # # # # ]: 0 : formt='('//TRIM(fmt)//')'
728 : 0 : write(str,formt) inum
729 [ # # ]: 0 : str=ADJUSTL(str)
730 : :
731 : 0 : end subroutine write_int_0D
732 : : !!***
733 : :
734 : : !----------------------------------------------------------------------
735 : :
736 : : !!****f* m_fstrings/trimzero
737 : : !! NAME
738 : : !! trimzero
739 : : !!
740 : : !! FUNCTION
741 : : !! Deletes nonsignificant trailing zeroes from number string str. If number
742 : : !! string ends in a decimal point, one trailing zero is added.
743 : : !!
744 : : !! INPUTS
745 : : !!
746 : : !! OUTPUT
747 : : !!
748 : : !! SOURCE
749 : : ! NOT sure it will work
750 : :
751 : 0 : subroutine trimzero(str)
752 : :
753 : : character(len=*),intent(inout) :: str
754 : :
755 : : !Local variables-------------------------------
756 : : integer :: i,ipos,lstr
757 : : character :: ch
758 : : character(len=10) :: sexp
759 : : ! *********************************************************************
760 : :
761 : 0 : ipos=SCAN(str,'eE')
762 : 0 : if (ipos>0) then
763 [ # # ]: 0 : sexp=str(ipos:)
764 [ # # # # ]: 0 : str=str(1:ipos-1)
765 : : end if
766 : 0 : lstr=LEN_TRIM(str)
767 [ # # ]: 0 : do i=lstr,1,-1
768 : 0 : ch=str(i:i)
769 [ # # ]: 0 : if (ch=='0') CYCLE
770 [ # # ]: 0 : if (ch=='.') then
771 [ # # # # ]: 0 : str=str(1:i)//'0'
772 [ # # # # : 0 : if (ipos>0) str=TRIM(str)//TRIM(sexp)
# # ]
773 : : EXIT
774 : : end if
775 [ # # # # ]: 0 : str=str(1:i)
776 : 0 : EXIT
777 : : end do
778 : :
779 [ # # # # : 0 : if (ipos>0) str=TRIM(str)//TRIM(sexp)
# # ]
780 : :
781 [ # # ]: 0 : end subroutine trimzero
782 : : !!***
783 : :
784 : : !----------------------------------------------------------------------
785 : :
786 : : !!****f* m_fstrings/writeq_rdp_0D
787 : : !! NAME
788 : : !! writeq_rdp_0D
789 : : !!
790 : : !! FUNCTION
791 : : !! Writes a string of the form <name> = value to unit.
792 : : !!
793 : : !! INPUTS
794 : : !!
795 : : !! OUTPUT
796 : : !!
797 : : !! SOURCE
798 : 0 : subroutine writeq_rdp_0D(unit,namestr,value,fmt)
799 : :
800 : : real(dp),intent(in) :: value
801 : : integer,intent(in) :: unit
802 : : character(len=*),intent(in) :: fmt
803 : : character(len=*),intent(in) :: namestr
804 : :
805 : : !Local variables-------------------------------
806 : : character(len=32) :: tempstr
807 : : ! *********************************************************************
808 : :
809 : 0 : call write_num(value,tempstr,fmt)
810 : 0 : call trimzero(tempstr)
811 : 0 : write(unit,*)TRIM(namestr)//' = '//TRIM(tempstr)
812 : :
813 : 0 : end subroutine writeq_rdp_0D
814 : : !!***
815 : :
816 : : !----------------------------------------------------------------------
817 : :
818 : : !!****f* m_fstrings/writeq_int_0D
819 : : !! NAME
820 : : !! writeq_int_0D
821 : : !!
822 : : !! FUNCTION
823 : : !! Writes a string of the form <name> = value to unit.
824 : : !!
825 : : !! INPUTS
826 : : !!
827 : : !! OUTPUT
828 : : !!
829 : : !! SOURCE
830 : :
831 : 0 : subroutine writeq_int_0D(unit,namestr,ivalue,fmt)
832 : :
833 : : integer,intent(in) :: ivalue
834 : : integer,intent(in) :: unit
835 : : character(len=*),intent(in) :: namestr
836 : : character(len=*),intent(in) :: fmt
837 : :
838 : : !Local variables-------------------------------
839 : : character(len=32) :: tempstr
840 : : ! *********************************************************************
841 : :
842 : 0 : call write_num(ivalue,tempstr,fmt)
843 : 0 : call trimzero(tempstr)
844 : 0 : write(unit,*)TRIM(namestr)//' = '//TRIM(tempstr)
845 : :
846 : 0 : end subroutine writeq_int_0D
847 : : !!***
848 : :
849 : : !----------------------------------------------------------------------
850 : :
851 : : !!****f* m_fstrings/sjoin_2
852 : : !! NAME
853 : : !! sjoin_2
854 : : !!
855 : : !! FUNCTION
856 : : !! Joins two strings with a space separator except if first string is empty.
857 : : !!
858 : :
859 : 896933 : pure function sjoin_2(str1,str2) result(ostr)
860 : :
861 : : character(len=*),intent(in) :: str1,str2
862 : : character(len=LEN_TRIM(str1)+LEN_TRIM(str2)+1) :: ostr
863 : : ! *********************************************************************
864 : :
865 : 896933 : if (len_trim(str1) > 0) then
866 [ + - - + ]: 896698 : ostr=TRIM(str1)//" "//TRIM(str2)
867 : : else
868 [ + - + + ]: 235 : ostr=TRIM(str2)
869 : : end if
870 : :
871 [ + + ]: 896933 : end function sjoin_2
872 : : !!***
873 : :
874 : : !----------------------------------------------------------------------
875 : :
876 : : !!****f* m_fstrings/sjoin_3
877 : : !! NAME
878 : : !! sjoin_3
879 : : !!
880 : : !! FUNCTION
881 : : !! Joins three strings with a space separator.
882 : : !!
883 : :
884 : 204590 : pure function sjoin_3(str1,str2,str3) result(ostr)
885 : :
886 : : character(len=*),intent(in) :: str1,str2,str3
887 : : character(len=LEN_TRIM(str1)+LEN_TRIM(str2)+LEN_TRIM(str3)+2) :: ostr
888 : : ! *********************************************************************
889 : :
890 [ + - + + ]: 204590 : ostr = sjoin_2(sjoin_2(str1, str2), str3)
891 : :
892 : 204590 : end function sjoin_3
893 : : !!***
894 : :
895 : : !----------------------------------------------------------------------
896 : :
897 : : !!****f* m_fstrings/sjoin_4
898 : : !! NAME
899 : : !! sjoin_4
900 : : !!
901 : : !! FUNCTION
902 : : !! Joins four strings with a space separator.
903 : : !!
904 : :
905 : 131955 : pure function sjoin_4(str1,str2,str3,str4) result(ostr)
906 : :
907 : : character(len=*),intent(in) :: str1,str2,str3,str4
908 : : character(len=LEN_TRIM(str1)+LEN_TRIM(str2)+LEN_TRIM(str3)+len_trim(str4)+3) :: ostr
909 : : ! *********************************************************************
910 : :
911 [ + - - + ]: 131955 : ostr = sjoin_2(str1, sjoin_3(str2, str3, str4))
912 : :
913 : 131955 : end function sjoin_4
914 : : !!***
915 : :
916 : : !----------------------------------------------------------------------
917 : :
918 : : !!****f* m_fstrings/sjoin_5
919 : : !! NAME
920 : : !! sjoin_5
921 : : !!
922 : : !! FUNCTION
923 : : !! Joins five strings with a space separator.
924 : : !!
925 : :
926 : 120323 : pure function sjoin_5(str1,str2,str3,str4,str5) result(ostr)
927 : :
928 : : character(len=*),intent(in) :: str1,str2,str3,str4,str5
929 : : character(len=LEN_TRIM(str1)+LEN_TRIM(str2)+LEN_TRIM(str3)+len_trim(str4)+len_trim(str5)+4) :: ostr
930 : : ! *********************************************************************
931 : :
932 [ + - - + ]: 120323 : ostr = sjoin_2(str1, sjoin_4(str2, str3, str4, str5))
933 : :
934 : 120323 : end function sjoin_5
935 : : !!***
936 : :
937 : : !----------------------------------------------------------------------
938 : :
939 : : !!****f* m_fstrings/sjoin_6
940 : : !! NAME
941 : : !! sjoin_6
942 : : !!
943 : : !! FUNCTION
944 : : !! Joins six strings with a space separator.
945 : : !!
946 : :
947 : 101755 : pure function sjoin_6(str1,str2,str3,str4,str5,str6) result(ostr)
948 : :
949 : : character(len=*),intent(in) :: str1,str2,str3,str4,str5,str6
950 : : character(len=LEN_TRIM(str1)+LEN_TRIM(str2)+LEN_TRIM(str3)+len_trim(str4)+len_trim(str5)+len_trim(str6)+5) :: ostr
951 : : ! *********************************************************************
952 : :
953 [ + - - + ]: 101755 : ostr = sjoin_2(str1, sjoin_5(str2, str3, str4, str5, str6))
954 : :
955 : 101755 : end function sjoin_6
956 : : !!***
957 : :
958 : : !----------------------------------------------------------------------
959 : :
960 : : !!****f* m_fstrings/sjoin_7
961 : : !! NAME
962 : : !! sjoin_7
963 : : !!
964 : : !! FUNCTION
965 : : !! Joins seven strings with a space separator.
966 : : !!
967 : :
968 : 42344 : pure function sjoin_7(str1,str2,str3,str4,str5,str6,str7) result(ostr)
969 : :
970 : : character(len=*),intent(in) :: str1,str2,str3,str4,str5,str6,str7
971 : : character(len=LEN_TRIM(str1)+LEN_TRIM(str2)+LEN_TRIM(str3)+len_trim(str4)+len_trim(str5)+len_trim(str6)+len_trim(str7)+6) &
972 : : & :: ostr
973 : : ! *********************************************************************
974 : :
975 [ + - - + ]: 42344 : ostr = sjoin_2(str1, sjoin_6(str2, str3, str4, str5, str6, str7))
976 : :
977 : 42344 : end function sjoin_7
978 : : !!***
979 : :
980 : : !----------------------------------------------------------------------
981 : :
982 : : !!****f* m_fstrings/sjoin_8
983 : : !! NAME
984 : : !! sjoin_8
985 : : !!
986 : : !! FUNCTION
987 : : !! Joins eight strings with a space separator.
988 : : !!
989 : :
990 : 0 : pure function sjoin_8(str1,str2,str3,str4,str5,str6,str7,str8) result(ostr)
991 : :
992 : : character(len=*),intent(in) :: str1,str2,str3,str4,str5,str6,str7,str8
993 : : character(len=LEN_TRIM(str1)+LEN_TRIM(str2)+LEN_TRIM(str3)+len_trim(str4)+len_trim(str5)+len_trim(str6)+len_trim(str7)+len_trim(str8)+7) &
994 : : & :: ostr
995 : : ! *********************************************************************
996 : :
997 [ # # # # ]: 0 : ostr = sjoin_2(str1, sjoin_7(str2, str3, str4, str5, str6, str7, str8))
998 : :
999 : 0 : end function sjoin_8
1000 : : !!***
1001 : :
1002 : : !----------------------------------------------------------------------
1003 : :
1004 : : !!****f* m_fstrings/sjoin_9
1005 : : !! NAME
1006 : : !! sjoin_9
1007 : : !!
1008 : : !! FUNCTION
1009 : : !! Joins nine strings with a space separator.
1010 : : !!
1011 : :
1012 : 0 : pure function sjoin_9(str1,str2,str3,str4,str5,str6,str7,str8,str9) result(ostr)
1013 : :
1014 : : character(len=*),intent(in) :: str1,str2,str3,str4,str5,str6,str7,str8,str9
1015 : : character(len=LEN_TRIM(str1)+LEN_TRIM(str2)+LEN_TRIM(str3)+len_trim(str4)+len_trim(str5)+len_trim(str6)+len_trim(str7)+len_trim(str8)+len_trim(str9)+8) &
1016 : : & :: ostr
1017 : : ! *********************************************************************
1018 : :
1019 [ # # # # ]: 0 : ostr = sjoin_2(str1, sjoin_8(str2, str3, str4, str5, str6, str7, str8, str9))
1020 : :
1021 : 0 : end function sjoin_9
1022 : : !!***
1023 : :
1024 : : !----------------------------------------------------------------------
1025 : :
1026 : : !!****f* m_fstrings/strcat_2
1027 : : !! NAME
1028 : : !! strcat_2
1029 : : !!
1030 : : !! FUNCTION
1031 : : !! Returns two concatenated strings.
1032 : :
1033 : 3923320 : pure function strcat_2(str1,str2) result(ostr)
1034 : :
1035 : : character(len=*),intent(in) :: str1,str2
1036 : : character(len=LEN_TRIM(str1)+LEN_TRIM(str2)) :: ostr
1037 : : ! *********************************************************************
1038 : :
1039 [ + - - + ]: 3923320 : ostr=TRIM(str1)//TRIM(str2)
1040 : :
1041 : 3923320 : end function strcat_2
1042 : : !!***
1043 : :
1044 : : !----------------------------------------------------------------------
1045 : :
1046 : : !!****f* m_fstrings/strcat_3
1047 : : !! NAME
1048 : : !! strcat_3
1049 : : !!
1050 : : !! FUNCTION
1051 : : !! Concatenate 3 strings
1052 : : !!
1053 : :
1054 : 717 : pure function strcat_3(str1, str2, str3) result(ostr)
1055 : :
1056 : : character(len=*),intent(in) :: str1,str2,str3
1057 : : character(len=LEN_TRIM(str1)+LEN_TRIM(str2)+LEN_TRIM(str3)) :: ostr
1058 : : ! *********************************************************************
1059 : :
1060 [ + - - + ]: 717 : ostr = TRIM(str1)//TRIM(str2)//TRIM(str3)
1061 : :
1062 : 717 : end function strcat_3
1063 : : !!***
1064 : :
1065 : : !----------------------------------------------------------------------
1066 : :
1067 : : !!****f* m_fstrings/strcat_4
1068 : : !! NAME
1069 : : !! strcat_3
1070 : : !!
1071 : : !! FUNCTION
1072 : : !! Concatenate 4 strings
1073 : : !!
1074 : :
1075 : 168 : pure function strcat_4(str1, str2, str3, str4) result(ostr)
1076 : :
1077 : : character(len=*),intent(in) :: str1,str2,str3,str4
1078 : : character(len=LEN_TRIM(str1)+LEN_TRIM(str2)+LEN_TRIM(str3)+LEN_TRIM(str4)) :: ostr
1079 : : ! *********************************************************************
1080 : :
1081 [ + - - + ]: 168 : ostr = TRIM(str1)//TRIM(str2)//TRIM(str3)//TRIM(str4)
1082 : :
1083 : 168 : end function strcat_4
1084 : : !!***
1085 : :
1086 : : !----------------------------------------------------------------------
1087 : :
1088 : : !!****f* m_fstrings/strcat_5
1089 : : !! NAME
1090 : : !! strcat_5
1091 : : !!
1092 : : !! FUNCTION
1093 : : !! Concatenate 5 strings
1094 : : !!
1095 : :
1096 : 69495 : pure function strcat_5(str1, str2, str3, str4, str5) result(ostr)
1097 : :
1098 : : character(len=*),intent(in) :: str1,str2,str3,str4,str5
1099 : : character(len=LEN_TRIM(str1)+LEN_TRIM(str2)+LEN_TRIM(str3)+LEN_TRIM(str4)+LEN_TRIM(str5)) :: ostr
1100 : : ! *********************************************************************
1101 : :
1102 [ + - - + ]: 69495 : ostr = TRIM(str1)//TRIM(str2)//TRIM(str3)//TRIM(str4)//trim(str5)
1103 : :
1104 : 69495 : end function strcat_5
1105 : : !!***
1106 : :
1107 : : !----------------------------------------------------------------------
1108 : :
1109 : : !!****f* m_fstrings/yesno
1110 : : !! NAME
1111 : : !! yesno
1112 : : !!
1113 : : !! FUNCTION
1114 : : !! Convert boolean into "yes" or "no"
1115 : : !!
1116 : :
1117 : 23485 : character(len=3) pure function yesno(bool)
1118 : :
1119 : : !Arguments ------------------------------------
1120 : : logical,intent(in) :: bool
1121 : : ! *********************************************************************
1122 : :
1123 [ + + ]: 23485 : if (bool) then
1124 : 15007 : yesno = "yes"
1125 : : else
1126 : 8478 : yesno = "no"
1127 : : end if
1128 : :
1129 : 23485 : end function yesno
1130 : : !!***
1131 : :
1132 : : !----------------------------------------------------------------------
1133 : :
1134 : : !!****f* m_fstrings/atoi
1135 : : !! NAME
1136 : : !! atoi
1137 : : !!
1138 : : !! FUNCTION
1139 : : !! Convert a string into a integer
1140 : : !!
1141 : :
1142 : 13630 : integer function atoi(string)
1143 : :
1144 : : !Arguments ------------------------------------
1145 : : character(len=*),intent(in) :: string
1146 : : ! *********************************************************************
1147 : :
1148 [ + - ]: 13630 : read(string,*,err=10)atoi
1149 : 13630 : return
1150 : 0 : 10 write(std_out,*)"Error while trying to convert string to integer. string: ",trim(string)
1151 : :
1152 : 0 : end function atoi
1153 : : !!***
1154 : :
1155 : : !----------------------------------------------------------------------
1156 : :
1157 : : !!****f* m_fstrings/atof
1158 : : !! NAME
1159 : : !! atof
1160 : : !!
1161 : : !! FUNCTION
1162 : : !! Convert a string into a floating-point number
1163 : : !!
1164 : :
1165 : 0 : real(dp) function atof(string)
1166 : :
1167 : : !Arguments ------------------------------------
1168 : : character(len=*),intent(in) :: string
1169 : : ! *********************************************************************
1170 : :
1171 [ # # ]: 0 : read(string,*,err=10)atof
1172 : 0 : return
1173 : 0 : 10 write(std_out,*)"Error while trying to convert string to floating-point. string: ",trim(string)
1174 : :
1175 : 0 : end function atof
1176 : : !!***
1177 : :
1178 : : !!****f* m_fstrings/itoa_1b
1179 : : !! NAME
1180 : : !! itoa_1b
1181 : : !!
1182 : : !! FUNCTION
1183 : : !! Convert an integer into a string
1184 : : !!
1185 : :
1186 : 0 : pure function itoa_1b(value)
1187 : :
1188 : : integer(c_int8_t),intent(in) :: value
1189 : : character(len=22) :: itoa_1b
1190 : : ! *********************************************************************
1191 : :
1192 : : ! len=22 is large enough to contain integer*8
1193 : 0 : write(itoa_1b,"(i0)")value
1194 : 0 : itoa_1b = ADJUSTL(itoa_1b)
1195 : :
1196 : 0 : end function itoa_1b
1197 : : !!***
1198 : :
1199 : : !!****f* m_fstrings/itoa_4b
1200 : : !! NAME
1201 : : !! itoa_4b
1202 : : !!
1203 : : !! FUNCTION
1204 : : !! Convert an integer into a string
1205 : : !!
1206 : 253463 : pure function itoa_4b(value)
1207 : :
1208 : : integer,intent(in) :: value
1209 : : character(len=22) :: itoa_4b
1210 : : ! *********************************************************************
1211 : :
1212 : : ! len=22 is large enough to contain integer*8
1213 : 253463 : write(itoa_4b,"(i0)")value
1214 : 253463 : itoa_4b = ADJUSTL(itoa_4b)
1215 : :
1216 : 253463 : end function itoa_4b
1217 : : !!***
1218 : :
1219 : : !----------------------------------------------------------------------
1220 : :
1221 : : !!****f* m_fstrings/ftoa_dp
1222 : : !! NAME
1223 : : !! ftoa_dp
1224 : : !!
1225 : : !! FUNCTION
1226 : : !! Convert an float into a string using format fmt (es16.6 if fmt is not given).
1227 : :
1228 : 7287 : pure function ftoa_dp(value, fmt)
1229 : :
1230 : : real(dp),intent(in) :: value
1231 : : character(len=*),optional,intent(in) :: fmt
1232 : : character(len=MAX_SLEN) :: ftoa_dp
1233 : : ! *********************************************************************
1234 : :
1235 [ + + ]: 7287 : if (present(fmt)) then
1236 : 6099 : write(ftoa_dp,round_brackets(fmt))value
1237 : : else
1238 : 1188 : write(ftoa_dp,"(es16.6)")value
1239 : : end if
1240 : 7287 : ftoa_dp = ADJUSTL(ftoa_dp)
1241 : :
1242 : 7287 : end function ftoa_dp
1243 : : !!***
1244 : :
1245 : : !----------------------------------------------------------------------
1246 : :
1247 : : !!****f* m_fstrings/ftoa_sp
1248 : : !! NAME
1249 : : !! ftoa_sp
1250 : : !!
1251 : : !! FUNCTION
1252 : : !! Convert an float into a string using format fmt (es16.6 if fmt is not given).
1253 : :
1254 : 0 : pure function ftoa_sp(value, fmt)
1255 : :
1256 : : real(sp),intent(in) :: value
1257 : : character(len=*),optional,intent(in) :: fmt
1258 : : character(len=MAX_SLEN) :: ftoa_sp
1259 : : ! *********************************************************************
1260 : :
1261 [ # # ]: 0 : if (present(fmt)) then
1262 : 0 : write(ftoa_sp,round_brackets(fmt))value
1263 : : else
1264 : 0 : write(ftoa_sp,"(es16.6)")value
1265 : : end if
1266 : 0 : ftoa_sp = ADJUSTL(ftoa_sp)
1267 : :
1268 : 0 : end function ftoa_sp
1269 : : !!***
1270 : :
1271 : : !----------------------------------------------------------------------
1272 : :
1273 : : !!****f* m_fstrings/ktoa
1274 : : !! NAME
1275 : : !! ktoa
1276 : : !!
1277 : : !! FUNCTION
1278 : : !! Convert an k-point into a string using format fmt (es.16.6 if fmt is not given).
1279 : : !!
1280 : :
1281 : 130668 : pure function ktoa(kpt, fmt)
1282 : :
1283 : : real(dp),intent(in) :: kpt(3)
1284 : : character(len=*),optional,intent(in) :: fmt
1285 : : character(len=MAX_SLEN) :: ktoa
1286 : : ! *********************************************************************
1287 : :
1288 [ - + ]: 130668 : if (present(fmt)) then
1289 : 0 : write(ktoa,fmt)kpt
1290 : : else
1291 : 130668 : write(ktoa,"(a,3(es11.4,a))")"[",kpt(1),", ",kpt(2),", ",kpt(3),"]"
1292 : : end if
1293 : 130668 : ktoa = ADJUSTL(ktoa)
1294 : :
1295 : 130668 : end function ktoa
1296 : : !!***
1297 : :
1298 : : !----------------------------------------------------------------------
1299 : :
1300 : : !!****f* m_fstrings/stoa
1301 : : !! NAME
1302 : : !! stoa
1303 : : !!
1304 : : !! FUNCTION
1305 : : !! Convert a spin index into a string
1306 : :
1307 : 0 : character(len=4) pure function stoa(spin)
1308 : :
1309 : : integer,intent(in) :: spin
1310 : : ! *********************************************************************
1311 : :
1312 : 0 : select case (spin)
1313 : : case (1)
1314 : 0 : stoa = "UP"
1315 : : case (2)
1316 : 0 : stoa = "DOWN"
1317 : : case default
1318 [ # # # ]: 0 : stoa = "????"
1319 : : end select
1320 : :
1321 : 0 : end function stoa
1322 : : !!***
1323 : :
1324 : : !----------------------------------------------------------------------
1325 : :
1326 : : !!****f* m_fstrings/ltoa_int
1327 : : !! NAME
1328 : : !! ltoa_int
1329 : : !!
1330 : : !! FUNCTION
1331 : : !! Convert a list of integers into a string.
1332 : : !!
1333 : : !! CHILDREN
1334 : :
1335 [ - + ]: 2706 : pure function ltoa_int(list) result(str)
1336 : :
1337 : : integer,intent(in) :: list(:)
1338 : : character(len=MAX_SLEN) :: str
1339 : :
1340 : : !Local variables-------------------------------
1341 : : integer :: ii,base,sz
1342 : : character(len=MAX_SLEN) :: temp
1343 : : ! *********************************************************************
1344 : :
1345 : 2706 : sz = size(list)
1346 : :
1347 [ + + ]: 2706 : if (any(sz == [0, 1])) then
1348 [ - + ]: 64 : if (sz == 0) str = "[]"
1349 [ + - ]: 64 : if (sz == 1) write(str, "(a,i0,a)")"[",list(1),"]"
1350 : 64 : return
1351 : : end if
1352 : :
1353 : 2642 : str = ""; base = 1
1354 [ + + ]: 10800 : do ii=1,sz
1355 : :
1356 : : ! Write to temp string and copy it to str if we have enough chars.
1357 : : ! Return if MAX_SLEN is too short.
1358 [ + + ]: 8158 : if (ii == 1) then
1359 : 2642 : write(temp, "(a,i0,a)")"[",list(1),", "
1360 [ + + ]: 5516 : else if (ii == sz) then
1361 : 2642 : write(temp, "(i0,a)")list(ii),"]"
1362 : : else
1363 : 2874 : write(temp, "(i0,a)")list(ii),", "
1364 : : end if
1365 : :
1366 [ + - ]: 10800 : if (base + len_trim(temp) <= MAX_SLEN) then
1367 [ + - + - ]: 8158 : str(base:) = trim(temp)//" "
1368 : 8158 : base = len_trim(str) + 2
1369 : : else
1370 : : return
1371 : : end if
1372 : : end do
1373 : :
1374 : : end function ltoa_int
1375 : : !!***
1376 : :
1377 : : !----------------------------------------------------------------------
1378 : :
1379 : : !!****f* m_fstrings/ltoa_dp
1380 : : !! NAME
1381 : : !! ltoa_dp
1382 : : !!
1383 : : !! FUNCTION
1384 : : !! Convert a list of double precision numbers into a string.
1385 : : !! fmt specifies the format to be used ("es13.4" by default)
1386 : : !!
1387 : : !! CHILDREN
1388 : :
1389 : 4266 : pure function ltoa_dp(list, fmt) result(str)
1390 : :
1391 : : real(dp),intent(in) :: list(:)
1392 : : character(len=*),optional,intent(in) :: fmt
1393 : : character(len=MAX_SLEN) :: str
1394 : :
1395 : : !Local variables-------------------------------
1396 : : integer :: ii,base,sz
1397 : : character(len=MAX_SLEN) :: temp,myfmt,fa
1398 : : ! *********************************************************************
1399 : :
1400 [ + + + - ]: 2133 : myfmt = "es13.4"; if (present(fmt)) myfmt = fmt
1401 : 2133 : sz = size(list)
1402 : :
1403 [ + + ]: 2133 : if (any(sz == [0, 1])) then
1404 [ - + ]: 83 : if (sz == 0) str = "[]"
1405 [ + - ]: 83 : if (sz == 1) write(str, sjoin("(a,",myfmt,",a)")) "[",list(1),"]"
1406 : 83 : return
1407 : : end if
1408 : :
1409 [ + - ]: 2050 : str = ""; base = 1; fa = sjoin("(",myfmt,",a)")
1410 [ + + ]: 17961 : do ii=1,sz
1411 : :
1412 : : ! Write to temp string and copy it to str if we have enough chars.
1413 : : ! Return if MAX_SLEN is too short.
1414 [ + + ]: 15911 : if (ii == 1) then
1415 : 2050 : write(temp, sjoin("(a,",myfmt,",a)")) "[",list(1),","
1416 [ + + ]: 13861 : else if (ii == sz) then
1417 : 2050 : write(temp, fa)list(ii),"]"
1418 : : else
1419 : 11811 : write(temp, fa) list(ii),","
1420 : : end if
1421 : :
1422 [ + - ]: 17961 : if (base + len_trim(temp) <= MAX_SLEN) then
1423 [ + - + - ]: 15911 : str(base:) = trim(temp)// " "
1424 : 15911 : base = len_trim(str) + 2
1425 : : else
1426 : : return
1427 : : end if
1428 : : end do
1429 : :
1430 [ - + ]: 2133 : end function ltoa_dp
1431 : : !!***
1432 : :
1433 : : !----------------------------------------------------------------------
1434 : :
1435 : : !!****f* m_fstring/basename
1436 : : !! NAME
1437 : : !! basename
1438 : : !!
1439 : : !! FUNCTION
1440 : : !! Returns the final component of a pathname.
1441 : : !!
1442 : : !! INPUTS
1443 : : !! string=The input string
1444 : : !!
1445 : : !! NOTES
1446 : : !! * If the input string in not a valid path to a file (i.e not in the form foo/name)
1447 : : !! a blank strink is returned
1448 : : !! * We do a backward search becase we want to optimize the algorithm for Fortran strings.
1449 : : !!
1450 : : !! SOURCE
1451 : :
1452 : 270335 : pure function basename(string)
1453 : :
1454 : : character(len=*),intent(in) :: string
1455 : : character(len=LEN_TRIM(string)) :: basename
1456 : :
1457 : : !Local variables-------------------------------
1458 : : integer :: ic,nch_trim,nch
1459 : : !************************************************************************
1460 : :
1461 : 270335 : nch =LEN (string)
1462 : 270335 : nch_trim=LEN_TRIM(string)
1463 : :
1464 : 270335 : ic = INDEX (TRIM(string), DIR_SEPARATOR, back=.TRUE.)
1465 : : !write(*,*)'DEBUG ',TRIM(string),ic
1466 : :
1467 : 270335 : if (ic >= 1 .and. ic <= nch_trim-1) then ! there is stuff after the separator.
1468 [ + - + - ]: 270254 : basename = string(ic+1:nch_trim)
1469 : 270254 : return
1470 [ - + - - ]: 81 : else if (ic==0 .or. ic == nch_trim+1) then ! no separator in string or zero length string,
1471 [ + - - + ]: 81 : basename = TRIM(string) ! return trimmed string.
1472 : 81 : return
1473 : : else ! (ic == nch_trim) separator is the last char.
1474 [ # # ]: 0 : basename= BLANK ! This is not a valid path to a file, return blank.
1475 : 0 : return
1476 : : end if
1477 : :
1478 [ + + ]: 270335 : end function basename
1479 : : !!***
1480 : :
1481 : : !----------------------------------------------------------------------
1482 : :
1483 : : !!****f* m_fstring/firstchar_0d
1484 : : !! NAME
1485 : : !! firstchar_0d
1486 : : !!
1487 : : !! FUNCTION
1488 : : !! Return True if string starts with the specified character
1489 : : !!
1490 : : !! INPUTS
1491 : : !! string=The string whose first character has to be cheched
1492 : : !! ch=Character
1493 : : !! [csens]=.TRUE. if comparison is done regardless of case. Defaults to .FALSE.
1494 : : !!
1495 : : !!
1496 : : !! SOURCE
1497 : :
1498 : 1671 : pure function firstchar_0d(string,ch,csens) result(ans)
1499 : :
1500 : : logical :: ans
1501 : : logical,optional,intent(in) :: csens
1502 : : character(len=*),intent(in) :: string
1503 : : character(len=1),intent(in) :: ch
1504 : :
1505 : : !Local variables-------------------------------
1506 : : logical :: my_csens
1507 : : !************************************************************************
1508 : :
1509 [ - + ]: 1671 : my_csens=.FALSE.; if (PRESENT(csens)) my_csens = csens
1510 : :
1511 [ # # ]: 0 : if (.not.my_csens) then
1512 : 1671 : ans = ( string(1:1) == ch)
1513 : : else
1514 : 0 : ans = ( toupper(string(1:1)) == toupper(ch))
1515 : : end if
1516 : :
1517 : 1671 : end function firstchar_0d
1518 : : !!***
1519 : :
1520 : : !----------------------------------------------------------------------
1521 : :
1522 : : !!****f* m_fstring/firstchar_1d
1523 : : !! NAME
1524 : : !! firstchar_1d
1525 : : !!
1526 : : !! FUNCTION
1527 : : !! Returns .TRUE. is the first character of the string belongs to a given list.
1528 : : !!
1529 : : !! INPUTS
1530 : : !! string=The string whose first character has to be cheched
1531 : : !! char_list=The list of characters.
1532 : : !! [csens]=.TRUE. if comparison is done regardless of case. Defaults to .FALSE.
1533 : : !!
1534 : : !!
1535 : : !! SOURCE
1536 : :
1537 [ - + ]: 1148832 : pure function firstchar_1d(string,char_list,csens) result(ans)
1538 : :
1539 : : logical :: ans
1540 : : logical,optional,intent(in) :: csens
1541 : : character(len=*),intent(in) :: string
1542 : : character(len=1),intent(in) :: char_list(:)
1543 : :
1544 : : !Local variables-------------------------------
1545 : : integer :: ii
1546 : : logical :: my_csens
1547 : : character(len=1) :: first_ch
1548 : : !************************************************************************
1549 : :
1550 [ - + ]: 1148832 : my_csens=.FALSE.; if (PRESENT(csens)) my_csens = csens
1551 : :
1552 : 1148832 : first_ch = string(1:1)
1553 : :
1554 : 1148832 : ans=.FALSE.
1555 : :
1556 [ + - ]: 1148832 : if (.not.my_csens) then
1557 [ + + ]: 2374948 : do ii=1,SIZE(char_list)
1558 [ + + ]: 2374948 : ans = ( first_ch == char_list(ii) ); if (ans) EXIT
1559 : : end do
1560 : : else
1561 [ # # ]: 0 : do ii=1,SIZE(char_list)
1562 [ # # ]: 0 : ans = ( toupper(first_ch) == toupper(char_list(ii)) ); if (ans) EXIT
1563 : : end do
1564 : : end if
1565 : :
1566 : 1148832 : end function firstchar_1d
1567 : : !!***
1568 : :
1569 : : !----------------------------------------------------------------------
1570 : :
1571 : : !!****f* m_fstring/startswith
1572 : : !! NAME
1573 : : !! startswith
1574 : : !!
1575 : : !! FUNCTION
1576 : : !! Returns .TRUE. is the string starts with the specified prefix.
1577 : : !!
1578 : : !! SOURCE
1579 : :
1580 : 1366 : pure logical function startswith(string, prefix) result(ans)
1581 : :
1582 : : character(len=*),intent(in) :: string
1583 : : character(len=*),intent(in) :: prefix
1584 : :
1585 : : !Local variables-------------------------------
1586 : : integer :: ii,lenstr,lenpre
1587 : : !************************************************************************
1588 : :
1589 : 1366 : ans = .False.
1590 : 1366 : lenstr = len_trim(string); lenpre = len_trim(prefix)
1591 [ + - ]: 1366 : if (lenpre > lenstr) return
1592 : :
1593 [ + + ]: 5464 : do ii=1,lenpre
1594 [ + - ]: 5464 : if (prefix(ii:ii) /= string(ii:ii)) return
1595 : : end do
1596 : 1366 : ans = .True.
1597 : :
1598 : : end function startswith
1599 : : !!***
1600 : :
1601 : : !----------------------------------------------------------------------
1602 : :
1603 : : !!****f* m_fstring/endswith
1604 : : !! NAME
1605 : : !! endswith
1606 : : !!
1607 : : !! FUNCTION
1608 : : !! Returns .TRUE. is the string ends with the specified suffix
1609 : : !!
1610 : : !! SOURCE
1611 : :
1612 : 82548 : pure function endswith(string, suffix) result(ans)
1613 : :
1614 : : logical :: ans
1615 : : character(len=*),intent(in) :: string
1616 : : character(len=*),intent(in) :: suffix
1617 : :
1618 : : !Local variables-------------------------------
1619 : : integer :: ii,p,lenstr,lensuf
1620 : : !************************************************************************
1621 : :
1622 : 82548 : ans = .False.
1623 : 82548 : lenstr = len_trim(string); lensuf = len_trim(suffix)
1624 [ + - ]: 82548 : if (lensuf > lenstr) return
1625 : :
1626 [ + + ]: 141506 : do ii=1,lensuf
1627 : 121899 : p = lenstr - lensuf + ii
1628 [ + + ]: 141506 : if (suffix(ii:ii) /= string(p:p)) return
1629 : : end do
1630 : 82548 : ans = .True.
1631 : :
1632 : : end function endswith
1633 : : !!***
1634 : :
1635 : : !!****f* m_fstrings/indent
1636 : : !! NAME
1637 : : !! indent
1638 : : !!
1639 : : !! FUNCTION
1640 : : !! Indent text
1641 : : !!
1642 : : !! INPUTS
1643 : : !! istr=Input string
1644 : : !!
1645 : : !! SOURCE
1646 : :
1647 : 232367 : pure function indent(istr) result(ostr)
1648 : :
1649 : : character(len=*),intent(in) :: istr
1650 : : character(len=len(istr)*4+4) :: ostr
1651 : :
1652 : : !Local variables-------------------------------
1653 : : integer,parameter :: n=4 ! ostr is large enough to allocate all the possible indentations.
1654 : : integer :: ii,jj,kk
1655 : : character(len=1) :: ch
1656 : : ! *********************************************************************
1657 : :
1658 [ + - ]: 232367 : ostr = " "
1659 : 232367 : jj = n
1660 [ + + ]: 16878211 : do ii=1,LEN_TRIM(istr)
1661 : 16645844 : ch = istr(ii:ii)
1662 : 16645844 : jj = jj + 1
1663 [ + + ]: 16878211 : if (ch == NCHAR) then
1664 : 123865 : ostr(jj:jj) = NCHAR
1665 [ + + ]: 619325 : do kk=jj+1,jj+n
1666 : 619325 : ostr(kk:kk) = " "
1667 : : end do
1668 : : jj = jj+n
1669 : : else
1670 : 16521979 : ostr(jj:jj) = ch
1671 : : end if
1672 : : end do
1673 : : !ostr(jj+1:) = "H"
1674 : :
1675 : 232367 : end function indent
1676 : : !!***
1677 : :
1678 : : !!****f* m_fstrings/string_in
1679 : : !! NAME
1680 : : !! string_in
1681 : : !!
1682 : : !! FUNCTION
1683 : : !! Compare input str with a list of comma-separated strings
1684 : : !! Example: string_in("foo", "foo, bar") --> True
1685 : : !!
1686 : : !! INPUTS
1687 : : !! string=Input string
1688 : : !!
1689 : : !! SOURCE
1690 : :
1691 : 18 : pure logical function string_in(string, tokens) result(ans)
1692 : :
1693 : : character(len=*),intent(in) :: string, tokens
1694 : :
1695 : : !Local variables-------------------------------
1696 : : integer :: ii, prev, cnt
1697 : : ! *********************************************************************
1698 : :
1699 : 18 : ans = .False.
1700 : 18 : prev = 0; cnt = 0
1701 [ + + ]: 210 : do ii=1,len_trim(tokens)
1702 [ + + ]: 210 : if (tokens(ii:ii) == ",") then
1703 : 19 : cnt = cnt + 1
1704 [ + + ]: 19 : if (trim(lstrip(string)) == lstrip(tokens(prev+1:ii-1))) then
1705 : 19 : ans = .True.; return
1706 : : end if
1707 : : prev = ii
1708 : : end if
1709 : : end do
1710 : :
1711 [ - + ]: 8 : if (cnt == 0) then
1712 : 0 : ans = trim(lstrip(string)) == trim(lstrip(tokens)); return
1713 : : end if
1714 : :
1715 : : ! Handle last item if "foo, bar"
1716 : 8 : ans = trim(lstrip(string)) == lstrip(tokens(prev+1:ii-1))
1717 : :
1718 : 8 : end function string_in
1719 : : !!***
1720 : :
1721 : : !----------------------------------------------------------------------
1722 : :
1723 : : !!****f* m_fstrings/prep_char
1724 : : !! NAME
1725 : : !! prep_char
1726 : : !!
1727 : : !! FUNCTION
1728 : : !! Prepend `char` to each line in a string.
1729 : : !!
1730 : : !! INPUTS
1731 : : !! istr=Input string
1732 : : !!
1733 : : !! SOURCE
1734 : :
1735 : 6518 : pure function prep_char(istr, one_char) result(ostr)
1736 : :
1737 : : character(len=*),intent(in) :: istr
1738 : : character(len=2*len(istr)) :: ostr
1739 : : character(len=1),intent(in) :: one_char
1740 : :
1741 : : !Local variables-------------------------------
1742 : : integer :: ii,jj
1743 : : character(len=1) :: ch
1744 : : ! *********************************************************************
1745 : :
1746 [ + - ]: 6518 : ostr = ""
1747 : 6518 : jj = 1; ostr(jj:jj) = one_char
1748 : : !jj = 0
1749 : :
1750 [ + + ]: 5344582 : do ii=1,LEN_TRIM(istr)
1751 : 5338064 : ch = istr(ii:ii)
1752 : 5338064 : jj = jj + 1
1753 [ + + ]: 5344582 : if (ch == ch10) then
1754 : 77412 : ostr(jj:jj) = ch10
1755 : 77412 : ostr(jj+1:jj+1) = one_char
1756 : 77412 : jj = jj+1
1757 : : else
1758 : 5260652 : ostr(jj:jj) = ch
1759 : : end if
1760 : : end do
1761 : : !ostr(jj+1:) = "H"
1762 : :
1763 : 6518 : end function prep_char
1764 : : !!***
1765 : :
1766 : : !----------------------------------------------------------------------
1767 : :
1768 : : !!****f* m_fstrings/int2char4
1769 : : !! NAME
1770 : : !! int2char4
1771 : : !!
1772 : : !! FUNCTION
1773 : : !! Convert an integer number to ("2") a character(len=*)
1774 : : !! with trailing zeros if the number is <=9999.
1775 : : !! Exemple : 123 will be mapped to "0123" ; 12345 will be mapped to "12345"
1776 : : !! Makes sure that the integer fits the string length
1777 : : !! (ex.: between 0 and 99999 if the string is a character(len=5)).
1778 : : !!
1779 : : !! INPUTS
1780 : : !! iint=integer to be converted
1781 : : !!
1782 : : !! OUTPUT
1783 : : !! string=character string ('####...' if error)
1784 : : !!
1785 : : !! SOURCE
1786 : :
1787 : 73623 : pure subroutine int2char4(iint,string)
1788 : :
1789 : : !Arguments ------------------------------------
1790 : : !scalars
1791 : : integer,intent(in) :: iint
1792 : : character(len=*),intent(out) :: string
1793 : :
1794 : : !Local variables-------------------------------
1795 : : integer :: lenstr
1796 : : ! *************************************************************************
1797 : :
1798 : 73623 : lenstr=min(len(string),25)
1799 [ - + ]: 73623 : if(iint<0 .or. iint>10._dp**(lenstr-1))then
1800 [ # # # # : 0 : string=repeat('#',lenstr)
# # # # ]
1801 : 0 : return
1802 : : end if
1803 [ + + ]: 73623 : if(iint<10)then
1804 : 47790 : write(string,'("000",i1)')iint
1805 [ + + ]: 25833 : else if(iint<100)then
1806 : 13401 : write(string,'("00",i2)')iint
1807 [ + - ]: 12432 : else if(iint<1000)then
1808 : 12432 : write(string,'("0",i3)')iint
1809 [ # # ]: 0 : else if(iint<10000)then
1810 : 0 : write(string,'(i4)')iint
1811 [ # # ]: 0 : else if(iint<1.0d5)then
1812 : 0 : write(string,'(i5)')iint
1813 [ # # ]: 0 : else if(iint<1.0d6)then
1814 : 0 : write(string,'(i6)')iint
1815 [ # # ]: 0 : else if(iint<1.0d7)then
1816 : 0 : write(string,'(i7)')iint
1817 [ # # ]: 0 : else if(iint<1.0d8)then
1818 : 0 : write(string,'(i8)')iint
1819 [ # # ]: 0 : else if(iint<1.0d9)then
1820 : 0 : write(string,'(i9)')iint
1821 : : else if(iint<1.0d9)then
1822 : : write(string,'(i10)')iint
1823 : : else
1824 [ # # # # : 0 : string=repeat('#',lenstr)
# # # # ]
1825 : : end if
1826 : :
1827 [ + - ]: 73623 : end subroutine int2char4
1828 : : !!***
1829 : :
1830 : : !----------------------------------------------------------------------
1831 : :
1832 : : !!****f* m_fstrings/int2char10
1833 : : !! NAME
1834 : : !! int2char10
1835 : : !!
1836 : : !! FUNCTION
1837 : : !! Convert a positive integer number (zero included) to a character(len=10),
1838 : : !! with blanks to COMPLETE the string.
1839 : : !! Exemple : 1234 will be mapped to "1234 "
1840 : : !! Makes sure that the integer is between 0 and 9 999 999 999
1841 : : !! Should be enough for integer*4
1842 : : !!
1843 : : !! INPUTS
1844 : : !! iint=integer to be converted
1845 : : !!
1846 : : !! OUTPUT
1847 : : !! string=character string ('##########' if error)
1848 : : !!
1849 : : !! SOURCE
1850 : :
1851 : 11107 : pure subroutine int2char10(iint,string)
1852 : :
1853 : : !Arguments ------------------------------------
1854 : : !scalars
1855 : : integer,intent(in) :: iint
1856 : : character(len=10),intent(out) :: string
1857 : : ! *************************************************************************
1858 : :
1859 : : !Note the use of floating numbers instead of large integers, for portability
1860 [ - + ]: 11107 : if(iint<0 .or. iint>=1.d10)then
1861 : 0 : string='####'
1862 : 0 : return
1863 : : end if
1864 [ + + ]: 11107 : if(iint<10)then
1865 : 8147 : write(string,'(i1,9x)')iint
1866 [ + - ]: 2960 : else if(iint<100)then
1867 : 2960 : write(string,'(i2,8x)')iint
1868 [ # # ]: 0 : else if(iint<1.0d3)then
1869 : 0 : write(string,'(i3,7x)')iint
1870 [ # # ]: 0 : else if(iint<1.0d4)then
1871 : 0 : write(string,'(i4,6x)')iint
1872 [ # # ]: 0 : else if(iint<1.0d5)then
1873 : 0 : write(string,'(i5,5x)')iint
1874 [ # # ]: 0 : else if(iint<1.0d6)then
1875 : 0 : write(string,'(i6,4x)')iint
1876 [ # # ]: 0 : else if(iint<1.0d7)then
1877 : 0 : write(string,'(i7,3x)')iint
1878 [ # # ]: 0 : else if(iint<1.0d8)then
1879 : 0 : write(string,'(i8,2x)')iint
1880 [ # # ]: 0 : else if(iint<1.0d9)then
1881 : 0 : write(string,'(i9,1x)')iint
1882 : : else
1883 : 0 : write(string,'(i10)')iint
1884 : : end if
1885 : :
1886 : : end subroutine int2char10
1887 : : !!***
1888 : :
1889 : : !----------------------------------------------------------------------
1890 : :
1891 : : !!****f* m_fstrings/char_count
1892 : : !! NAME
1893 : : !! chcount
1894 : : !!
1895 : : !! FUNCTION
1896 : : !! Count the occurrences of a character in a string.
1897 : : !!
1898 : : !! SOURCE
1899 : :
1900 : 1266075 : integer pure function char_count(string, char)
1901 : :
1902 : : !Arguments ------------------------------------
1903 : : !scalars
1904 : : character(len=*),intent(in) :: string
1905 : : character(len=1),intent(in) :: char
1906 : : integer :: i
1907 : : ! *************************************************************************
1908 : :
1909 : 1266075 : char_count = 0
1910 [ + + ]: 320769572 : do i=1,len(string)
1911 [ + + ]: 320769572 : if (string(i:i) == char) char_count = char_count + 1
1912 : : end do
1913 : :
1914 : 1266075 : end function char_count
1915 : : !!***
1916 : :
1917 : : !----------------------------------------------------------------------
1918 : :
1919 : : !!****f* m_fstrings/next_token
1920 : : !! NAME
1921 : : !! next_token
1922 : : !!
1923 : : !! FUNCTION
1924 : : !! Assume a string with whitespace-separated tokens.
1925 : : !! Find the next token starting from `start`, return it in `ostr` and update `start`
1926 : : !! so that one can call the function inside a loop.
1927 : : !! Return exit status.
1928 : : !!
1929 : : !! SOURCE
1930 : :
1931 : 444 : integer function next_token(string, start, ostr) result(ierr)
1932 : :
1933 : : !Arguments ------------------------------------
1934 : : !scalars
1935 : : character(len=*),intent(in) :: string
1936 : : character(len=*),intent(out) :: ostr
1937 : : integer,intent(inout) :: start
1938 : :
1939 : : !Local variables-------------------------------
1940 : : integer :: ii,beg
1941 : : ! *************************************************************************
1942 : : !print *, "string:", trim(string(start:)), ", start:", start
1943 : :
1944 : 444 : ierr = 1; beg = 0
1945 : : ! Find first non-empty char.
1946 [ + + ]: 685 : do ii=start,len_trim(string)
1947 [ + + ]: 685 : if (string(ii:ii) /= " ") then
1948 : : beg = ii; exit
1949 : : end if
1950 : : end do
1951 [ + + ]: 444 : if (beg == 0) return
1952 : :
1953 : : ! Find end of token.
1954 : 348 : start = 0
1955 [ + + ]: 984 : do ii=beg,len_trim(string)
1956 [ + + ]: 984 : if (string(ii:ii) == " ") then
1957 : 239 : start = ii; exit
1958 : : end if
1959 : : end do
1960 : : ! Handle end of string.
1961 [ + + ]: 348 : if (start == 0) start = len_trim(string) + 1
1962 : :
1963 : 348 : ierr = 0
1964 : : !print *, "string(beg:):", trim(string(beg:))
1965 [ + - + + ]: 348 : ostr = string(beg:start-1)
1966 : :
1967 : 444 : end function next_token
1968 : : !!***
1969 : :
1970 : : !----------------------------------------------------------------------
1971 : :
1972 : : !!****f* m_fstrings/inupper
1973 : : !! NAME
1974 : : !! inupper
1975 : : !!
1976 : : !! FUNCTION
1977 : : !! Maps all characters in string to uppercase except for tokens between quotation marks.
1978 : : !! Uses fortran90 character string manipulation but should work
1979 : : !! independent of EBCDIC or ASCII assumptions--only relies on
1980 : : !! 'index' intrinsic character string matching function.
1981 : : !! Makes sure that the string 'lolett' remains defined as the lower
1982 : : !! case 26-character alphabet string and 'uplett' remains upper case.
1983 : : !!
1984 : : !! INPUTS
1985 : : !! string= character string with arbitrary case
1986 : : !!
1987 : : !! OUTPUT
1988 : : !! string= same character string mapped to upper case
1989 : : !!
1990 : : !! SIDE EFFECTS
1991 : : !! string= (input) character string with arbitrary case
1992 : : !! (output) same character string mapped to upper case
1993 : : !!
1994 : : !! SOURCE
1995 : :
1996 : 89477819 : subroutine inupper(string)
1997 : :
1998 : : !Arguments ------------------------------------
1999 : : !scalars
2000 : : character(len=*),intent(inout) :: string
2001 : :
2002 : : !Local variables-------------------------------
2003 : : !scalars
2004 : : integer :: ii,indx,inquotes
2005 : : logical,save :: first=.true.
2006 : : character(len=1) :: cc
2007 : : !character(len=500) :: message
2008 : : character(len=26), parameter :: uplett='ABCDEFGHIJKLMNOPQRSTUVWXYZ'
2009 : : character(len=26), parameter :: lolett='abcdefghijklmnopqrstuvwxyz'
2010 : : ! *************************************************************************
2011 : : !
2012 : : !On first entry make sure lower case letters stayed
2013 : : !lower case and upper case letters stayed upper case
2014 [ + + ]: 89477819 : if (first) then
2015 [ + + ]: 44739 : do ii=1,26
2016 : : ! Look for occurrence of each upper case character
2017 : : ! anywhere in string of all lower case letters
2018 : 43082 : indx=index(lolett,uplett(ii:ii))
2019 : : ! If found then print error message and quit
2020 [ - + ]: 44739 : if (indx>0) then
2021 : : write(std_out, '(a,a,a,a,a,a,a,a,a)' )&
2022 : 0 : 'Upper case string = ',uplett,ch10,&
2023 : 0 : 'Lower case string = ',lolett,ch10,&
2024 : 0 : 'Upper case character ',uplett(ii:ii),'found in supposedly lower case string.'
2025 : 0 : stop
2026 : : end if
2027 : : end do
2028 : 1657 : first=.false.
2029 : : end if
2030 : :
2031 : 89477819 : inquotes = 0
2032 [ + + ]: 1166615685 : do ii=1,len_trim(string)
2033 : : ! Pick off single character of string (one byte):
2034 : 1077137866 : cc=string(ii:ii)
2035 : :
2036 : : ! Ignore tokens between quotation marks.
2037 [ + + ]: 1077137866 : if (cc == "'" .or. cc == '"') inquotes = inquotes + 1
2038 [ + + ]: 1077137866 : if (inquotes == 1) cycle
2039 [ + + ]: 1076632070 : if (inquotes == 2) then
2040 : : inquotes = 0; cycle
2041 : : end if
2042 : : ! determine whether a lowercase letter:
2043 : 1076616002 : indx=index(lolett,cc)
2044 : : ! Map to uppercase:
2045 [ + + ]: 1166093821 : if (indx>0) string(ii:ii)=uplett(indx:indx)
2046 : : end do
2047 : :
2048 : 89477819 : end subroutine inupper
2049 : : !!***
2050 : :
2051 : : !----------------------------------------------------------------------
2052 : :
2053 : : !!****f* m_fstrings/find_and_select
2054 : : !! NAME
2055 : : !! find_and_select
2056 : : !!
2057 : : !! FUNCTION
2058 : : !! Find substring and select value in list depending on substring.
2059 : : !!
2060 : : !! Usage example:
2061 : : !!
2062 : : !! istop = find_and_select(arg, &
2063 : : !! ["K", "M", "G", "T"], &
2064 : : !! [one/1024._dp, one, 1024._dp, 1024._dp ** 2], fact, err_msg, default=one)
2065 : : !!
2066 : : !! ABI_CHECK(istop /= -1, err_msg)
2067 : : !!
2068 : : !! SOURCE
2069 : :
2070 [ - + ]: 114954 : integer function find_and_select(string, choices, values, out_val, err_msg, default, back) result(iend)
2071 : :
2072 : : !Arguments ------------------------------------
2073 : : character(len=*),intent(in) :: string
2074 : : character(len=*),intent(in) :: choices(:)
2075 : : real(dp),intent(in) :: values(:)
2076 : : real(dp),optional,intent(in) :: default
2077 : : real(dp),intent(out) :: out_val
2078 : : character(len=*),intent(out) :: err_msg
2079 : : logical,optional,intent(in) :: back
2080 : :
2081 : : !Local variables-------------------------------
2082 : : integer :: ic
2083 : : logical :: back__
2084 : : ! *************************************************************************
2085 : :
2086 [ - + ]: 114954 : if (size(values) /= size(choices)) then
2087 [ # # # # ]: 0 : err_msg = "BUG in API call: size(values) /= size(choices))"
2088 : 0 : iend = -1; return
2089 : : end if
2090 : :
2091 [ - + ]: 114954 : back__ = .True.; if (present(back)) back__ = back
2092 [ + - ]: 114954 : do ic=1,size(choices)
2093 [ + - ]: 114954 : iend = index(string, trim(choices(ic)), back=back__)
2094 [ + - ]: 114954 : if (iend /= 0) then
2095 [ - + ]: 114954 : if (trim(string(iend:)) /= choices(ic)) then
2096 [ # # # # : 0 : err_msg = sjoin("Invalid token:", trim(string(iend:)))
# # ]
2097 : 0 : iend = -1; return
2098 : : end if
2099 : 114954 : out_val = values(ic); return
2100 : : end if
2101 : : end do
2102 : :
2103 [ # # ]: 0 : if (present(default)) then
2104 : 0 : iend = 0
2105 : 0 : out_val = default
2106 : : else
2107 : 0 : iend = -1
2108 [ # # # # ]: 0 : err_msg = "Cannot find `choices` in string and `default` optional argument is not set!"
2109 : : end if
2110 : :
2111 [ - + ]: 114954 : end function find_and_select
2112 : : !!***
2113 : :
2114 : 0 : end module m_fstrings
2115 : : !!***
|
