FortranGIS Version 3.0
iso_varying_string.F90
1! Modified version of Rich Townsend's iso_varying_string.f90, minimal
2! modifications have been made in order to make the internal string
3! storage compatible with a null-terminated C string; the original API
4! has not changed, it has been completed with a constructor from a
5! pointer to a C null-terminated string and a function returning a C
6! const char* pointer to an existing varying string. The iso_c_binding
7! intrinsic module is now required.
8!
9! Copyright 2003 Rich Townsend <rhdt@bartol.udel.edu>
10! Copyright 2011 Davide Cesari <dcesari69 at gmail dot com>
11!
12! This file is part of FortranGIS.
13!
14! The original copyright notice follows:
15! ******************************************************************************
16! * *
17! * iso_varying_string.f90 *
18! * *
19! * Copyright (c) 2003, Rich Townsend <rhdt@bartol.udel.edu> *
20! * All rights reserved. *
21! * *
22! * Redistribution and use in source and binary forms, with or without *
23! * modification, are permitted provided that the following conditions are *
24! * met: *
25! * *
26! * * Redistributions of source code must retain the above copyright notice, *
27! * this list of conditions and the following disclaimer. *
28! * * Redistributions in binary form must reproduce the above copyright *
29! * notice, this list of conditions and the following disclaimer in the *
30! * documentation and/or other materials provided with the distribution. *
31! * *
32! * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS *
33! * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, *
34! * THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *
35! * PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR *
36! * CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, *
37! * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, *
38! * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR *
39! * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF *
40! * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING *
41! * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS *
42! * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *
43! * *
44! ******************************************************************************
45!
46! Author : Rich Townsend <rhdt@bartol.udel.edu>
47! Synopsis : Definition of iso_varying_string module, conformant to the API
48! specified in ISO/IEC 1539-2:2000 (varying-length strings for
49! Fortran 95).
50! Version : 1.3-F
51! Thanks : Lawrie Schonfelder (bugfixes and design pointers), Walt Brainerd
52! (conversion to F).
53
54module iso_varying_string
55use,INTRINSIC :: iso_c_binding
56
57! No implicit typing
58
59 implicit none
60
61! Parameter definitions
62
63 integer, parameter, private :: GET_BUFFER_LEN = 256
64
65! Type definitions
66
67 type, public :: varying_string
68 private
69 character(LEN=1), dimension(:), allocatable :: chars
70 end type varying_string
71
72! Interface blocks
73
74 interface assignment(=)
75 module procedure op_assign_ch_vs
76 module procedure op_assign_vs_ch
77 end interface assignment(=)
78
79 interface operator(//)
80 module procedure op_concat_vs_vs
81 module procedure op_concat_ch_vs
82 module procedure op_concat_vs_ch
83 end interface operator(//)
84
85 interface operator(==)
86 module procedure op_eq_vs_vs
87 module procedure op_eq_ch_vs
88 module procedure op_eq_vs_ch
89 end interface operator(==)
90
91 interface operator(/=)
92 module procedure op_ne_vs_vs
93 module procedure op_ne_ch_vs
94 module procedure op_ne_vs_ch
95 end interface operator (/=)
96
97 interface operator(<)
98 module procedure op_lt_vs_vs
99 module procedure op_lt_ch_vs
100 module procedure op_lt_vs_ch
101 end interface operator (<)
102
103 interface operator(<=)
104 module procedure op_le_vs_vs
105 module procedure op_le_ch_vs
106 module procedure op_le_vs_ch
107 end interface operator (<=)
108
109 interface operator(>=)
110 module procedure op_ge_vs_vs
111 module procedure op_ge_ch_vs
112 module procedure op_ge_vs_ch
113 end interface operator (>=)
114
115 interface operator(>)
116 module procedure op_gt_vs_vs
117 module procedure op_gt_ch_vs
118 module procedure op_gt_vs_ch
119 end interface operator (>)
120
121 interface adjustl
122 module procedure adjustl_
123 end interface adjustl
124
125 interface adjustr
126 module procedure adjustr_
127 end interface adjustr
128
129 interface char
130 module procedure char_auto
131 module procedure char_fixed
132 end interface char
133
134 interface iachar
135 module procedure iachar_
136 end interface iachar
137
138 interface ichar
139 module procedure ichar_
140 end interface ichar
141
142 interface index
143 module procedure index_vs_vs
144 module procedure index_ch_vs
145 module procedure index_vs_ch
146 end interface index
147
148 interface len
149 module procedure len_
150 end interface len
151
152 interface len_trim
153 module procedure len_trim_
154 end interface len_trim
155
156 interface lge
157 module procedure lge_vs_vs
158 module procedure lge_ch_vs
159 module procedure lge_vs_ch
160 end interface lge
161
162 interface lgt
163 module procedure lgt_vs_vs
164 module procedure lgt_ch_vs
165 module procedure lgt_vs_ch
166 end interface lgt
167
168 interface lle
169 module procedure lle_vs_vs
170 module procedure lle_ch_vs
171 module procedure lle_vs_ch
172 end interface lle
173
174 interface llt
175 module procedure llt_vs_vs
176 module procedure llt_ch_vs
177 module procedure llt_vs_ch
178 end interface llt
179
180 interface repeat
181 module procedure repeat_
182 end interface repeat
183
184 interface scan
185 module procedure scan_vs_vs
186 module procedure scan_ch_vs
187 module procedure scan_vs_ch
188 end interface scan
189
190 interface trim
191 module procedure trim_
192 end interface trim
193
194 interface verify
195 module procedure verify_vs_vs
196 module procedure verify_ch_vs
197 module procedure verify_vs_ch
198 end interface verify
199
200 interface var_str
201 module procedure var_str_
202 module procedure var_str_c_ptr
203 end interface var_str
204
205 interface get
206 module procedure get_
207 module procedure get_unit
208 module procedure get_set_vs
209 module procedure get_set_ch
210 module procedure get_unit_set_vs
211 module procedure get_unit_set_ch
212 end interface get
213
214 interface put
215 module procedure put_vs
216 module procedure put_ch
217 module procedure put_unit_vs
218 module procedure put_unit_ch
219 end interface put
220
221 interface put_line
222 module procedure put_line_vs
223 module procedure put_line_ch
224 module procedure put_line_unit_vs
225 module procedure put_line_unit_ch
226 end interface put_line
227
228 interface extract
229 module procedure extract_vs
230 module procedure extract_ch
231 end interface extract
232
233 interface insert
234 module procedure insert_vs_vs
235 module procedure insert_ch_vs
236 module procedure insert_vs_ch
237 module procedure insert_ch_ch
238 end interface insert
239
240 interface remove
241 module procedure remove_vs
242 module procedure remove_ch
243 end interface remove
244
245 interface replace
246 module procedure replace_vs_vs_auto
247 module procedure replace_ch_vs_auto
248 module procedure replace_vs_ch_auto
249 module procedure replace_ch_ch_auto
250 module procedure replace_vs_vs_fixed
251 module procedure replace_ch_vs_fixed
252 module procedure replace_vs_ch_fixed
253 module procedure replace_ch_ch_fixed
254 module procedure replace_vs_vs_vs_target
255 module procedure replace_ch_vs_vs_target
256 module procedure replace_vs_ch_vs_target
257 module procedure replace_ch_ch_vs_target
258 module procedure replace_vs_vs_ch_target
259 module procedure replace_ch_vs_ch_target
260 module procedure replace_vs_ch_ch_target
261 module procedure replace_ch_ch_ch_target
262 end interface
263
264 interface split
265 module procedure split_vs
266 module procedure split_ch
267 end interface split
268
269 interface c_ptr_new
270 module procedure c_ptr_new_vs
271 end interface c_ptr_new
272
273
274! Access specifiers
275
276 public :: assignment(=)
277 public :: operator(//)
278 public :: operator(==)
279 public :: operator(/=)
280 public :: operator(<)
281 public :: operator(<=)
282 public :: operator(>=)
283 public :: operator(>)
284 public :: adjustl
285 public :: adjustr
286 public :: char
287 public :: iachar
288 public :: ichar
289 public :: index
290 public :: len
291 public :: len_trim
292 public :: lge
293 public :: lgt
294 public :: lle
295 public :: llt
296 public :: repeat
297 public :: scan
298 public :: trim
299 public :: verify
300 public :: var_str
301 public :: get
302 public :: put
303 public :: put_line
304 public :: extract
305 public :: insert
306 public :: remove
307 public :: replace
308 public :: split
309
310 private :: op_assign_ch_vs
311 private :: op_assign_vs_ch
312 private :: op_concat_vs_vs
313 private :: op_concat_ch_vs
314 private :: op_concat_vs_ch
315 private :: op_eq_vs_vs
316 private :: op_eq_ch_vs
317 private :: op_eq_vs_ch
318 private :: op_ne_vs_vs
319 private :: op_ne_ch_vs
320 private :: op_ne_vs_ch
321 private :: op_lt_vs_vs
322 private :: op_lt_ch_vs
323 private :: op_lt_vs_ch
324 private :: op_le_vs_vs
325 private :: op_le_ch_vs
326 private :: op_le_vs_ch
327 private :: op_ge_vs_vs
328 private :: op_ge_ch_vs
329 private :: op_ge_vs_ch
330 private :: op_gt_vs_vs
331 private :: op_gt_ch_vs
332 private :: op_gt_vs_ch
333 private :: adjustl_
334 private :: adjustr_
335 private :: char_auto
336 private :: char_fixed
337 private :: iachar_
338 private :: ichar_
339 private :: index_vs_vs
340 private :: index_ch_vs
341 private :: index_vs_ch
342 private :: len_
343 private :: len_trim_
344 private :: lge_vs_vs
345 private :: lge_ch_vs
346 private :: lge_vs_ch
347 private :: lgt_vs_vs
348 private :: lgt_ch_vs
349 private :: lgt_vs_ch
350 private :: lle_vs_vs
351 private :: lle_ch_vs
352 private :: lle_vs_ch
353 private :: llt_vs_vs
354 private :: llt_ch_vs
355 private :: llt_vs_ch
356 private :: repeat_
357 private :: scan_vs_vs
358 private :: scan_ch_vs
359 private :: scan_vs_ch
360 private :: trim_
361 private :: verify_vs_vs
362 private :: verify_ch_vs
363 private :: verify_vs_ch
364 private :: var_str_
365 private :: var_str_c_ptr
366 private :: get_
367 private :: get_unit
368 private :: get_set_vs
369 private :: get_set_ch
370 private :: get_unit_set_vs
371 private :: get_unit_set_ch
372 private :: put_vs
373 private :: put_ch
374 private :: put_unit_vs
375 private :: put_unit_ch
376 private :: put_line_vs
377 private :: put_line_ch
378 private :: put_line_unit_vs
379 private :: put_line_unit_ch
380 private :: extract_vs
381 private :: extract_ch
382 private :: insert_vs_vs
383 private :: insert_ch_vs
384 private :: insert_vs_ch
385 private :: insert_ch_ch
386 private :: remove_vs
387 private :: remove_ch
388 private :: replace_vs_vs_auto
389 private :: replace_ch_vs_auto
390 private :: replace_vs_ch_auto
391 private :: replace_ch_ch_auto
392 private :: replace_vs_vs_fixed
393 private :: replace_ch_vs_fixed
394 private :: replace_vs_ch_fixed
395 private :: replace_ch_ch_fixed
396 private :: replace_vs_vs_vs_target
397 private :: replace_ch_vs_vs_target
398 private :: replace_vs_ch_vs_target
399 private :: replace_ch_ch_vs_target
400 private :: replace_vs_vs_ch_target
401 private :: replace_ch_vs_ch_target
402 private :: replace_vs_ch_ch_target
403 private :: replace_ch_ch_ch_target
404 private :: split_vs
405 private :: split_ch
406
407! Procedures
408
409contains
410
411!****
412
413 elemental subroutine op_assign_ch_vs (var, exp)
414
415 character(LEN=*), intent(out) :: var
416 type(varying_string), intent(in) :: exp
417
418! Assign a varying string to a character string
419
420 var = char(exp)
421
422! Finish
423
424 return
425
426 end subroutine op_assign_ch_vs
427
428!****
429
430 elemental subroutine op_assign_vs_ch (var, exp)
431
432 type(varying_string), intent(out) :: var
433 character(LEN=*), intent(in) :: exp
434
435! Assign a character string to a varying string
436
437 var = var_str(exp)
438
439! Finish
440
441 return
442
443 end subroutine op_assign_vs_ch
444
445!****
446
447 elemental function op_concat_vs_vs (string_a, string_b) result (concat_string)
448
449 type(varying_string), intent(in) :: string_a
450 type(varying_string), intent(in) :: string_b
451 type(varying_string) :: concat_string
452
453 integer :: len_string_a
454
455! Concatenate two varying strings
456
457 len_string_a = len(string_a)
458
459 ALLOCATE(concat_string%chars(len_string_a+len(string_b)+1))
460 concat_string%chars(:len_string_a) = string_a%chars(:len_string_a)
461 concat_string%chars(len_string_a+1:) = string_b%chars(:)
462
463
464! Finish
465
466 return
467
468 end function op_concat_vs_vs
469
470!****
471
472 elemental function op_concat_ch_vs (string_a, string_b) result (concat_string)
473
474 character(LEN=*), intent(in) :: string_a
475 type(varying_string), intent(in) :: string_b
476 type(varying_string) :: concat_string
477
478! Concatenate a character string and a varying
479! string
480
481 concat_string = op_concat_vs_vs(var_str(string_a), string_b)
482
483! Finish
484
485 return
486
487 end function op_concat_ch_vs
488
489!****
490
491 elemental function op_concat_vs_ch (string_a, string_b) result (concat_string)
492
493 type(varying_string), intent(in) :: string_a
494 character(LEN=*), intent(in) :: string_b
495 type(varying_string) :: concat_string
496
497! Concatenate a varying string and a character
498! string
499
500 concat_string = op_concat_vs_vs(string_a, var_str(string_b))
501
502! Finish
503
504 return
505
506 end function op_concat_vs_ch
507
508!****
509
510 elemental function op_eq_vs_vs (string_a, string_b) result (op_eq)
511
512 type(varying_string), intent(in) :: string_a
513 type(varying_string), intent(in) :: string_b
514 logical :: op_eq
515
516! Compare (==) two varying strings
517
518 op_eq = char(string_a) == char(string_b)
519
520! Finish
521
522 return
523
524 end function op_eq_vs_vs
525
526!****
527
528 elemental function op_eq_ch_vs (string_a, string_b) result (op_eq)
529
530 character(LEN=*), intent(in) :: string_a
531 type(varying_string), intent(in) :: string_b
532 logical :: op_eq
533
534! Compare (==) a character string and a varying
535! string
536
537 op_eq = string_a == char(string_b)
538
539! Finish
540
541 return
542
543 end function op_eq_ch_vs
544
545!****
546
547 elemental function op_eq_vs_ch (string_a, string_b) result (op_eq)
548
549 type(varying_string), intent(in) :: string_a
550 character(LEN=*), intent(in) :: string_b
551 logical :: op_eq
552
553! Compare (==) a varying string and a character
554! string
555
556 op_eq = char(string_a) == string_b
557
558! Finish
559
560 return
561
562 end function op_eq_vs_ch
563
564!****
565
566 elemental function op_ne_vs_vs (string_a, string_b) result (op_ne)
567
568 type(varying_string), intent(in) :: string_a
569 type(varying_string), intent(in) :: string_b
570 logical :: op_ne
571
572! Compare (/=) two varying strings
573
574 op_ne = char(string_a) /= char(string_b)
575
576! Finish
577
578 return
579
580 end function op_ne_vs_vs
581
582!****
583
584 elemental function op_ne_ch_vs (string_a, string_b) result (op_ne)
585
586 character(LEN=*), intent(in) :: string_a
587 type(varying_string), intent(in) :: string_b
588 logical :: op_ne
589
590! Compare (/=) a character string and a varying
591! string
592
593 op_ne = string_a /= char(string_b)
594
595! Finish
596
597 return
598
599 end function op_ne_ch_vs
600
601!****
602
603 elemental function op_ne_vs_ch (string_a, string_b) result (op_ne)
604
605 type(varying_string), intent(in) :: string_a
606 character(LEN=*), intent(in) :: string_b
607 logical :: op_ne
608
609! Compare (/=) a varying string and a character
610! string
611
612 op_ne = char(string_a) /= string_b
613
614! Finish
615
616 return
617
618 end function op_ne_vs_ch
619
620!****
621
622 elemental function op_lt_vs_vs (string_a, string_b) result (op_lt)
623
624 type(varying_string), intent(in) :: string_a
625 type(varying_string), intent(in) :: string_b
626 logical :: op_lt
627
628! Compare (<) two varying strings
629
630 op_lt = char(string_a) < char(string_b)
631
632! Finish
633
634 return
635
636 end function op_lt_vs_vs
637
638!****
639
640 elemental function op_lt_ch_vs (string_a, string_b) result (op_lt)
641
642 character(LEN=*), intent(in) :: string_a
643 type(varying_string), intent(in) :: string_b
644 logical :: op_lt
645
646! Compare (<) a character string and a varying
647! string
648
649 op_lt = string_a < char(string_b)
650
651! Finish
652
653 return
654
655 end function op_lt_ch_vs
656
657!****
658
659 elemental function op_lt_vs_ch (string_a, string_b) result (op_lt)
660
661 type(varying_string), intent(in) :: string_a
662 character(LEN=*), intent(in) :: string_b
663 logical :: op_lt
664
665! Compare (<) a varying string and a character
666! string
667
668 op_lt = char(string_a) < string_b
669
670! Finish
671
672 return
673
674 end function op_lt_vs_ch
675
676!****
677
678 elemental function op_le_vs_vs (string_a, string_b) result (op_le)
679
680 type(varying_string), intent(in) :: string_a
681 type(varying_string), intent(in) :: string_b
682 logical :: op_le
683
684! Compare (<=) two varying strings
685
686 op_le = char(string_a) <= char(string_b)
687
688! Finish
689
690 return
691
692 end function op_le_vs_vs
693
694!****
695
696 elemental function op_le_ch_vs (string_a, string_b) result (op_le)
697
698 character(LEN=*), intent(in) :: string_a
699 type(varying_string), intent(in) :: string_b
700 logical :: op_le
701
702! Compare (<=) a character string and a varying
703! string
704
705 op_le = string_a <= char(string_b)
706
707! Finish
708
709 return
710
711 end function op_le_ch_vs
712
713!****
714
715 elemental function op_le_vs_ch (string_a, string_b) result (op_le)
716
717 type(varying_string), intent(in) :: string_a
718 character(LEN=*), intent(in) :: string_b
719 logical :: op_le
720
721! Compare (<=) a varying string and a character
722! string
723
724 op_le = char(string_a) <= string_b
725
726! Finish
727
728 return
729
730 end function op_le_vs_ch
731
732!****
733
734 elemental function op_ge_vs_vs (string_a, string_b) result (op_ge)
735
736 type(varying_string), intent(in) :: string_a
737 type(varying_string), intent(in) :: string_b
738 logical :: op_ge
739
740! Compare (>=) two varying strings
741
742 op_ge = char(string_a) >= char(string_b)
743
744! Finish
745
746 return
747
748 end function op_ge_vs_vs
749
750!****
751
752 elemental function op_ge_ch_vs (string_a, string_b) result (op_ge)
753
754 character(LEN=*), intent(in) :: string_a
755 type(varying_string), intent(in) :: string_b
756 logical :: op_ge
757
758! Compare (>=) a character string and a varying
759! string
760
761 op_ge = string_a >= char(string_b)
762
763! Finish
764
765 return
766
767 end function op_ge_ch_vs
768
769!****
770
771 elemental function op_ge_vs_ch (string_a, string_b) result (op_ge)
772
773 type(varying_string), intent(in) :: string_a
774 character(LEN=*), intent(in) :: string_b
775 logical :: op_ge
776
777! Compare (>=) a varying string and a character
778! string
779
780 op_ge = char(string_a) >= string_b
781
782! Finish
783
784 return
785
786 end function op_ge_vs_ch
787
788!****
789
790 elemental function op_gt_vs_vs (string_a, string_b) result (op_gt)
791
792 type(varying_string), intent(in) :: string_a
793 type(varying_string), intent(in) :: string_b
794 logical :: op_gt
795
796! Compare (>) two varying strings
797
798 op_gt = char(string_a) > char(string_b)
799
800! Finish
801
802 return
803
804 end function op_gt_vs_vs
805
806!****
807
808 elemental function op_gt_ch_vs (string_a, string_b) result (op_gt)
809
810 character(LEN=*), intent(in) :: string_a
811 type(varying_string), intent(in) :: string_b
812 logical :: op_gt
813
814! Compare (>) a character string and a varying
815! string
816
817 op_gt = string_a > char(string_b)
818
819! Finish
820
821 return
822
823 end function op_gt_ch_vs
824
825!****
826
827 elemental function op_gt_vs_ch (string_a, string_b) result (op_gt)
828
829 type(varying_string), intent(in) :: string_a
830 character(LEN=*), intent(in) :: string_b
831 logical :: op_gt
832
833! Compare (>) a varying string and a character
834! string
835
836 op_gt = char(string_a) > string_b
837
838! Finish
839
840 return
841
842 end function op_gt_vs_ch
843
844!****
845
846 elemental function adjustl_ (string) result (adjustl_string)
847
848 type(varying_string), intent(in) :: string
849 type(varying_string) :: adjustl_string
850
851! Adjust the varying string to the left
852
853 adjustl_string = adjustl(char(string))
854
855! Finish
856
857 return
858
859 end function adjustl_
860
861!****
862
863 elemental function adjustr_ (string) result (adjustr_string)
864
865 type(varying_string), intent(in) :: string
866 type(varying_string) :: adjustr_string
867
868! Adjust the varying string to the right
869
870 adjustr_string = adjustr(char(string))
871
872! Finish
873
874 return
875
876 end function adjustr_
877
878!****
879
880 pure function char_auto (string) result (char_string)
881
882 type(varying_string), intent(in) :: string
883 character(LEN=len(string)) :: char_string
884
885 integer :: i_char
886
887! Convert a varying string into a character string
888! (automatic length)
889
890 forall(i_char = 1:len(string))
891 char_string(i_char:i_char) = string%chars(i_char)
892 end forall
893
894! Finish
895
896 return
897
898 end function char_auto
899
900!****
901
902 pure function char_fixed (string, length) result (char_string)
903
904 type(varying_string), intent(in) :: string
905 integer, intent(in) :: length
906 character(LEN=length) :: char_string
907
908! Convert a varying string into a character string
909! (fixed length)
910
911 char_string = char(string)
912
913! Finish
914
915 return
916
917 end function char_fixed
918
919!****
920
921 elemental function iachar_ (c) result (i)
922
923 type(varying_string), intent(in) :: c
924 integer :: i
925
926! Get the position in the ISO 646 collating sequence
927! of a varying string character
928
929 i = ichar(char(c))
930
931! Finish
932
933 return
934
935 end function iachar_
936
937!****
938
939 elemental function ichar_ (c) result (i)
940
941 type(varying_string), intent(in) :: c
942 integer :: i
943
944! Get the position in the processor collating
945! sequence of a varying string character
946
947 i = ichar(char(c))
948
949! Finish
950
951 return
952
953 end function ichar_
954
955!****
956
957 elemental function index_vs_vs (string, substring, back) result (i_substring)
958
959 type(varying_string), intent(in) :: string
960 type(varying_string), intent(in) :: substring
961 logical, intent(in), optional :: back
962 integer :: i_substring
963
964! Get the index of a varying substring within a
965! varying string
966
967 i_substring = index(char(string), char(substring), back)
968
969! Finish
970
971 return
972
973 end function index_vs_vs
974
975!****
976
977 elemental function index_ch_vs (string, substring, back) result (i_substring)
978
979 character(LEN=*), intent(in) :: string
980 type(varying_string), intent(in) :: substring
981 logical, intent(in), optional :: back
982 integer :: i_substring
983
984! Get the index of a varying substring within a
985! character string
986
987 i_substring = index(string, char(substring), back)
988
989! Finish
990
991 return
992
993 end function index_ch_vs
994
995!****
996
997 elemental function index_vs_ch (string, substring, back) result (i_substring)
998
999 type(varying_string), intent(in) :: string
1000 character(LEN=*), intent(in) :: substring
1001 logical, intent(in), optional :: back
1002 integer :: i_substring
1003
1004! Get the index of a character substring within a
1005! varying string
1006
1007 i_substring = index(char(string), substring, back)
1008
1009! Finish
1010
1011 return
1012
1013 end function index_vs_ch
1014
1015!****
1016
1017 elemental function len_ (string) result (length)
1018
1019 type(varying_string), intent(in) :: string
1020 integer :: length
1021
1022! Get the length of a varying string
1023
1024 if(ALLOCATED(string%chars)) then
1025 length = SIZE(string%chars)-1
1026 else
1027 length = 0
1028 endif
1029
1030! Finish
1031
1032 return
1033
1034 end function len_
1035
1036!****
1037
1038 elemental function len_trim_ (string) result (length)
1039
1040 type(varying_string), intent(in) :: string
1041 integer :: length
1042
1043! Get the trimmed length of a varying string
1044
1045 if(ALLOCATED(string%chars)) then
1046 length = len_trim(char(string))
1047 else
1048 length = 0
1049 endif
1050
1051! Finish
1052
1053 return
1054
1055 end function len_trim_
1056
1057!****
1058
1059 elemental function lge_vs_vs (string_a, string_b) result (comp)
1060
1061 type(varying_string), intent(in) :: string_a
1062 type(varying_string), intent(in) :: string_b
1063 logical :: comp
1064
1065! Compare (LGE) two varying strings
1066
1067 comp = (char(string_a) >= char(string_b))
1068
1069! Finish
1070
1071 return
1072
1073 end function lge_vs_vs
1074
1075!****
1076
1077 elemental function lge_ch_vs (string_a, string_b) result (comp)
1078
1079 character(LEN=*), intent(in) :: string_a
1080 type(varying_string), intent(in) :: string_b
1081 logical :: comp
1082
1083! Compare (LGE) a character string and a varying
1084! string
1085
1086 comp = (string_a >= char(string_b))
1087
1088! Finish
1089
1090 return
1091
1092 end function lge_ch_vs
1093
1094!****
1095
1096 elemental function lge_vs_ch (string_a, string_b) result (comp)
1097
1098 type(varying_string), intent(in) :: string_a
1099 character(LEN=*), intent(in) :: string_b
1100 logical :: comp
1101
1102! Compare (LGE) a varying string and a character
1103! string
1104
1105 comp = (char(string_a) >= string_b)
1106
1107! Finish
1108
1109 return
1110
1111 end function lge_vs_ch
1112
1113!****
1114
1115 elemental function lgt_vs_vs (string_a, string_b) result (comp)
1116
1117 type(varying_string), intent(in) :: string_a
1118 type(varying_string), intent(in) :: string_b
1119 logical :: comp
1120
1121! Compare (LGT) two varying strings
1122
1123 comp = (char(string_a) > char(string_b))
1124
1125! Finish
1126
1127 return
1128
1129 end function lgt_vs_vs
1130
1131!****
1132
1133 elemental function lgt_ch_vs (string_a, string_b) result (comp)
1134
1135 character(LEN=*), intent(in) :: string_a
1136 type(varying_string), intent(in) :: string_b
1137 logical :: comp
1138
1139! Compare (LGT) a character string and a varying
1140! string
1141
1142 comp = (string_a > char(string_b))
1143
1144! Finish
1145
1146 return
1147
1148 end function lgt_ch_vs
1149
1150!****
1151
1152 elemental function lgt_vs_ch (string_a, string_b) result (comp)
1153
1154 type(varying_string), intent(in) :: string_a
1155 character(LEN=*), intent(in) :: string_b
1156 logical :: comp
1157
1158! Compare (LGT) a varying string and a character
1159! string
1160
1161 comp = (char(string_a) > string_b)
1162
1163! Finish
1164
1165 return
1166
1167 end function lgt_vs_ch
1168
1169!****
1170
1171 elemental function lle_vs_vs (string_a, string_b) result (comp)
1172
1173 type(varying_string), intent(in) :: string_a
1174 type(varying_string), intent(in) :: string_b
1175 logical :: comp
1176
1177! Compare (LLE) two varying strings
1178
1179 comp = (char(string_a) <= char(string_b))
1180
1181! Finish
1182
1183 return
1184
1185 end function lle_vs_vs
1186
1187!****
1188
1189 elemental function lle_ch_vs (string_a, string_b) result (comp)
1190
1191 character(LEN=*), intent(in) :: string_a
1192 type(varying_string), intent(in) :: string_b
1193 logical :: comp
1194
1195! Compare (LLE) a character string and a varying
1196! string
1197
1198 comp = (string_a <= char(string_b))
1199
1200! Finish
1201
1202 return
1203
1204 end function lle_ch_vs
1205
1206!****
1207
1208 elemental function lle_vs_ch (string_a, string_b) result (comp)
1209
1210 type(varying_string), intent(in) :: string_a
1211 character(LEN=*), intent(in) :: string_b
1212 logical :: comp
1213
1214! Compare (LLE) a varying string and a character
1215! string
1216
1217 comp = (char(string_a) <= string_b)
1218
1219! Finish
1220
1221 return
1222
1223 end function lle_vs_ch
1224
1225!****
1226
1227 elemental function llt_vs_vs (string_a, string_b) result (comp)
1228
1229 type(varying_string), intent(in) :: string_a
1230 type(varying_string), intent(in) :: string_b
1231 logical :: comp
1232
1233! Compare (LLT) two varying strings
1234
1235 comp = (char(string_a) < char(string_b))
1236
1237! Finish
1238
1239 return
1240
1241 end function llt_vs_vs
1242
1243!****
1244
1245 elemental function llt_ch_vs (string_a, string_b) result (comp)
1246
1247 character(LEN=*), intent(in) :: string_a
1248 type(varying_string), intent(in) :: string_b
1249 logical :: comp
1250
1251! Compare (LLT) a character string and a varying
1252! string
1253
1254 comp = (string_a < char(string_b))
1255
1256! Finish
1257
1258 return
1259
1260 end function llt_ch_vs
1261
1262!****
1263
1264 elemental function llt_vs_ch (string_a, string_b) result (comp)
1265
1266 type(varying_string), intent(in) :: string_a
1267 character(LEN=*), intent(in) :: string_b
1268 logical :: comp
1269
1270! Compare (LLT) a varying string and a character
1271! string
1272
1273 comp = (char(string_a) < string_b)
1274
1275! Finish
1276
1277 return
1278
1279 end function llt_vs_ch
1280
1281!****
1282
1283 elemental function repeat_ (string, ncopies) result (repeat_string)
1284
1285 type(varying_string), intent(in) :: string
1286 integer, intent(in) :: ncopies
1287 type(varying_string) :: repeat_string
1288
1289! Concatenate several copies of a varying string
1290
1291 repeat_string = var_str(repeat(char(string), ncopies))
1292
1293! Finish
1294
1295 return
1296
1297 end function repeat_
1298
1299!****
1300
1301 elemental function scan_vs_vs (string, set, back) result (i)
1302
1303 type(varying_string), intent(in) :: string
1304 type(varying_string), intent(in) :: set
1305 logical, intent(in), optional :: back
1306 integer :: i
1307
1308! Scan a varying string for occurrences of
1309! characters in a varying-string set
1310
1311 i = scan(char(string), char(set), back)
1312
1313! Finish
1314
1315 return
1316
1317 end function scan_vs_vs
1318
1319!****
1320
1321 elemental function scan_ch_vs (string, set, back) result (i)
1322
1323 character(LEN=*), intent(in) :: string
1324 type(varying_string), intent(in) :: set
1325 logical, intent(in), optional :: back
1326 integer :: i
1327
1328! Scan a character string for occurrences of
1329! characters in a varying-string set
1330
1331 i = scan(string, char(set), back)
1332
1333! Finish
1334
1335 return
1336
1337 end function scan_ch_vs
1338
1339!****
1340
1341 elemental function scan_vs_ch (string, set, back) result (i)
1342
1343 type(varying_string), intent(in) :: string
1344 character(LEN=*), intent(in) :: set
1345 logical, intent(in), optional :: back
1346 integer :: i
1347
1348! Scan a varying string for occurrences of
1349! characters in a character-string set
1350
1351 i = scan(char(string), set, back)
1352
1353! Finish
1354
1355 return
1356
1357 end function scan_vs_ch
1358
1359!****
1360
1361 elemental function trim_ (string) result (trim_string)
1362
1363 type(varying_string), intent(in) :: string
1364 type(varying_string) :: trim_string
1365
1366! Remove trailing blanks from a varying string
1367
1368 trim_string = trim(char(string))
1369
1370! Finish
1371
1372 return
1373
1374 end function trim_
1375
1376!****
1377
1378 elemental function verify_vs_vs (string, set, back) result (i)
1379
1380 type(varying_string), intent(in) :: string
1381 type(varying_string), intent(in) :: set
1382 logical, intent(in), optional :: back
1383 integer :: i
1384
1385! Verify a varying string for occurrences of
1386! characters in a varying-string set
1387
1388 i = verify(char(string), char(set), back)
1389
1390! Finish
1391
1392 return
1393
1394 end function verify_vs_vs
1395
1396!****
1397
1398 elemental function verify_ch_vs (string, set, back) result (i)
1399
1400 character(LEN=*), intent(in) :: string
1401 type(varying_string), intent(in) :: set
1402 logical, intent(in), optional :: back
1403 integer :: i
1404
1405! Verify a character string for occurrences of
1406! characters in a varying-string set
1407
1408 i = verify(string, char(set), back)
1409
1410! Finish
1411
1412 return
1413
1414 end function verify_ch_vs
1415
1416!****
1417
1418 elemental function verify_vs_ch (string, set, back) result (i)
1419
1420 type(varying_string), intent(in) :: string
1421 character(LEN=*), intent(in) :: set
1422 logical, intent(in), optional :: back
1423 integer :: i
1424
1425! Verify a varying string for occurrences of
1426! characters in a character-string set
1427
1428 i = verify(char(string), set, back)
1429
1430! Finish
1431
1432 return
1433
1434 end function verify_vs_ch
1435
1436!****
1437
1438 elemental function var_str_ (char_) result (string)
1439
1440 character(LEN=*), intent(in) :: char_
1441 type(varying_string) :: string
1442
1443 integer :: length
1444 integer :: i_char
1445
1446! Convert a character string to a varying string
1447
1448 length = len(char_)
1449
1450 ALLOCATE(string%chars(length+1))
1451
1452 forall(i_char = 1:length)
1453 string%chars(i_char) = char_(i_char:i_char)
1454 end forall
1455 string%chars(length+1) = char(0)
1456
1457! Finish
1458
1459 return
1460
1461 end function var_str_
1462
1463!****
1464
1465 function var_str_c_ptr (char_c_ptr) result (string)
1466
1467 type(c_ptr), intent(in) :: char_c_ptr
1468 type(varying_string) :: string
1469
1470 CHARACTER(len=1),pointer :: char_(:)
1471 INTEGER :: length
1472
1473! Convert a character string to a varying string
1474
1475 IF (c_associated(char_c_ptr)) THEN
1476
1477 CALL c_f_pointer(char_c_ptr, char_, (/huge(1)-1/))
1478
1479 DO length = 1, SIZE(char_)
1480 IF (char_(length) == char(0)) EXIT
1481 ENDDO
1482
1483 ALLOCATE(string%chars(length))
1484 string%chars(:) = char_(1:length)
1485 string%chars(length) = char(0) ! handle absurdus HUGE() case
1486
1487 ELSE
1488
1489 string = var_str('')
1490
1491 ENDIF
1492
1493! Finish
1494
1495 return
1496
1497 end function var_str_c_ptr
1498
1499!****
1500
1501 subroutine get_ (string, maxlen, iostat)
1502
1503 type(varying_string), intent(out) :: string
1504 integer, intent(in), optional :: maxlen
1505 integer, intent(out), optional :: iostat
1506
1507 integer :: n_chars_remain
1508 integer :: n_chars_read
1509 character(LEN=GET_BUFFER_LEN) :: buffer
1510 integer :: local_iostat
1511
1512! Read from the default unit into a varying string
1513
1514 string = ""
1515
1516 if(PRESENT(maxlen)) then
1517 n_chars_remain = maxlen
1518 else
1519 n_chars_remain = huge(1)
1520 endif
1521
1522 read_loop : do
1523
1524 if(n_chars_remain <= 0) return
1525
1526 n_chars_read = min(n_chars_remain, get_buffer_len)
1527
1528 if(PRESENT(iostat)) then
1529 read(unit=*, fmt="(A)", advance="NO", &
1530 iostat=iostat, size=n_chars_read) buffer(:n_chars_read)
1531 if(iostat < 0) exit read_loop
1532 if(iostat > 0) return
1533 else
1534 read(unit=*, fmt="(A)", advance="NO", &
1535 iostat=local_iostat, size=n_chars_read) buffer(:n_chars_read)
1536 if(local_iostat < 0) exit read_loop
1537 endif
1538
1539 string = string//buffer(:n_chars_read)
1540 n_chars_remain = n_chars_remain - n_chars_read
1541
1542 end do read_loop
1543
1544 string = string//buffer(:n_chars_read)
1545
1546! Finish (end-of-record)
1547
1548 return
1549
1550 end subroutine get_
1551
1552!****
1553
1554 subroutine get_unit (unit, string, maxlen, iostat)
1555
1556 integer, intent(in) :: unit
1557 type(varying_string), intent(out) :: string
1558 integer, intent(in), optional :: maxlen
1559 integer, intent(out), optional :: iostat
1560
1561 integer :: n_chars_remain
1562 integer :: n_chars_read
1563 character(LEN=GET_BUFFER_LEN) :: buffer
1564 integer :: local_iostat
1565
1566! Read from the specified unit into a varying string
1567
1568 string = ""
1569
1570 if(PRESENT(maxlen)) then
1571 n_chars_remain = maxlen
1572 else
1573 n_chars_remain = huge(1)
1574 endif
1575
1576 read_loop : do
1577
1578 if(n_chars_remain <= 0) return
1579
1580 n_chars_read = min(n_chars_remain, get_buffer_len)
1581
1582 if(PRESENT(iostat)) then
1583 read(unit=unit, fmt="(A)", advance="NO", &
1584 iostat=iostat, size=n_chars_read) buffer(:n_chars_read)
1585 if(iostat < 0) exit read_loop
1586 if(iostat > 0) return
1587 else
1588 read(unit=unit, fmt="(A)", advance="NO", &
1589 iostat=local_iostat, size=n_chars_read) buffer(:n_chars_read)
1590 if(local_iostat < 0) exit read_loop
1591 endif
1592
1593 string = string//buffer(:n_chars_read)
1594 n_chars_remain = n_chars_remain - n_chars_read
1595
1596 end do read_loop
1597
1598 string = string//buffer(:n_chars_read)
1599
1600! Finish (end-of-record)
1601
1602 return
1603
1604 end subroutine get_unit
1605
1606!****
1607
1608 subroutine get_set_vs (string, set, separator, maxlen, iostat)
1609
1610 type(varying_string), intent(out) :: string
1611 type(varying_string), intent(in) :: set
1612 type(varying_string), intent(out), optional :: separator
1613 integer, intent(in), optional :: maxlen
1614 integer, intent(out), optional :: iostat
1615
1616! Read from the default unit into a varying string,
1617! with a custom varying-string separator
1618
1619 call get(string, char(set), separator, maxlen, iostat)
1620
1621! Finish
1622
1623 return
1624
1625 end subroutine get_set_vs
1626
1627!****
1628
1629 subroutine get_set_ch (string, set, separator, maxlen, iostat)
1630
1631 type(varying_string), intent(out) :: string
1632 character(LEN=*), intent(in) :: set
1633 type(varying_string), intent(out), optional :: separator
1634 integer, intent(in), optional :: maxlen
1635 integer, intent(out), optional :: iostat
1636
1637 integer :: n_chars_remain
1638 character(LEN=1) :: buffer
1639 integer :: i_set
1640 integer :: local_iostat
1641
1642! Read from the default unit into a varying string,
1643! with a custom character-string separator
1644
1645 string = ""
1646
1647 if(PRESENT(maxlen)) then
1648 n_chars_remain = maxlen
1649 else
1650 n_chars_remain = huge(1)
1651 endif
1652
1653 if(PRESENT(separator)) separator = ""
1654
1655 read_loop : do
1656
1657 if(n_chars_remain <= 0) return
1658
1659 if(PRESENT(iostat)) then
1660 read(unit=*, fmt="(A1)", advance="NO", iostat=iostat) buffer
1661 if(iostat /= 0) exit read_loop
1662 else
1663 read(unit=*, fmt="(A1)", advance="NO", iostat=local_iostat) buffer
1664 if(local_iostat /= 0) exit read_loop
1665 endif
1666
1667 i_set = scan(buffer, set)
1668
1669 if(i_set == 1) then
1670 if(PRESENT(separator)) separator = buffer
1671 exit read_loop
1672 endif
1673
1674 string = string//buffer
1675 n_chars_remain = n_chars_remain - 1
1676
1677 end do read_loop
1678
1679! Finish
1680
1681 return
1682
1683 end subroutine get_set_ch
1684
1685!****
1686
1687 subroutine get_unit_set_vs (unit, string, set, separator, maxlen, iostat)
1688
1689 integer, intent(in) :: unit
1690 type(varying_string), intent(out) :: string
1691 type(varying_string), intent(in) :: set
1692 type(varying_string), intent(out), optional :: separator
1693 integer, intent(in), optional :: maxlen
1694 integer, intent(out), optional :: iostat
1695
1696! Read from the specified unit into a varying string,
1697! with a custom varying-string separator
1698
1699 call get(unit, string, char(set), separator, maxlen, iostat)
1700
1701! Finish
1702
1703 return
1704
1705 end subroutine get_unit_set_vs
1706
1707!****
1708
1709 subroutine get_unit_set_ch (unit, string, set, separator, maxlen, iostat)
1710
1711 integer, intent(in) :: unit
1712 type(varying_string), intent(out) :: string
1713 character(LEN=*), intent(in) :: set
1714 type(varying_string), intent(out), optional :: separator
1715 integer, intent(in), optional :: maxlen
1716 integer, intent(out), optional :: iostat
1717
1718 integer :: n_chars_remain
1719 character(LEN=1) :: buffer
1720 integer :: i_set
1721 integer :: local_iostat
1722
1723! Read from the default unit into a varying string,
1724! with a custom character-string separator
1725
1726 string = ""
1727
1728 if(PRESENT(maxlen)) then
1729 n_chars_remain = maxlen
1730 else
1731 n_chars_remain = huge(1)
1732 endif
1733
1734 if(PRESENT(separator)) separator = ""
1735
1736 read_loop : do
1737
1738 if(n_chars_remain <= 0) return
1739
1740 if(PRESENT(iostat)) then
1741 read(unit=unit, fmt="(A1)", advance="NO", iostat=iostat) buffer
1742 if(iostat /= 0) exit read_loop
1743 else
1744 read(unit=unit, fmt="(A1)", advance="NO", iostat=local_iostat) buffer
1745 if(local_iostat /= 0) exit read_loop
1746 endif
1747
1748 i_set = scan(buffer, set)
1749
1750 if(i_set == 1) then
1751 if(PRESENT(separator)) separator = buffer
1752 exit read_loop
1753 endif
1754
1755 string = string//buffer
1756 n_chars_remain = n_chars_remain - 1
1757
1758 end do read_loop
1759
1760! Finish
1761
1762 return
1763
1764 end subroutine get_unit_set_ch
1765
1766!****
1767
1768 subroutine put_vs (string, iostat)
1769
1770 type(varying_string), intent(in) :: string
1771 integer, intent(out), optional :: iostat
1772
1773! Append a varying string to the current record of
1774! the default unit
1775
1776 call put(char(string), iostat)
1777
1778! Finish
1779
1780 end subroutine put_vs
1781
1782!****
1783
1784 subroutine put_ch (string, iostat)
1785
1786 character(LEN=*), intent(in) :: string
1787 integer, intent(out), optional :: iostat
1788
1789! Append a character string to the current record of
1790! the default unit
1791
1792 if(PRESENT(iostat)) then
1793 write(unit=*, fmt="(A)", advance="NO", iostat=iostat) string
1794 else
1795 write(unit=*, fmt="(A)", advance="NO") string
1796 endif
1797
1798! Finish
1799
1800 end subroutine put_ch
1801
1802!****
1803
1804 subroutine put_unit_vs (unit, string, iostat)
1805
1806 integer, intent(in) :: unit
1807 type(varying_string), intent(in) :: string
1808 integer, intent(out), optional :: iostat
1809
1810! Append a varying string to the current record of
1811! the specified unit
1812
1813 call put(unit, char(string), iostat)
1814
1815! Finish
1816
1817 return
1818
1819 end subroutine put_unit_vs
1820
1821!****
1822
1823 subroutine put_unit_ch (unit, string, iostat)
1824
1825 integer, intent(in) :: unit
1826 character(LEN=*), intent(in) :: string
1827 integer, intent(out), optional :: iostat
1828
1829! Append a character string to the current record of
1830! the specified unit
1831
1832 if(PRESENT(iostat)) then
1833 write(unit=unit, fmt="(A)", advance="NO", iostat=iostat) string
1834 else
1835 write(unit=unit, fmt="(A)", advance="NO") string
1836 endif
1837
1838! Finish
1839
1840 return
1841
1842 end subroutine put_unit_ch
1843
1844!****
1845
1846 subroutine put_line_vs (string, iostat)
1847
1848 type(varying_string), intent(in) :: string
1849 integer, intent(out), optional :: iostat
1850
1851! Append a varying string to the current record of
1852! the default unit, terminating the record
1853
1854 call put_line(char(string), iostat)
1855
1856! Finish
1857
1858 return
1859
1860 end subroutine put_line_vs
1861
1862!****
1863
1864 subroutine put_line_ch (string, iostat)
1865
1866 character(LEN=*), intent(in) :: string
1867 integer, intent(out), optional :: iostat
1868
1869! Append a varying string to the current record of
1870! the default unit, terminating the record
1871
1872 if(PRESENT(iostat)) then
1873 write(unit=*, fmt="(A,/)", advance="NO", iostat=iostat) string
1874 else
1875 write(unit=*, fmt="(A,/)", advance="NO") string
1876 endif
1877
1878! Finish
1879
1880 return
1881
1882 end subroutine put_line_ch
1883
1884!****
1885
1886 subroutine put_line_unit_vs (unit, string, iostat)
1887
1888 integer, intent(in) :: unit
1889 type(varying_string), intent(in) :: string
1890 integer, intent(out), optional :: iostat
1891
1892! Append a varying string to the current record of
1893! the specified unit, terminating the record
1894
1895 call put_line(unit, char(string), iostat)
1896
1897! Finish
1898
1899 return
1900
1901 end subroutine put_line_unit_vs
1902
1903!****
1904
1905 subroutine put_line_unit_ch (unit, string, iostat)
1906
1907 integer, intent(in) :: unit
1908 character(LEN=*), intent(in) :: string
1909 integer, intent(out), optional :: iostat
1910
1911! Append a varying string to the current record of
1912! the specified unit, terminating the record
1913
1914 if(PRESENT(iostat)) then
1915 write(unit=unit, fmt="(A,/)", advance="NO", iostat=iostat) string
1916 else
1917 write(unit=unit, fmt="(A,/)", advance="NO") string
1918 endif
1919
1920! Finish
1921
1922 return
1923
1924 end subroutine put_line_unit_ch
1925
1926!****
1927
1928 elemental function extract_vs (string, start, finish) result (ext_string)
1929
1930 type(varying_string), intent(in) :: string
1931 integer, intent(in), optional :: start
1932 integer, intent(in), optional :: finish
1933 type(varying_string) :: ext_string
1934
1935! Extract a varying substring from a varying string
1936
1937 ext_string = extract(char(string), start, finish)
1938
1939! Finish
1940
1941 return
1942
1943 end function extract_vs
1944
1945!****
1946
1947 elemental function extract_ch (string, start, finish) result (ext_string)
1948
1949 character(LEN=*), intent(in) :: string
1950 integer, intent(in), optional :: start
1951 integer, intent(in), optional :: finish
1952 type(varying_string) :: ext_string
1953
1954 integer :: start_
1955 integer :: finish_
1956
1957! Extract a varying substring from a character string
1958
1959 if(PRESENT(start)) then
1960 start_ = max(1, start)
1961 else
1962 start_ = 1
1963 endif
1964
1965 if(PRESENT(finish)) then
1966 finish_ = min(len(string), finish)
1967 else
1968 finish_ = len(string)
1969 endif
1970
1971 ext_string = var_str(string(start_:finish_))
1972
1973! Finish
1974
1975 return
1976
1977 end function extract_ch
1978
1979!****
1980
1981 elemental function insert_vs_vs (string, start, substring) result (ins_string)
1982
1983 type(varying_string), intent(in) :: string
1984 integer, intent(in) :: start
1985 type(varying_string), intent(in) :: substring
1986 type(varying_string) :: ins_string
1987
1988! Insert a varying substring into a varying string
1989
1990 ins_string = insert(char(string), start, char(substring))
1991
1992! Finish
1993
1994 return
1995
1996 end function insert_vs_vs
1997
1998!****
1999
2000 elemental function insert_ch_vs (string, start, substring) result (ins_string)
2001
2002 character(LEN=*), intent(in) :: string
2003 integer, intent(in) :: start
2004 type(varying_string), intent(in) :: substring
2005 type(varying_string) :: ins_string
2006
2007! Insert a varying substring into a character string
2008
2009 ins_string = insert(string, start, char(substring))
2010
2011! Finish
2012
2013 return
2014
2015 end function insert_ch_vs
2016
2017!****
2018
2019 elemental function insert_vs_ch (string, start, substring) result (ins_string)
2020
2021 type(varying_string), intent(in) :: string
2022 integer, intent(in) :: start
2023 character(LEN=*), intent(in) :: substring
2024 type(varying_string) :: ins_string
2025
2026! Insert a character substring into a varying string
2027
2028 ins_string = insert(char(string), start, substring)
2029
2030! Finish
2031
2032 return
2033
2034 end function insert_vs_ch
2035
2036!****
2037
2038 elemental function insert_ch_ch (string, start, substring) result (ins_string)
2039
2040 character(LEN=*), intent(in) :: string
2041 integer, intent(in) :: start
2042 character(LEN=*), intent(in) :: substring
2043 type(varying_string) :: ins_string
2044
2045 integer :: start_
2046
2047! Insert a character substring into a character
2048! string
2049
2050 start_ = max(1, min(start, len(string)+1))
2051
2052 ins_string = var_str(string(:start_-1)//substring//string(start_:))
2053
2054! Finish
2055
2056 return
2057
2058 end function insert_ch_ch
2059
2060!****
2061
2062 elemental function remove_vs (string, start, finish) result (rem_string)
2063
2064 type(varying_string), intent(in) :: string
2065 integer, intent(in), optional :: start
2066 integer, intent(in), optional :: finish
2067 type(varying_string) :: rem_string
2068
2069! Remove a substring from a varying string
2070
2071 rem_string = remove(char(string), start, finish)
2072
2073! Finish
2074
2075 return
2076
2077 end function remove_vs
2078
2079!****
2080
2081 elemental function remove_ch (string, start, finish) result (rem_string)
2082
2083 character(LEN=*), intent(in) :: string
2084 integer, intent(in), optional :: start
2085 integer, intent(in), optional :: finish
2086 type(varying_string) :: rem_string
2087
2088 integer :: start_
2089 integer :: finish_
2090
2091! Remove a substring from a character string
2092
2093 if(PRESENT(start)) then
2094 start_ = max(1, start)
2095 else
2096 start_ = 1
2097 endif
2098
2099 if(PRESENT(finish)) then
2100 finish_ = min(len(string), finish)
2101 else
2102 finish_ = len(string)
2103 endif
2104
2105 if(finish_ >= start_) then
2106 rem_string = var_str(string(:start_-1)//string(finish_+1:))
2107 else
2108 rem_string = string
2109 endif
2110
2111! Finish
2112
2113 return
2114
2115 end function remove_ch
2116
2117!****
2118
2119 elemental function replace_vs_vs_auto (string, start, substring) result (rep_string)
2120
2121 type(varying_string), intent(in) :: string
2122 integer, intent(in) :: start
2123 type(varying_string), intent(in) :: substring
2124 type(varying_string) :: rep_string
2125
2126! Replace part of a varying string with a varying
2127! substring
2128
2129 rep_string = replace(char(string), start, max(start, 1)+len(substring)-1, char(substring))
2130
2131! Finish
2132
2133 return
2134
2135 end function replace_vs_vs_auto
2136
2137!****
2138
2139 elemental function replace_ch_vs_auto (string, start, substring) result (rep_string)
2140
2141 character(LEN=*), intent(in) :: string
2142 integer, intent(in) :: start
2143 type(varying_string), intent(in) :: substring
2144 type(varying_string) :: rep_string
2145
2146! Replace part of a character string with a varying
2147! substring
2148
2149 rep_string = replace(string, start, max(start, 1)+len(substring)-1, char(substring))
2150
2151! Finish
2152
2153 return
2154
2155 end function replace_ch_vs_auto
2156
2157!****
2158
2159 elemental function replace_vs_ch_auto (string, start, substring) result (rep_string)
2160
2161 type(varying_string), intent(in) :: string
2162 integer, intent(in) :: start
2163 character(LEN=*), intent(in) :: substring
2164 type(varying_string) :: rep_string
2165
2166! Replace part of a varying string with a character
2167! substring
2168
2169 rep_string = replace(char(string), start, max(start, 1)+len(substring)-1, substring)
2170
2171! Finish
2172
2173 return
2174
2175 end function replace_vs_ch_auto
2176
2177!****
2178
2179 elemental function replace_ch_ch_auto (string, start, substring) result (rep_string)
2180
2181 character(LEN=*), intent(in) :: string
2182 integer, intent(in) :: start
2183 character(LEN=*), intent(in) :: substring
2184 type(varying_string) :: rep_string
2185
2186! Replace part of a character string with a character
2187! substring
2188
2189 rep_string = replace(string, start, max(start, 1)+len(substring)-1, substring)
2190
2191! Finish
2192
2193 return
2194
2195 end function replace_ch_ch_auto
2196
2197!****
2198
2199 elemental function replace_vs_vs_fixed (string, start, finish, substring) result (rep_string)
2200
2201 type(varying_string), intent(in) :: string
2202 integer, intent(in) :: start
2203 integer, intent(in) :: finish
2204 type(varying_string), intent(in) :: substring
2205 type(varying_string) :: rep_string
2206
2207! Replace part of a varying string with a varying
2208! substring
2209
2210 rep_string = replace(char(string), start, finish, char(substring))
2211
2212! Finish
2213
2214 return
2215
2216 end function replace_vs_vs_fixed
2217
2218!****
2219
2220!****
2221
2222 elemental function replace_ch_vs_fixed (string, start, finish, substring) result (rep_string)
2223
2224 character(LEN=*), intent(in) :: string
2225 integer, intent(in) :: start
2226 integer, intent(in) :: finish
2227 type(varying_string), intent(in) :: substring
2228 type(varying_string) :: rep_string
2229
2230! Replace part of a character string with a varying
2231! substring
2232
2233 rep_string = replace(string, start, finish, char(substring))
2234
2235! Finish
2236
2237 return
2238
2239 end function replace_ch_vs_fixed
2240
2241!****
2242
2243 elemental function replace_vs_ch_fixed (string, start, finish, substring) result (rep_string)
2244
2245 type(varying_string), intent(in) :: string
2246 integer, intent(in) :: start
2247 integer, intent(in) :: finish
2248 character(LEN=*), intent(in) :: substring
2249 type(varying_string) :: rep_string
2250
2251! Replace part of a varying string with a character
2252! substring
2253
2254 rep_string = replace(char(string), start, finish, substring)
2255
2256! Finish
2257
2258 return
2259
2260 end function replace_vs_ch_fixed
2261
2262!****
2263
2264 elemental function replace_ch_ch_fixed (string, start, finish, substring) result (rep_string)
2265
2266 character(LEN=*), intent(in) :: string
2267 integer, intent(in) :: start
2268 integer, intent(in) :: finish
2269 character(LEN=*), intent(in) :: substring
2270 type(varying_string) :: rep_string
2271
2272 integer :: start_
2273 integer :: finish_
2274
2275! Replace part of a character string with a character
2276! substring
2277
2278 start_ = max(1, start)
2279 finish_ = min(len(string), finish)
2280
2281 if(finish_ < start_) then
2282 rep_string = insert(string, start_, substring)
2283 else
2284 rep_string = var_str(string(:start_-1)//substring//string(finish_+1:))
2285 endif
2286
2287! Finish
2288
2289 return
2290
2291 end function replace_ch_ch_fixed
2292
2293!****
2294
2295 elemental function replace_vs_vs_vs_target (string, target, substring, every, back) result (rep_string)
2296
2297 type(varying_string), intent(in) :: string
2298 type(varying_string), intent(in) :: target
2299 type(varying_string), intent(in) :: substring
2300 logical, intent(in), optional :: every
2301 logical, intent(in), optional :: back
2302 type(varying_string) :: rep_string
2303
2304! Replace part of a varying string with a varying
2305! substring, at a location matching a varying-
2306! string target
2307
2308 rep_string = replace(char(string), char(target), char(substring), every, back)
2309
2310! Finish
2311
2312 return
2313
2314 end function replace_vs_vs_vs_target
2315
2316!****
2317
2318 elemental function replace_ch_vs_vs_target (string, target, substring, every, back) result (rep_string)
2319
2320 character(LEN=*), intent(in) :: string
2321 type(varying_string), intent(in) :: target
2322 type(varying_string), intent(in) :: substring
2323 logical, intent(in), optional :: every
2324 logical, intent(in), optional :: back
2325 type(varying_string) :: rep_string
2326
2327! Replace part of a character string with a varying
2328! substring, at a location matching a varying-
2329! string target
2330
2331 rep_string = replace(string, char(target), char(substring), every, back)
2332
2333! Finish
2334
2335 return
2336
2337 end function replace_ch_vs_vs_target
2338
2339!****
2340
2341 elemental function replace_vs_ch_vs_target (string, target, substring, every, back) result (rep_string)
2342
2343 type(varying_string), intent(in) :: string
2344 character(LEN=*), intent(in) :: target
2345 type(varying_string), intent(in) :: substring
2346 logical, intent(in), optional :: every
2347 logical, intent(in), optional :: back
2348 type(varying_string) :: rep_string
2349
2350! Replace part of a character string with a varying
2351! substring, at a location matching a character-
2352! string target
2353
2354 rep_string = replace(char(string), target, char(substring), every, back)
2355
2356! Finish
2357
2358 return
2359
2360 end function replace_vs_ch_vs_target
2361
2362!****
2363
2364 elemental function replace_ch_ch_vs_target (string, target, substring, every, back) result (rep_string)
2365
2366 character(LEN=*), intent(in) :: string
2367 character(LEN=*), intent(in) :: target
2368 type(varying_string), intent(in) :: substring
2369 logical, intent(in), optional :: every
2370 logical, intent(in), optional :: back
2371 type(varying_string) :: rep_string
2372
2373! Replace part of a character string with a varying
2374! substring, at a location matching a character-
2375! string target
2376
2377 rep_string = replace(string, target, char(substring), every, back)
2378
2379! Finish
2380
2381 return
2382
2383 end function replace_ch_ch_vs_target
2384
2385!****
2386
2387 elemental function replace_vs_vs_ch_target (string, target, substring, every, back) result (rep_string)
2388
2389 type(varying_string), intent(in) :: string
2390 type(varying_string), intent(in) :: target
2391 character(LEN=*), intent(in) :: substring
2392 logical, intent(in), optional :: every
2393 logical, intent(in), optional :: back
2394 type(varying_string) :: rep_string
2395
2396! Replace part of a varying string with a character
2397! substring, at a location matching a varying-
2398! string target
2399
2400 rep_string = replace(char(string), char(target), substring, every, back)
2401
2402! Finish
2403
2404 return
2405
2406 end function replace_vs_vs_ch_target
2407
2408!****
2409
2410 elemental function replace_ch_vs_ch_target (string, target, substring, every, back) result (rep_string)
2411
2412 character(LEN=*), intent(in) :: string
2413 type(varying_string), intent(in) :: target
2414 character(LEN=*), intent(in) :: substring
2415 logical, intent(in), optional :: every
2416 logical, intent(in), optional :: back
2417 type(varying_string) :: rep_string
2418
2419! Replace part of a character string with a character
2420! substring, at a location matching a varying-
2421! string target
2422
2423 rep_string = replace(string, char(target), substring, every, back)
2424
2425! Finish
2426
2427 return
2428
2429 end function replace_ch_vs_ch_target
2430
2431!****
2432
2433 elemental function replace_vs_ch_ch_target (string, target, substring, every, back) result (rep_string)
2434
2435 type(varying_string), intent(in) :: string
2436 character(LEN=*), intent(in) :: target
2437 character(LEN=*), intent(in) :: substring
2438 logical, intent(in), optional :: every
2439 logical, intent(in), optional :: back
2440 type(varying_string) :: rep_string
2441
2442! Replace part of a varying string with a character
2443! substring, at a location matching a character-
2444! string target
2445
2446 rep_string = replace(char(string), target, substring, every, back)
2447
2448! Finish
2449
2450 return
2451
2452 end function replace_vs_ch_ch_target
2453
2454!****
2455
2456 elemental function replace_ch_ch_ch_target (string, target, substring, every, back) result (rep_string)
2457
2458 character(LEN=*), intent(in) :: string
2459 character(LEN=*), intent(in) :: target
2460 character(LEN=*), intent(in) :: substring
2461 logical, intent(in), optional :: every
2462 logical, intent(in), optional :: back
2463 type(varying_string) :: rep_string
2464
2465 logical :: every_
2466 logical :: back_
2467 type(varying_string) :: work_string
2468 integer :: length_target
2469 integer :: i_target
2470
2471! Handle special cases when LEN(target) == 0. Such
2472! instances are prohibited by the standard, but
2473! since this function is elemental, no error can be
2474! thrown. Therefore, it makes sense to handle them
2475! in a sensible manner
2476
2477 if(len(target) == 0) then
2478 if(len(string) /= 0) then
2479 rep_string = string
2480 else
2481 rep_string = substring
2482 endif
2483 return
2484 end if
2485
2486! Replace part of a character string with a character
2487! substring, at a location matching a character-
2488! string target
2489
2490 if(PRESENT(every)) then
2491 every_ = every
2492 else
2493 every_ = .false.
2494 endif
2495
2496 if(PRESENT(back)) then
2497 back_ = back
2498 else
2499 back_ = .false.
2500 endif
2501
2502 rep_string = ""
2503
2504 work_string = string
2505
2506 length_target = len(target)
2507
2508 replace_loop : do
2509
2510 i_target = index(work_string, target, back_)
2511
2512 if(i_target == 0) exit replace_loop
2513
2514 if(back_) then
2515 rep_string = substring//extract(work_string, start=i_target+length_target)//rep_string
2516 work_string = extract(work_string, finish=i_target-1)
2517 else
2518 rep_string = rep_string//extract(work_string, finish=i_target-1)//substring
2519 work_string = extract(work_string, start=i_target+length_target)
2520 endif
2521
2522 if(.NOT. every_) exit replace_loop
2523
2524 end do replace_loop
2525
2526 if(back_) then
2527 rep_string = work_string//rep_string
2528 else
2529 rep_string = rep_string//work_string
2530 endif
2531
2532! Finish
2533
2534 return
2535
2536 end function replace_ch_ch_ch_target
2537
2538!****
2539
2540 elemental subroutine split_vs (string, word, set, separator, back)
2541
2542 type(varying_string), intent(inout) :: string
2543 type(varying_string), intent(out) :: word
2544 type(varying_string), intent(in) :: set
2545 type(varying_string), intent(out), optional :: separator
2546 logical, intent(in), optional :: back
2547
2548! Split a varying string into two verying strings
2549
2550 call split_ch(string, word, char(set), separator, back)
2551
2552! Finish
2553
2554 return
2555
2556 end subroutine split_vs
2557
2558!****
2559
2560 elemental subroutine split_ch (string, word, set, separator, back)
2561
2562 type(varying_string), intent(inout) :: string
2563 type(varying_string), intent(out) :: word
2564 character(LEN=*), intent(in) :: set
2565 type(varying_string), intent(out), optional :: separator
2566 logical, intent(in), optional :: back
2567
2568 logical :: back_
2569 integer :: i_separator
2570
2571! Split a varying string into two verying strings
2572
2573 if(PRESENT(back)) then
2574 back_ = back
2575 else
2576 back_ = .false.
2577 endif
2578
2579 i_separator = scan(string, set, back_)
2580
2581 if(i_separator /= 0) then
2582
2583 if(back_) then
2584 word = extract(string, start=i_separator+1)
2585 if(PRESENT(separator)) separator = extract(string, start=i_separator, finish=i_separator)
2586 string = extract(string, finish=i_separator-1)
2587 else
2588 word = extract(string, finish=i_separator-1)
2589 if(PRESENT(separator)) separator = extract(string, start=i_separator, finish=i_separator)
2590 string = extract(string, start=i_separator+1)
2591 endif
2592
2593 else
2594
2595 word = string
2596 if(PRESENT(separator)) separator = ""
2597 string = ""
2598
2599 endif
2600
2601! Finish
2602
2603 return
2604
2605 end subroutine split_ch
2606
2607
2608 FUNCTION c_ptr_new_vs(string) RESULT(c_ptr_new)
2609 TYPE(varying_string),INTENT(in),TARGET :: string
2610 TYPE(c_ptr) :: c_ptr_new
2611
2612 c_ptr_new = c_loc(string%chars(1))
2613
2614 END FUNCTION c_ptr_new_vs
2615
2616
2617end module iso_varying_string
2618