FortranGIS  Version2.5
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 
54 module iso_varying_string
55 use,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 
409 contains
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 
2617 end module iso_varying_string
2618