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 116264129 : 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 233996050 : do ic=1,LEN_TRIM(str_in)
268 117731921 : iasc=IACHAR(str_in(ic:ic))
269 233996050 : if (iasc>=ASCII_aa.and.iasc<=ASCII_zz) then
270 367 : str_out(ic:ic)=ACHAR(iasc-SHIFT)
271 : else
272 117731554 : str_out(ic:ic)=str_in(ic:ic)
273 : end if
274 : end do
275 :
276 116264129 : 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 121017 : 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 618498 : do ic=1,LEN_TRIM(str_in)
327 497481 : iasc=IACHAR(str_in(ic:ic))
328 618498 : if (iasc>=ASCII_A.and.iasc<=ASCII_Z) then
329 53 : str_out(ic:ic)=ACHAR(iasc+SHIFT)
330 : else
331 497428 : str_out(ic:ic)=str_in(ic:ic)
332 : end if
333 : end do
334 :
335 121017 : 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 40693 : elemental subroutine replace_ch0(string)
396 :
397 : character(len=*), intent(inout) :: string
398 :
399 : integer :: i, l
400 :
401 40693 : i = index(string, char(0))
402 40693 : if (i > 0) then
403 91 : l = len(string)
404 12251 : string(i:l) = repeat(" ", l - i + 1)
405 : end if
406 :
407 40693 : 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 2413155 : 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 2413155 : lg=LEN(istr)
467 3395607 : do ii=1,lg
468 3395607 : if (istr(ii:ii)/=BLANK) EXIT
469 : end do
470 :
471 2413155 : ostr = " "
472 215946693 : do jj=1,lg-ii+1
473 213533538 : ostr(jj:jj) = istr(ii:ii)
474 215946693 : ii=ii+1
475 : end do
476 :
477 2413155 : 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 10833 : 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 10833 : ostr = ADJUSTL(istr)
504 :
505 10833 : 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 10833 : 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 6060 : 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 6060 : character(len=LEN(istr)+2) :: tmp
572 : ! *********************************************************************
573 :
574 6060 : do ii=1,LEN(istr)
575 6060 : if (istr(ii:ii)/=BLANK) EXIT
576 : end do
577 :
578 6060 : qq = istr(ii:ii)
579 :
580 6060 : 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 6023 : qq = '('
590 6023 : ostr(1:1) = qq
591 6023 : ostr(2:) = TRIM(istr)
592 6023 : ii = LEN_TRIM(ostr)+1
593 6023 : ostr(ii:ii) = ")"
594 : end if
595 :
596 6060 : 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 295 : 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 295 : ostr = ""; cnt = 0
667 6051 : do ii=1,len_trim(istr)
668 17262 : if (any(istr(ii:ii) == ["'", '"'])) cycle
669 5750 : cnt = cnt + 1
670 6051 : ostr(cnt:cnt) = istr(ii:ii)
671 : end do
672 :
673 295 : 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 1471097 : 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 1471097 : if (len_trim(str1) > 0) then
866 1470868 : ostr=TRIM(str1)//" "//TRIM(str2)
867 : else
868 229 : ostr=TRIM(str2)
869 : end if
870 :
871 1471097 : 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 319285 : 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 319285 : ostr = sjoin_2(sjoin_2(str1, str2), str3)
891 :
892 319285 : 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 247095 : 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 247095 : ostr = sjoin_2(str1, sjoin_3(str2, str3, str4))
912 :
913 247095 : 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 235562 : 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 235562 : ostr = sjoin_2(str1, sjoin_4(str2, str3, str4, str5))
933 :
934 235562 : 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 217085 : 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 217085 : ostr = sjoin_2(str1, sjoin_5(str2, str3, str4, str5, str6))
954 :
955 217085 : 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 41876 : 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 41876 : ostr = sjoin_2(str1, sjoin_6(str2, str3, str4, str5, str6, str7))
976 :
977 41876 : 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 3897710 : 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 3897710 : ostr=TRIM(str1)//TRIM(str2)
1040 :
1041 3897710 : 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 707 : 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 707 : ostr = TRIM(str1)//TRIM(str2)//TRIM(str3)
1061 :
1062 707 : 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 162 : 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 162 : ostr = TRIM(str1)//TRIM(str2)//TRIM(str3)//TRIM(str4)
1082 :
1083 162 : 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 69379 : 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 69379 : ostr = TRIM(str1)//TRIM(str2)//TRIM(str3)//TRIM(str4)//trim(str5)
1103 :
1104 69379 : 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 23343 : character(len=3) pure function yesno(bool)
1118 :
1119 : !Arguments ------------------------------------
1120 : logical,intent(in) :: bool
1121 : ! *********************************************************************
1122 :
1123 23343 : if (bool) then
1124 14904 : yesno = "yes"
1125 : else
1126 8439 : yesno = "no"
1127 : end if
1128 :
1129 23343 : 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 251813 : 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 251813 : write(itoa_4b,"(i0)")value
1214 251813 : itoa_4b = ADJUSTL(itoa_4b)
1215 :
1216 251813 : 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 7247 : 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 7247 : if (present(fmt)) then
1236 6060 : write(ftoa_dp,round_brackets(fmt))value
1237 : else
1238 1187 : write(ftoa_dp,"(es16.6)")value
1239 : end if
1240 7247 : ftoa_dp = ADJUSTL(ftoa_dp)
1241 :
1242 7247 : 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 130344 : 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 130344 : if (present(fmt)) then
1289 0 : write(ktoa,fmt)kpt
1290 : else
1291 130344 : write(ktoa,"(a,3(es11.4,a))")"[",kpt(1),", ",kpt(2),", ",kpt(3),"]"
1292 : end if
1293 130344 : ktoa = ADJUSTL(ktoa)
1294 :
1295 130344 : 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 2686 : 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 2686 : sz = size(list)
1346 :
1347 2686 : 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 2622 : str = ""; base = 1
1354 10701 : 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 8079 : if (ii == 1) then
1359 2622 : write(temp, "(a,i0,a)")"[",list(1),", "
1360 5457 : else if (ii == sz) then
1361 2622 : write(temp, "(i0,a)")list(ii),"]"
1362 : else
1363 2835 : write(temp, "(i0,a)")list(ii),", "
1364 : end if
1365 :
1366 10701 : if (base + len_trim(temp) <= MAX_SLEN) then
1367 8079 : str(base:) = trim(temp)//" "
1368 8079 : 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 4258 : 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 2129 : myfmt = "es13.4"; if (present(fmt)) myfmt = fmt
1401 2129 : sz = size(list)
1402 :
1403 2129 : 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 2046 : str = ""; base = 1; fa = sjoin("(",myfmt,",a)")
1410 17945 : 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 15899 : if (ii == 1) then
1415 2046 : write(temp, sjoin("(a,",myfmt,",a)")) "[",list(1),","
1416 13853 : else if (ii == sz) then
1417 2046 : write(temp, fa)list(ii),"]"
1418 : else
1419 11807 : write(temp, fa) list(ii),","
1420 : end if
1421 :
1422 17945 : if (base + len_trim(temp) <= MAX_SLEN) then
1423 15899 : str(base:) = trim(temp)// " "
1424 15899 : base = len_trim(str) + 2
1425 : else
1426 : return
1427 : end if
1428 : end do
1429 :
1430 2129 : 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 269335 : 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 269335 : nch =LEN (string)
1462 269335 : nch_trim=LEN_TRIM(string)
1463 :
1464 269335 : ic = INDEX (TRIM(string), DIR_SEPARATOR, back=.TRUE.)
1465 : !write(*,*)'DEBUG ',TRIM(string),ic
1466 :
1467 269335 : if (ic >= 1 .and. ic <= nch_trim-1) then ! there is stuff after the separator.
1468 269254 : basename = string(ic+1:nch_trim)
1469 269254 : 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 269335 : 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 1654 : 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 1654 : my_csens=.FALSE.; if (PRESENT(csens)) my_csens = csens
1510 :
1511 0 : if (.not.my_csens) then
1512 1654 : ans = ( string(1:1) == ch)
1513 : else
1514 0 : ans = ( toupper(string(1:1)) == toupper(ch))
1515 : end if
1516 :
1517 1654 : 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 1141303 : 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 1141303 : my_csens=.FALSE.; if (PRESENT(csens)) my_csens = csens
1551 :
1552 1141303 : first_ch = string(1:1)
1553 :
1554 1141303 : ans=.FALSE.
1555 :
1556 1141303 : if (.not.my_csens) then
1557 2361095 : do ii=1,SIZE(char_list)
1558 2361095 : 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 1141303 : 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 82150 : 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 82150 : ans = .False.
1623 82150 : lenstr = len_trim(string); lensuf = len_trim(suffix)
1624 82150 : if (lensuf > lenstr) return
1625 :
1626 140823 : do ii=1,lensuf
1627 121315 : p = lenstr - lensuf + ii
1628 140823 : if (suffix(ii:ii) /= string(p:p)) return
1629 : end do
1630 82150 : 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 231654 : 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 231654 : ostr = " "
1659 231654 : jj = n
1660 16707339 : do ii=1,LEN_TRIM(istr)
1661 16475685 : ch = istr(ii:ii)
1662 16475685 : jj = jj + 1
1663 16707339 : if (ch == NCHAR) then
1664 121684 : ostr(jj:jj) = NCHAR
1665 608420 : do kk=jj+1,jj+n
1666 608420 : ostr(kk:kk) = " "
1667 : end do
1668 : jj = jj+n
1669 : else
1670 16354001 : ostr(jj:jj) = ch
1671 : end if
1672 : end do
1673 : !ostr(jj+1:) = "H"
1674 :
1675 231654 : 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 6454 : 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 6454 : ostr = ""
1747 6454 : jj = 1; ostr(jj:jj) = one_char
1748 : !jj = 0
1749 :
1750 5296614 : do ii=1,LEN_TRIM(istr)
1751 5290160 : ch = istr(ii:ii)
1752 5290160 : jj = jj + 1
1753 5296614 : if (ch == ch10) then
1754 76722 : ostr(jj:jj) = ch10
1755 76722 : ostr(jj+1:jj+1) = one_char
1756 76722 : jj = jj+1
1757 : else
1758 5213438 : ostr(jj:jj) = ch
1759 : end if
1760 : end do
1761 : !ostr(jj+1:) = "H"
1762 :
1763 6454 : 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 71977 : 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 71977 : lenstr=min(len(string),25)
1799 71977 : if(iint<0 .or. iint>10._dp**(lenstr-1))then
1800 0 : string=repeat('#',lenstr)
1801 0 : return
1802 : end if
1803 71977 : if(iint<10)then
1804 46850 : write(string,'("000",i1)')iint
1805 25127 : else if(iint<100)then
1806 13041 : write(string,'("00",i2)')iint
1807 12086 : else if(iint<1000)then
1808 12086 : 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 71977 : 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 11120 : 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 11120 : if(iint<0 .or. iint>=1.d10)then
1861 0 : string='####'
1862 0 : return
1863 : end if
1864 11120 : if(iint<10)then
1865 8160 : 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 1257946 : 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 1257946 : char_count = 0
1910 318637640 : do i=1,len(string)
1911 318637640 : if (string(i:i) == char) char_count = char_count + 1
1912 : end do
1913 :
1914 1257946 : 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 88418201 : 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 88418201 : if (first) then
2015 44280 : do ii=1,26
2016 : ! Look for occurrence of each upper case character
2017 : ! anywhere in string of all lower case letters
2018 42640 : indx=index(lolett,uplett(ii:ii))
2019 : ! If found then print error message and quit
2020 44280 : 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 1640 : first=.false.
2029 : end if
2030 :
2031 88418201 : inquotes = 0
2032 1150665230 : do ii=1,len_trim(string)
2033 : ! Pick off single character of string (one byte):
2034 1062247029 : cc=string(ii:ii)
2035 :
2036 : ! Ignore tokens between quotation marks.
2037 1062247029 : if (cc == "'" .or. cc == '"') inquotes = inquotes + 1
2038 1062247029 : if (inquotes == 1) cycle
2039 1061783789 : if (inquotes == 2) then
2040 : inquotes = 0; cycle
2041 : end if
2042 : ! determine whether a lowercase letter:
2043 1061767887 : indx=index(lolett,cc)
2044 : ! Map to uppercase:
2045 1150186088 : if (indx>0) string(ii:ii)=uplett(indx:indx)
2046 : end do
2047 :
2048 88418201 : 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 114081 : 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 114081 : 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 114081 : back__ = .True.; if (present(back)) back__ = back
2092 114081 : do ic=1,size(choices)
2093 114081 : iend = index(string, trim(choices(ic)), back=back__)
2094 114081 : if (iend /= 0) then
2095 114081 : 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 114081 : 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 114081 : end function find_and_select
2112 : !!***
2113 :
2114 0 : end module m_fstrings
2115 : !!***
|
