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