1module fox_m_fsys_format 2 3!Note that there are several oddities to this package, 4!to get round assorted compiler bugs. 5 6!All the _matrix_ subroutines should be straight 7!call-throughs to the relevant _array_ subroutine, 8!but with flattened arrays. (this would allow easy 9!generation of all functions up to 7 dimensions) 10!but unfortunately that breaks PGI-6.1, and causes 11!errors on Pathscale-2.4. 12 13!The Logical array/matrix functions should be able 14!to COUNT their length inline in the specification 15!expression, but Pathscale-2.4 gives an error on that. 16 17!With PGI (all versions up to last PGI 17.10 community edition) 18!all the procedures exported with the safestr interface 19!were either crashing (older versions) or returning an empty string 20!(latest version) because of a compiler bug. 21!This bug made fail all the _Overload tests in wxml/tests. 22! safestr works correctly if all colon are removed from the dimension 23! of the ia array arguments passed to the len functions 24! (see e.g. lines 918 and below). 25! With this format it is instead ifort v.12 to fail, because of a similar and 26! opposite bug fortunately fixed by Intel in the successive versions 27! For sake of compatibility one or the other call is selected with 28! preprocessor directives. 29 30 use fox_m_fsys_abort_flush, only: pxfflush 31 use fox_m_fsys_realtypes, only: sp, dp 32 33 implicit none 34 private 35 36#ifndef DUMMYLIB 37 integer, parameter :: sig_sp = digits(1.0_sp)/4 38 integer, parameter :: sig_dp = digits(1.0_dp)/4 ! Approximate precision worth outputting of each type. 39 40 character(len=*), parameter :: digit = "0123456789:" 41 character(len=*), parameter :: hexdigit = "0123456789abcdefABCDEF" 42#endif 43 44 interface str 45! This is for external use only: str should not be called within this 46! file. 47! All *_chk subroutines check that the fmt they are passed is valid. 48 module procedure str_string, str_string_array, str_string_matrix, & 49 str_integer, str_integer_array, str_integer_matrix, & 50 str_integer_fmt, str_integer_array_fmt, str_integer_matrix_fmt, & 51 str_logical, str_logical_array, str_logical_matrix, & 52 str_real_sp, str_real_sp_fmt_chk, & 53 str_real_sp_array, str_real_sp_array_fmt_chk, & 54 str_real_sp_matrix, str_real_sp_matrix_fmt_chk, & 55 str_real_dp, str_real_dp_fmt_chk, & 56 str_real_dp_array, str_real_dp_array_fmt_chk, & 57 str_real_dp_matrix, str_real_dp_matrix_fmt_chk, & 58 str_complex_sp, str_complex_sp_fmt_chk, & 59 str_complex_sp_array, str_complex_sp_array_fmt_chk, & 60 str_complex_sp_matrix, str_complex_sp_matrix_fmt_chk, & 61 str_complex_dp, str_complex_dp_fmt_chk, & 62 str_complex_dp_array, str_complex_dp_array_fmt_chk, & 63 str_complex_dp_matrix, str_complex_dp_matrix_fmt_chk 64 end interface str 65 66#ifndef DUMMYLIB 67 interface safestr 68! This is for internal use only - no check is made on the validity of 69! any fmt input. 70 module procedure str_string, str_string_array, str_string_matrix, & 71 str_integer, str_integer_array, str_integer_matrix, & 72 str_logical, str_logical_array, str_logical_matrix, & 73 str_real_sp, str_real_sp_fmt, & 74 str_real_sp_array, str_real_sp_array_fmt, & 75 str_real_sp_matrix, str_real_sp_matrix_fmt, & 76 str_real_dp, str_real_dp_fmt, & 77 str_real_dp_array, str_real_dp_array_fmt, & 78 str_real_dp_matrix, str_real_dp_matrix_fmt, & 79 str_complex_sp, str_complex_sp_fmt, & 80 str_complex_sp_array, str_complex_sp_array_fmt, & 81 str_complex_sp_matrix, str_complex_sp_matrix_fmt, & 82 str_complex_dp, str_complex_dp_fmt, & 83 str_complex_dp_array, str_complex_dp_array_fmt, & 84 str_complex_dp_matrix, str_complex_dp_matrix_fmt 85 end interface safestr 86 87 interface len 88 module procedure str_integer_len, str_integer_array_len, str_integer_matrix_len, & 89 str_integer_fmt_len, str_integer_array_fmt_len, str_integer_matrix_fmt_len, & 90 str_logical_len, str_logical_array_len, str_logical_matrix_len, & 91 str_real_sp_len, str_real_sp_fmt_len, & 92 str_real_sp_array_len, str_real_sp_array_fmt_len, & 93 str_real_sp_matrix_len, str_real_sp_matrix_fmt_len, & 94 str_real_dp_len, str_real_dp_fmt_len, & 95 str_real_dp_array_len, str_real_dp_array_fmt_len, & 96 str_real_dp_matrix_len, str_real_dp_matrix_fmt_len, & 97 str_complex_sp_len, str_complex_sp_fmt_len, & 98 str_complex_sp_array_len, str_complex_sp_array_fmt_len, & 99 str_complex_sp_matrix_len, str_complex_sp_matrix_fmt_len, & 100 str_complex_dp_len, str_complex_dp_fmt_len, & 101 str_complex_dp_array_len, str_complex_dp_array_fmt_len, & 102 str_complex_dp_matrix_len, str_complex_dp_matrix_fmt_len 103 end interface 104#endif 105 106 interface operator(//) 107 module procedure concat_str_int, concat_int_str, & 108 concat_str_logical, concat_logical_str, & 109 concat_real_sp_str, concat_str_real_sp, & 110 concat_real_dp_str, concat_str_real_dp, & 111 concat_complex_sp_str, concat_str_complex_sp, & 112 concat_complex_dp_str, concat_str_complex_dp 113 end interface 114 115 public :: str 116 public :: operator(//) 117 118#ifndef DUMMYLIB 119 public :: str_to_int_10 120 public :: str_to_int_16 121#endif 122 123contains 124 125#ifndef DUMMYLIB 126 ! NB: The len generic module procedure is used in 127 ! many initialisation statments (to set the 128 ! length of the output string needed for the 129 ! converted number). As of the Fortran 2008 130 ! spec every specific function belonging to 131 ! a generic used in this way must be defined 132 ! in the module before use. This is enforced 133 ! by at least version 7.4.4 of the Cray 134 ! Fortran compiler. Hence we put all the *_len 135 ! functions here at the top of the file. 136 pure function str_string_array_len(st) result(n) 137 character(len=*), dimension(:), intent(in) :: st 138 integer :: n 139 140 integer :: k 141 142 n = size(st) - 1 143 do k = 1, size(st) 144 n = n + len(st(k)) 145 enddo 146 147 end function str_string_array_len 148 149 pure function str_string_matrix_len(st) result(n) 150 character(len=*), dimension(:, :), intent(in) :: st 151 integer :: n 152 153 n = len(st) * size(st) + size(st) - 1 154 end function str_string_matrix_len 155 156 pure function str_integer_len(i) result(n) 157 integer, intent(in) :: i 158 integer :: n 159 160 n = int(log10(real(max(abs(i),1)))) + 1 + dim(-i,0)/max(abs(i),1) 161 162 end function str_integer_len 163 164 pure function str_integer_base_len(i, b) result(n) 165 integer, intent(in) :: i, b 166 integer :: n 167 168 n = int(log10(real(max(abs(i),1)))/log10(real(b))) & 169 + 1 + dim(-i,0)/max(abs(i),1) 170 171 end function str_integer_base_len 172 173 pure function str_integer_fmt_len(i, fmt) result(n) 174 integer, intent(in) :: i 175 character(len=*), intent(in) :: fmt 176 integer :: n 177 178 select case (len(fmt)) 179 case(0) 180 n = 0 181 case(1) 182 if (fmt=="x") then 183 n = int(log10(real(max(abs(i),1)))/log10(16.0)) + 1 + dim(-i,0)/max(abs(i),1) 184 elseif (fmt=="d") then 185 n = int(log10(real(max(abs(i),1)))) + 1 + dim(-i,0)/max(abs(i),1) 186 else 187 return 188 endif 189 case default 190 if (fmt(1:1)/='x'.and.fmt(1:1)/='d') then 191 n = 0 192 elseif (verify(fmt(2:), digit)==0) then 193 n = str_to_int_10(fmt(2:)) 194 else 195 n = 0 196 endif 197 end select 198 199 end function str_integer_fmt_len 200 201 pure function str_integer_array_len(ia) result(n) 202 integer, dimension(:), intent(in) :: ia 203 integer :: n 204 205 integer :: j 206 207 n = size(ia) - 1 208 209 do j = 1, size(ia) 210 n = n + len(ia(j)) 211 enddo 212 213 end function str_integer_array_len 214 215 pure function str_integer_array_fmt_len(ia, fmt) result(n) 216 integer, dimension(:), intent(in) :: ia 217 character(len=*), intent(in) :: fmt 218 integer :: n 219 220 integer :: j 221 222 n = size(ia) - 1 223 224 do j = 1, size(ia) 225 n = n + len(ia(j), fmt) 226 enddo 227 228 end function str_integer_array_fmt_len 229 230 pure function str_integer_matrix_len(ia) result(n) 231 integer, dimension(:,:), intent(in) :: ia 232 integer :: n 233 234 integer :: j, k 235 236 n = size(ia) - 1 237 238 do k = 1, size(ia, 2) 239 do j = 1, size(ia, 1) 240 n = n + len(ia(j, k)) 241 enddo 242 enddo 243 244 end function str_integer_matrix_len 245 246 pure function str_integer_matrix_fmt_len(ia, fmt) result(n) 247 integer, dimension(:,:), intent(in) :: ia 248 character(len=*), intent(in) :: fmt 249 integer :: n 250 251 integer :: j, k 252 253 n = size(ia) - 1 254 255 do k = 1, size(ia, 2) 256 do j = 1, size(ia, 1) 257 n = n + len(ia(j, k), fmt) 258 enddo 259 enddo 260 261 end function str_integer_matrix_fmt_len 262 263 pure function str_logical_len(l) result (n) 264 logical, intent(in) :: l 265 integer :: n 266 267 if (l) then 268 n = 4 269 else 270 n = 5 271 endif 272 end function str_logical_len 273 274 pure function str_logical_array_len(la) result(n) 275! This function should be inlined in the declarations of 276! str_logical_array below but PGI and pathscale don't like it. 277 logical, dimension(:), intent(in) :: la 278 integer :: n 279 n = 5*size(la) - 1 + count(.not.la) 280 end function str_logical_array_len 281 282 pure function str_logical_matrix_len(la) result(n) 283! This function should be inlined in the declarations of 284! str_logical_matrix below but PGI and pathscale don't like it. 285 logical, dimension(:,:), intent(in) :: la 286 integer :: n 287 n = 5*size(la) - 1 + count(.not.la) 288 end function str_logical_matrix_len 289 290 pure function str_real_sp_fmt_len(x, fmt) result(n) 291 real(sp), intent(in) :: x 292 character(len=*), intent(in) :: fmt 293 integer :: n 294 295 integer :: dec, sig 296 integer :: e 297 298 if (.not.checkFmt(fmt)) then 299 n = 0 300 return 301 endif 302 303 if (x == 0.0_sp) then 304 e = 1 305 else 306 e = floor(log10(abs(x))) 307 endif 308 309 if (x < 0.0_sp) then 310 n = 1 311 else 312 n = 0 313 endif 314 315 if (len(fmt) == 0) then 316 sig = sig_sp 317 318 n = n + sig + 2 + len(e) 319 ! for the decimal point and the e 320 321 elseif (fmt(1:1) == "s") then 322 if (len(fmt) > 1) then 323 sig = str_to_int_10(fmt(2:)) 324 else 325 sig = sig_sp 326 endif 327 sig = max(sig, 1) 328 sig = min(sig, digits(1.0_sp)) 329 330 if (sig > 1) n = n + 1 331 ! for the decimal point 332 333 n = n + sig + 1 + len(e) 334 335 elseif (fmt(1:1) == "r") then 336 337 if (len(fmt) > 1) then 338 dec = str_to_int_10(fmt(2:)) 339 else 340 dec = sig_sp - e - 1 341 endif 342 dec = min(dec, digits(1.0_sp)-e) 343 dec = max(dec, 0) 344 345 if (dec > 0) n = n + 1 346 if (abs(x) >= 1.0_sp) n = n + 1 347 348 ! Need to know if there's an overflow .... 349 if (e+dec+1 > 0) then 350 if (index(real_sp_str(abs(x), e+dec+1), "!") == 1) & 351 e = e + 1 352 endif 353 354 n = n + abs(e) + dec 355 356 endif 357 358 end function str_real_sp_fmt_len 359 360 pure function str_real_sp_len(x) result(n) 361 real(sp), intent(in) :: x 362 integer :: n 363 364 n = len(x, "") 365 366 end function str_real_sp_len 367 368 pure function str_real_sp_array_len(xa) result(n) 369 real(sp), dimension(:), intent(in) :: xa 370 integer :: n 371 372 integer :: k 373 374 n = size(xa) - 1 375 do k = 1, size(xa) 376 n = n + len(xa(k), "") 377 enddo 378 379 end function str_real_sp_array_len 380 381 pure function str_real_sp_array_fmt_len(xa, fmt) result(n) 382 real(sp), dimension(:), intent(in) :: xa 383 character(len=*), intent(in) :: fmt 384 integer :: n 385 386 integer :: k 387 388 n = size(xa) - 1 389 do k = 1, size(xa) 390 n = n + len(xa(k), fmt) 391 enddo 392 393 end function str_real_sp_array_fmt_len 394 395 pure function str_real_sp_matrix_fmt_len(xa, fmt) result(n) 396 real(sp), dimension(:,:), intent(in) :: xa 397 character(len=*), intent(in) :: fmt 398 integer :: n 399 400 integer :: j, k 401 402 n = size(xa) - 1 403 do k = 1, size(xa, 2) 404 do j = 1, size(xa, 1) 405 n = n + len(xa(j,k), fmt) 406 enddo 407 enddo 408 409 end function str_real_sp_matrix_fmt_len 410 411 pure function str_real_sp_matrix_len(xa) result(n) 412 real(sp), dimension(:,:), intent(in) :: xa 413 integer :: n 414 415 n = len(xa, "") 416 end function str_real_sp_matrix_len 417 418 pure function str_real_dp_fmt_len(x, fmt) result(n) 419 real(dp), intent(in) :: x 420 character(len=*), intent(in) :: fmt 421 integer :: n 422 423 integer :: dec, sig 424 integer :: e 425 426 if (.not.checkFmt(fmt)) then 427 n = 0 428 return 429 endif 430 431 if (x == 0.0_dp) then 432 e = 1 433 else 434 e = floor(log10(abs(x))) 435 endif 436 437 if (x < 0.0_dp) then 438 n = 1 439 else 440 n = 0 441 endif 442 443 if (len(fmt) == 0) then 444 sig = sig_dp 445 446 n = n + sig + 2 + len(e) 447 ! for the decimal point and the e 448 449 elseif (fmt(1:1) == "s") then 450 if (len(fmt) > 1) then 451 sig = str_to_int_10(fmt(2:)) 452 else 453 sig = sig_dp 454 endif 455 sig = max(sig, 1) 456 sig = min(sig, digits(1.0_dp)) 457 458 if (sig > 1) n = n + 1 459 ! for the decimal point 460 461 n = n + sig + 1 + len(e) 462 463 elseif (fmt(1:1) == "r") then 464 465 if (len(fmt) > 1) then 466 dec = str_to_int_10(fmt(2:)) 467 else 468 dec = sig_dp - e - 1 469 endif 470 dec = min(dec, digits(1.0_dp)-e) 471 dec = max(dec, 0) 472 473 if (dec > 0) n = n + 1 474 if (abs(x) >= 1.0_dp) n = n + 1 475 476 ! Need to know if there's an overflow .... 477 if (e+dec+1 > 0) then 478 if (index(real_dp_str(abs(x), e+dec+1), "!") == 1) & 479 e = e + 1 480 endif 481 482 n = n + abs(e) + dec 483 484 endif 485 486 end function str_real_dp_fmt_len 487 488 pure function str_real_dp_len(x) result(n) 489 real(dp), intent(in) :: x 490 integer :: n 491 492 n = len(x, "") 493 494 end function str_real_dp_len 495 496 pure function str_real_dp_array_len(xa) result(n) 497 real(dp), dimension(:), intent(in) :: xa 498 integer :: n 499 500 integer :: k 501 502 n = size(xa) - 1 503 do k = 1, size(xa) 504 n = n + len(xa(k), "") 505 enddo 506 507 end function str_real_dp_array_len 508 509 pure function str_real_dp_array_fmt_len(xa, fmt) result(n) 510 real(dp), dimension(:), intent(in) :: xa 511 character(len=*), intent(in) :: fmt 512 integer :: n 513 514 integer :: k 515 516 n = size(xa) - 1 517 do k = 1, size(xa) 518 n = n + len(xa(k), fmt) 519 enddo 520 521 end function str_real_dp_array_fmt_len 522 523 pure function str_real_dp_matrix_fmt_len(xa, fmt) result(n) 524 real(dp), dimension(:,:), intent(in) :: xa 525 character(len=*), intent(in) :: fmt 526 integer :: n 527 528 integer :: j, k 529 530 n = size(xa) - 1 531 do k = 1, size(xa, 2) 532 do j = 1, size(xa, 1) 533 n = n + len(xa(j,k), fmt) 534 enddo 535 enddo 536 537 end function str_real_dp_matrix_fmt_len 538 539 pure function str_real_dp_matrix_len(xa) result(n) 540 real(dp), dimension(:,:), intent(in) :: xa 541 integer :: n 542 543 n = len(xa, "") 544 end function str_real_dp_matrix_len 545 546 pure function str_complex_sp_fmt_len(c, fmt) result(n) 547 complex(sp), intent(in) :: c 548 character(len=*), intent(in) :: fmt 549 integer :: n 550 551 real(sp) :: re, im 552 re = real(c) 553 im = aimag(c) 554 555 n = len(re, fmt) + len(im, fmt) + 6 556 end function str_complex_sp_fmt_len 557 558 pure function str_complex_sp_len(c) result(n) 559 complex(sp), intent(in) :: c 560 integer :: n 561 562 n = len(c, "") 563 end function str_complex_sp_len 564 565 pure function str_complex_sp_array_fmt_len(ca, fmt) result(n) 566 complex(sp), dimension(:), intent(in) :: ca 567 character(len=*), intent(in) :: fmt 568 integer :: n 569 570 integer :: i 571 572 n = size(ca) - 1 573 do i = 1, size(ca) 574 n = n + len(ca(i), fmt) 575 enddo 576 end function str_complex_sp_array_fmt_len 577 578 pure function str_complex_sp_array_len(ca) result(n) 579 complex(sp), dimension(:), intent(in) :: ca 580 integer :: n 581 582 n = len(ca, "") 583 end function str_complex_sp_array_len 584 585 pure function str_complex_sp_matrix_fmt_len(ca, fmt) result(n) 586 complex(sp), dimension(:, :), intent(in) :: ca 587 character(len=*), intent(in) :: fmt 588 integer :: n 589 590 integer :: i, j 591 592 n = size(ca) - 1 593 do i = 1, size(ca, 1) 594 do j = 1, size(ca, 2) 595 n = n + len(ca(i, j), fmt) 596 enddo 597 enddo 598 end function str_complex_sp_matrix_fmt_len 599 600 pure function str_complex_sp_matrix_len(ca) result(n) 601 complex(sp), dimension(:, :), intent(in) :: ca 602 integer :: n 603 604 n = len(ca, "") 605 end function str_complex_sp_matrix_len 606 607 pure function str_complex_dp_fmt_len(c, fmt) result(n) 608 complex(dp), intent(in) :: c 609 character(len=*), intent(in) :: fmt 610 integer :: n 611 612 real(dp) :: re, im 613 re = real(c) 614 im = aimag(c) 615 616 n = len(re, fmt) + len(im, fmt) + 6 617 end function str_complex_dp_fmt_len 618 619 pure function str_complex_dp_len(c) result(n) 620 complex(dp), intent(in) :: c 621 integer :: n 622 623 n = len(c, "") 624 end function str_complex_dp_len 625 626 pure function str_complex_dp_array_fmt_len(ca, fmt) result(n) 627 complex(dp), dimension(:), intent(in) :: ca 628 character(len=*), intent(in) :: fmt 629 integer :: n 630 631 integer :: i 632 633 n = size(ca) - 1 634 do i = 1, size(ca) 635 n = n + len(ca(i), fmt) 636 enddo 637 end function str_complex_dp_array_fmt_len 638 639 pure function str_complex_dp_array_len(ca) result(n) 640 complex(dp), dimension(:), intent(in) :: ca 641 integer :: n 642 643 n = len(ca, "") 644 end function str_complex_dp_array_len 645 646 pure function str_complex_dp_matrix_fmt_len(ca, fmt) result(n) 647 complex(dp), dimension(:, :), intent(in) :: ca 648 character(len=*), intent(in) :: fmt 649 integer :: n 650 651 integer :: i, j 652 653 n = size(ca) - 1 654 do i = 1, size(ca, 1) 655 do j = 1, size(ca, 2) 656 n = n + len(ca(i, j), fmt) 657 enddo 658 enddo 659 end function str_complex_dp_matrix_fmt_len 660 661 pure function str_complex_dp_matrix_len(ca) result(n) 662 complex(dp), dimension(:, :), intent(in) :: ca 663 integer :: n 664 665 n = len(ca, "") 666 end function str_complex_dp_matrix_len 667#endif 668 669#ifndef DUMMYLIB 670 subroutine FoX_error(msg) 671 ! Emit error message and stop. 672 ! No clean up is done here, but this can 673 ! be overridden to include clean-up routines 674 character(len=*), intent(in) :: msg 675 676 write(0,'(a)') 'ERROR(FoX)' 677 write(0,'(a)') msg 678 call pxfflush(0) 679 680 stop 681 682 end subroutine FoX_error 683 684 685 pure function str_to_int_10(str) result(n) 686 ! Takes a string containing digits, and returns 687 ! the integer representable by those digits. 688 ! Does not deal with negative numbers, and 689 ! presumes that the number is representable 690 ! in a default integer 691 ! Error is flagged by returning -1 692 character(len=*), intent(in) :: str 693 integer :: n 694 695 integer :: max_power, i, j 696 697 if (verify(str, digit) > 0) then 698 n = -1 699 return 700 endif 701 702 max_power = len(str) - 1 703 704 n = 0 705 do i = 0, max_power 706 j = max_power - i + 1 707 n = n + (index(digit, str(j:j)) - 1) * 10**i 708 enddo 709 710 end function str_to_int_10 711 712 pure function str_to_int_16(str) result(n) 713 ! Takes a string containing hexadecimal digits, and returns 714 ! the integer representable by those digits. 715 ! Does not deal with negative numbers, and 716 ! presumes that the number is representable 717 ! in a default integer 718 ! Error is flagged by returning -1 719 character(len=*), intent(in) :: str 720 integer :: n 721 722 character(len=len(str)) :: str_l 723 integer :: max_power, i, j 724 725 if (verify(str, hexdigit) == 0) then 726 str_l = to_lower(str) 727 else 728 n = -1 729 return 730 endif 731 732 max_power = len(str) - 1 733 734 n = 0 735 do i = 0, max_power 736 j = max_power - i + 1 737 n = n + (index(hexdigit, str_l(j:j)) - 1) * 16**i 738 enddo 739 740 contains 741 pure function to_lower(s) result(s2) 742 character(len=*), intent(in) :: s 743 character(len=len(s)) :: s2 744 character(len=*), parameter :: hex = "abcdef" 745 integer :: j, k 746 do j = 1, len(s) 747 k = index('ABCDEF', s(j:j)) 748 if (k > 0) then 749 s2(j:j) = hex(k:k) 750 else 751 s2(j:j) = s(j:j) 752 endif 753 enddo 754 end function to_lower 755 756 end function str_to_int_16 757#endif 758 759 pure function str_string(st) result(s) 760 character(len=*), intent(in) :: st 761#ifdef DUMMYLIB 762 character(len=1) :: s 763 s = " " 764#else 765 character(len=len(st)) :: s 766 s = st 767#endif 768 end function str_string 769 770 pure function str_string_array(st, delimiter) result(s) 771 character(len=*), dimension(:), intent(in) :: st 772 character(len=1), intent(in), optional :: delimiter 773#ifdef DUMMYLIB 774 character(len=1) :: s 775 s = " " 776#else 777 character(len=str_string_array_len(st)) :: s 778 779 integer :: k, n 780 character(len=1) :: d 781 782 if (present(delimiter)) then 783 d = delimiter 784 else 785 d = " " 786 endif 787 788 n = 1 789 do k = 1, size(st) - 1 790 s(n:n+len(st(k))) = st(k)//d 791 n = n + len(st(k)) + 1 792 enddo 793 s(n:) = st(k) 794#endif 795 end function str_string_array 796 797 pure function str_string_matrix(st, delimiter) result(s) 798 character(len=*), dimension(:, :), intent(in) :: st 799 character(len=1), intent(in), optional :: delimiter 800#ifdef DUMMYLIB 801 character(len=1) :: s 802 s = " " 803#else 804 character(len=str_string_matrix_len(st)) :: s 805 806 integer :: j, k, n 807 character(len=1) :: d 808 809 if (present(delimiter)) then 810 d = delimiter 811 else 812 d = " " 813 endif 814 815 s(1:len(st)) = st(1,1) 816 n = len(st) + 1 817 do j = 2, size(st, 1) 818 s(n:n+len(st)) = d//st(j,1) 819 n = n + len(st) + 1 820 enddo 821 do k = 2, size(st, 2) 822 do j = 1, size(st, 1) 823 s(n:n+len(st(j,k))) = d//st(j,k) 824 n = n + len(st) + 1 825 enddo 826 enddo 827#endif 828 end function str_string_matrix 829 830 pure function str_integer(i) result(s) 831 integer, intent(in) :: i 832#ifdef DUMMYLIB 833 character(len=1) :: s 834 s = " " 835#else 836 character(len=str_integer_len(i)) :: s 837 838 integer :: b, ii, j, k, n 839 840 b = 10 841 842 if (i < 0) then 843 s(1:1) = "-" 844 n = 2 845 else 846 n = 1 847 endif 848 ii = abs(i) 849 do k = len(s) - n, 0, -1 850 j = ii/(b**k) 851 ii = ii - j*(b**k) 852 s(n:n) = digit(j+1:j+1) 853 n = n + 1 854 enddo 855#endif 856 end function str_integer 857 858 pure function str_integer_fmt(i, fmt) result(s) 859 integer, intent(in) :: i 860 character(len=*), intent(in):: fmt 861#ifdef DUMMYLIB 862 character(len=1) :: s 863 s = " " 864#else 865 character(len=str_integer_fmt_len(i, fmt)) :: s 866 867 character :: f 868 integer :: b, ii, j, k, n, ls 869 870 if (len(fmt)>0) then 871 if (fmt(1:1)=="d") then 872 f = 'd' 873 b = 10 874 elseif (fmt(1:1)=="x") then 875 f = 'x' 876 b = 16 877 else 878 ! Undefined outcome 879 s = "" 880 return 881 endif 882 else 883 ! Undefined outcome 884 s = "" 885 return 886 endif 887 888 ls = str_integer_base_len(i, b) 889 n = len(s) - ls + 1 890 891 if (i < 0) then 892 if (n>0) s(:n) = "-"//repeat("0", n-1) 893 n = n + 1 894 else 895 if (n>1) s(:n) = repeat("0", n) 896 endif 897 898 ii = abs(i) 899 do k = 1, -n + 1 900 j = ii/(b**k) 901 ii = ii - j*(b**k) 902 n = n + 1 903 enddo 904 do k = len(s) - n, 0, -1 905 j = ii/(b**k) 906 ii = ii - j*(b**k) 907 s(n:n) = hexdigit(j+1:j+1) 908 n = n + 1 909 enddo 910#endif 911 end function str_integer_fmt 912 913 pure function str_integer_array(ia) result(s) 914 integer, dimension(:), intent(in) :: ia 915#ifdef DUMMYLIB 916 character(len=1) :: s 917#else 918#if defined (__PGI) 919 character(len=len(ia, "d")) :: s 920#else 921 character(len=len(ia(:), "d")) :: s 922#endif 923 924 integer :: j, k, n 925 926 n = 1 927 do k = 1, size(ia) - 1 928 j = len(ia(k)) 929 s(n:n+j) = str(ia(k))//" " 930 n = n + j + 1 931 enddo 932 s(n:) = str(ia(k)) 933#endif 934 end function str_integer_array 935 936 937 function str_integer_array_fmt(ia, fmt) result(s) 938 integer, dimension(:), intent(in) :: ia 939 character(len=*), intent(in) :: fmt 940#ifdef DUMMYLIB 941 character(len=1) :: s 942 s = " " 943#else 944#if defined(__PGI) 945 character(len=len(ia, fmt)) :: s 946#else 947 character(len=len(ia(:), fmt)) :: s 948#endif 949 950 integer :: j, k, n 951 952 n = 1 953 do k = 1, size(ia) - 1 954 j = len(ia(k), fmt) 955 s(n:n+j) = str(ia(k), fmt)//" " 956 n = n + j + 1 957 enddo 958 s(n:) = str(ia(k), fmt) 959#endif 960 end function str_integer_array_fmt 961 962 pure function str_integer_matrix(ia) result(s) 963 integer, dimension(:,:), intent(in) :: ia 964#ifdef DUMMYLIB 965 character(len=1) :: s 966 s = " " 967#else 968#if defined(__PGI) 969 character(len=len(ia, "d")) :: s 970#else 971 character(len=len(ia(:,:), "d")) :: s 972#endif 973 974 integer :: j, k, n 975 976 s(:len(ia(1,1))) = str(ia(1,1)) 977 n = len(ia(1,1)) + 1 978 do j = 2, size(ia, 1) 979 s(n:n+len(ia(j,1))) = " "//str(ia(j,1)) 980 n = n + len(ia(j,1)) + 1 981 enddo 982 do k = 2, size(ia, 2) 983 do j = 1, size(ia, 1) 984 s(n:n+len(ia(j,k))) = " "//str(ia(j,k)) 985 n = n + len(ia(j,k)) + 1 986 enddo 987 enddo 988#endif 989 end function str_integer_matrix 990 991 992 pure function str_integer_matrix_fmt(ia, fmt) result(s) 993 integer, dimension(:,:), intent(in) :: ia 994 character(len=*), intent(in) :: fmt 995#ifdef DUMMYLIB 996 character(len=1) :: s 997 s = " " 998#else 999#if defined(__PGI) 1000 character(len=len(ia, fmt)) :: s 1001#else 1002 character(len=len(ia(:,:), fmt)) :: s 1003#endif 1004 1005 integer :: j, k, n 1006 1007 s(:len(ia(1,1), fmt)) = str(ia(1,1), fmt) 1008 n = len(ia(1,1), fmt) + 1 1009 do j = 2, size(ia, 1) 1010 s(n:n+len(ia(j,1), fmt)) = " "//str(ia(j,1), fmt) 1011 n = n + len(ia(j,1), fmt) + 1 1012 enddo 1013 do k = 2, size(ia, 2) 1014 do j = 1, size(ia, 1) 1015 s(n:n+len(ia(j,k), fmt)) = " "//str(ia(j,k), fmt) 1016 n = n + len(ia(j,k), fmt) + 1 1017 enddo 1018 enddo 1019#endif 1020 end function str_integer_matrix_fmt 1021 1022 pure function str_logical(l) result(s) 1023 logical, intent(in) :: l 1024#ifdef DUMMYLIB 1025 character(len=1) :: s 1026 s = " " 1027#else 1028! Pathscale 2.5 gets it wrong if we use merge here 1029! character(len=merge(4,5,l)) :: s 1030! And g95 (sep2007) cant resolve the generic here 1031 character(len=str_logical_len(l)) :: s 1032 1033 if (l) then 1034 s="true" 1035 else 1036 s="false" 1037 endif 1038#endif 1039 end function str_logical 1040 1041 pure function str_logical_array(la) result(s) 1042 logical, dimension(:), intent(in) :: la 1043#ifdef DUMMYLIB 1044 character(len=1) :: s 1045 s = " " 1046#else 1047#if defined(__PGI) 1048 character(len=len(la)) :: s 1049#else 1050 character(len=len(la(:))) :: s 1051#endif 1052 1053 integer :: k, n 1054 1055 n = 1 1056 do k = 1, size(la) - 1 1057 if (la(k)) then 1058 s(n:n+3) = "true" 1059 n = n + 5 1060 else 1061 s(n:n+4) = "false" 1062 n = n + 6 1063 endif 1064 s(n-1:n-1) = " " 1065 enddo 1066 if (la(k)) then 1067 s(n:) = "true" 1068 else 1069 s(n:) = "false" 1070 endif 1071#endif 1072 end function str_logical_array 1073 1074 pure function str_logical_matrix(la) result(s) 1075 logical, dimension(:,:), intent(in) :: la 1076#ifdef DUMMYLIB 1077 character(len=1) :: s 1078 s = " " 1079#else 1080#if defined(__PGI) 1081 character(len=len(la)) :: s 1082#else 1083 character(len=len(la(:,:))) :: s 1084#endif 1085 1086 integer :: j, k, n 1087 1088 if (la(1,1)) then 1089 s(:4) = "true" 1090 n = 5 1091 else 1092 s(:5) = "false" 1093 n = 6 1094 endif 1095 do j = 2, size(la, 1) 1096 s(n:n) = " " 1097 if (la(j,1)) then 1098 s(n+1:n+4) = "true" 1099 n = n + 5 1100 else 1101 s(n+1:n+5) = "false" 1102 n = n + 6 1103 endif 1104 enddo 1105 do k = 2, size(la, 2) 1106 do j = 1, size(la, 1) 1107 s(n:n) = " " 1108 if (la(j,k)) then 1109 s(n+1:n+4) = "true" 1110 n = n + 5 1111 else 1112 s(n+1:n+5) = "false" 1113 n = n + 6 1114 endif 1115 enddo 1116 enddo 1117#endif 1118 end function str_logical_matrix 1119 1120#ifndef DUMMYLIB 1121 ! In order to convert real numbers to strings, we need to 1122 ! perform an internal write - but how long will the 1123 ! resultant string be? We don't know & there is no way 1124 ! to discover for an arbitrary format. Therefore, 1125 ! (if we have the capability; f95 or better) 1126 ! we assume it will be less than 100 characters, write 1127 ! it to a string of that length, then remove leading & 1128 ! trailing whitespace. (this means that if the specified 1129 ! format includes whitespace, this will be lost.) 1130 ! 1131 ! If we are working with an F90-only compiler, then 1132 ! we cannot do this trick - the output string will 1133 ! always be 100 chars in length, though we will remove 1134 ! leading whitespace. 1135 1136 1137 ! The standard Fortran format functions do not give us 1138 ! enough control, so we write our own real number formatting 1139 ! routines here. For each real type, we optionally take a 1140 ! format like so: 1141 ! "r<integer>" which will produce output without an exponent, 1142 ! and <integer> digits after the decimal point. 1143 ! or 1144 ! "s<integer>": which implies scientific notation, with an 1145 ! exponent, with <integer> significant figures. 1146 ! If the integer is absent, then the precision will be 1147 ! half of the number of significant figures available 1148 ! for that real type. 1149 ! The absence of a format implies scientific notation, with 1150 ! the default precision. 1151 1152 ! These routines are fairly imperfect - they are inaccurate for 1153 ! the lower-end bits of the number, since they work by simple 1154 ! multiplications by 10. 1155 ! Also they will probably be orders of magnitude slower than library IO. 1156 ! Ideally they'd be rewritten to convert from teh native format by 1157 ! bit-twidding. Not sure how to do that portably though. 1158 1159 ! The format specification could be done more nicely - but unfortunately 1160 ! not in F95 due to *stupid* restrictions on specification expressions. 1161 1162 ! And I wouldn't have to invent my own format specification if Fortran 1163 ! had a proper IO library anyway. 1164 1165!FIXME Signed zero is not handled correctly; don't quite understand why. 1166!FIXME too much duplication between sp & dp, we should m4. 1167 1168 pure function real_sp_str(x, sig) result(s) 1169 real(sp), intent(in) :: x 1170 integer, intent(in) :: sig 1171 character(len=sig) :: s 1172 ! make a string of numbers sig long of x. 1173 integer :: e, i, j, k, n 1174 real(sp) :: x_ 1175 1176 if (sig < 1) then 1177 s ="" 1178 return 1179 endif 1180 1181 if (x == 0.0_sp) then 1182 e = 1 1183 else 1184 e = floor(log10(abs(x))) 1185 endif 1186 x_ = abs(x) 1187 ! Have to do this next in a loop rather than just exponentiating in 1188 ! order to avoid under/over-flow. 1189 do i = 1, abs(e) 1190 ! Have to multiply by 10^-e rather than divide by 10^e 1191 ! to avoid rounding errors. 1192 x_ = x_ * (10.0_sp**(-abs(e)/e)) 1193 enddo 1194 n = 1 1195 do k = sig - 2, 0, -1 1196 ! This baroque way of taking int() ensures the optimizer 1197 ! stores it in j without keeping a different value in cache. 1198 j = iachar(digit(int(x_)+1:int(x_)+1)) - 48 1199 if (j==10) then 1200 ! This can happen if, on the previous cycle, int(x_) in 1201 ! the line above gave a result approx. 1.0 less than 1202 ! expected. 1203 ! In this case we want to quit the cycle & just get 999... to the end 1204 s(n:) = repeat("9", sig - n + 1) 1205 return 1206 endif 1207 s(n:n) = digit(j+1:j+1) 1208 n = n + 1 1209 x_ = (x_ - j) * 10.0_sp 1210 enddo 1211 j = nint(x_) 1212 if (j == 10) then 1213 ! Now round ... 1214 s(n:n) = "9" 1215 ! Are they all 9's? 1216 i = verify(s, "9", .true.) 1217 if (i == 0) then 1218 s(1:1) = "!" 1219 ! overflow 1220 return 1221 endif 1222 j = index(digit, s(i:i)) 1223 s(i:i) = digit(j+1:j+1) 1224 s(i+1:) = repeat("0", sig - i + 1) 1225 else 1226 s(n:n) = digit(j+1:j+1) 1227 endif 1228 1229 end function real_sp_str 1230 1231#endif 1232 1233 function str_real_sp_fmt_chk(x, fmt) result(s) 1234 real(sp), intent(in) :: x 1235 character(len=*), intent(in) :: fmt 1236#ifdef DUMMYLIB 1237 character(len=1) :: s 1238 s = " " 1239#else 1240 character(len=len(x, fmt)) :: s 1241 1242 if (checkFmt(fmt)) then 1243 s = safestr(x, fmt) 1244 else 1245 call FoX_error("Invalid format: "//fmt) 1246 endif 1247#endif 1248 end function str_real_sp_fmt_chk 1249 1250#ifndef DUMMYLIB 1251 pure function str_real_sp_fmt(x, fmt) result(s) 1252 real(sp), intent(in) :: x 1253 character(len=*), intent(in) :: fmt 1254 character(len=len(x, fmt)) :: s 1255 1256 integer :: sig, dec 1257 integer :: e, n 1258 character(len=len(x, fmt)) :: num !this will always be enough memory. 1259 1260 if (x == 0.0_sp) then 1261 e = 0 1262 else 1263 e = floor(log10(abs(x))) 1264 endif 1265 1266 if (x < 0.0_sp) then 1267 s(1:1) = "-" 1268 n = 2 1269 else 1270 n = 1 1271 endif 1272 1273 if (len(fmt) == 0) then 1274 1275 sig = sig_sp 1276 1277 num = real_sp_str(abs(x), sig) 1278 if (num(1:1) == "!") then 1279 e = e + 1 1280 num = "1"//repeat("0",len(num)-1) 1281 endif 1282 1283 if (sig == 1) then 1284 s(n:n) = num 1285 n = n + 1 1286 else 1287 s(n:n+1) = num(1:1)//"." 1288 s(n+2:n+sig) = num(2:) 1289 n = n + sig + 1 1290 endif 1291 1292 s(n:n) = "e" 1293 s(n+1:) = str(e) 1294 1295 elseif (fmt(1:1) == "s") then 1296 1297 if (len(fmt) > 1) then 1298 sig = str_to_int_10(fmt(2:)) 1299 else 1300 sig = sig_sp 1301 endif 1302 sig = max(sig, 1) 1303 sig = min(sig, digits(1.0_sp)) 1304 1305 num = real_sp_str(abs(x), sig) 1306 if (num(1:1) == "!") then 1307 e = e + 1 1308 num = "1"//repeat("0",len(num)-1) 1309 endif 1310 1311 if (sig == 1) then 1312 s(n:n) = num 1313 n = n + 1 1314 else 1315 s(n:n+1) = num(1:1)//"." 1316 s(n+2:n+sig) = num(2:) 1317 n = n + sig + 1 1318 endif 1319 1320 s(n:n) = "e" 1321 s(n+1:) = str(e) 1322 1323 elseif (fmt(1:1) == "r") then 1324 1325 if (len(fmt) > 1) then 1326 dec = str_to_int_10(fmt(2:)) 1327 else 1328 dec = sig_sp - e - 1 1329 endif 1330 dec = min(dec, digits(1.0_sp)-e-1) 1331 dec = max(dec, 0) 1332 1333 if (e+dec+1 > 0) then 1334 num = real_sp_str(abs(x), e+dec+1) 1335 else 1336 num = "" 1337 endif 1338 if (num(1:1) == "!") then 1339 e = e + 1 1340 num = "1"//repeat("0",len(num)-1) 1341 endif 1342 1343 if (abs(x) >= 1.0_sp) then 1344 s(n:n+e) = num(:e+1) 1345 n = n + e + 1 1346 if (dec > 0) then 1347 s(n:n) = "." 1348 n = n + 1 1349 s(n:) = num(e+2:) 1350 endif 1351 else 1352 s(n:n) = "0" 1353 if (dec > 0) then 1354 s(n+1:n+1) = "." 1355 n = n + 2 1356 if (dec < -e-1) then 1357 s(n:) = repeat("0", dec) 1358 else 1359 s(n:n-e-2) = repeat("0", max(-e-1,0)) 1360 n = n - min(e,-1) - 1 1361 if (n <= len(s)) then 1362 s(n:) = num 1363 endif 1364 endif 1365 endif 1366 endif 1367 1368 endif 1369 1370 end function str_real_sp_fmt 1371#endif 1372 1373 pure function str_real_sp(x) result(s) 1374 real(sp), intent(in) :: x 1375#ifdef DUMMYLIB 1376 character(len=1) :: s 1377 s = " " 1378#else 1379 character(len=len(x)) :: s 1380 1381 s = safestr(x, "") 1382#endif 1383 end function str_real_sp 1384 1385 pure function str_real_sp_array(xa) result(s) 1386 real(sp), dimension(:), intent(in) :: xa 1387#ifdef DUMMYLIB 1388 character(len=1) :: s 1389 s = " " 1390#else 1391#if defined(__PGI) 1392 character(len=len(xa)) :: s 1393#else 1394 character(len=len(xa(:))) :: s 1395#endif 1396 1397 integer :: j, k, n 1398 1399 n = 1 1400 do k = 1, size(xa) - 1 1401 j = len(xa(k), "") 1402 s(n:n+j) = safestr(xa(k), "")//" " 1403 n = n + j + 1 1404 enddo 1405 s(n:) = safestr(xa(k), "") 1406#endif 1407 end function str_real_sp_array 1408 1409#ifndef DUMMYLIB 1410 pure function str_real_sp_array_fmt(xa, fmt) result(s) 1411 real(sp), dimension(:), intent(in) :: xa 1412 character(len=*), intent(in) :: fmt 1413#if defined(__PGI) 1414 character(len=len(xa, fmt)) :: s 1415#else 1416 character(len=len(xa(:), fmt)) :: s 1417#endif 1418 1419 integer :: j, k, n 1420 1421 n = 1 1422 do k = 1, size(xa) - 1 1423 j = len(xa(k), fmt) 1424 s(n:n+j) = safestr(xa(k), fmt)//" " 1425 n = n + j + 1 1426 enddo 1427 s(n:) = safestr(xa(k), fmt) 1428 1429 end function str_real_sp_array_fmt 1430#endif 1431 1432 function str_real_sp_array_fmt_chk(xa, fmt) result(s) 1433 real(sp), dimension(:), intent(in) :: xa 1434 character(len=*), intent(in) :: fmt 1435#ifdef DUMMYLIB 1436 character(len=1) :: s 1437 s = " " 1438#else 1439#if defined(__PGI) 1440 character(len=len(xa, fmt)) :: s 1441#else 1442 character(len=len(xa(:), fmt)) :: s 1443#endif 1444 1445 if (checkFmt(fmt)) then 1446 s = safestr(xa, fmt) 1447 else 1448 call FoX_error("Invalid format: "//fmt) 1449 endif 1450#endif 1451 end function str_real_sp_array_fmt_chk 1452 1453#ifndef DUMMYLIB 1454 pure function str_real_sp_matrix_fmt(xa, fmt) result(s) 1455 real(sp), dimension(:,:), intent(in) :: xa 1456 character(len=*), intent(in) :: fmt 1457#if defined(__PGI) 1458 character(len=len(xa,fmt)) :: s 1459#else 1460 character(len=len(xa(:,:),fmt)) :: s 1461#endif 1462 1463 integer :: i, j, k, n 1464 1465 i = len(xa(1,1), fmt) 1466 s(:i) = safestr(xa(1,1), fmt) 1467 n = i + 1 1468 do j = 2, size(xa, 1) 1469 i = len(xa(j,1), fmt) 1470 s(n:n+i) = " "//safestr(xa(j,1), fmt) 1471 n = n + i + 1 1472 enddo 1473 do k = 2, size(xa, 2) 1474 do j = 1, size(xa, 1) 1475 i = len(xa(j,k), fmt) 1476 s(n:n+i) = " "//safestr(xa(j,k), fmt) 1477 n = n + i + 1 1478 enddo 1479 enddo 1480 1481 end function str_real_sp_matrix_fmt 1482#endif 1483 1484 function str_real_sp_matrix_fmt_chk(xa, fmt) result(s) 1485 real(sp), dimension(:,:), intent(in) :: xa 1486 character(len=*), intent(in) :: fmt 1487#ifdef DUMMYLIB 1488 character(len=1) :: s 1489 s = " " 1490#else 1491#if defined(__PGI) 1492 character(len=len(xa,fmt)) :: s 1493#else 1494 character(len=len(xa(:,:),fmt)) :: s 1495#endif 1496 1497 if (checkFmt(fmt)) then 1498 s = safestr(xa, fmt) 1499 else 1500 call FoX_error("Invalid format: "//fmt) 1501 end if 1502#endif 1503 end function str_real_sp_matrix_fmt_chk 1504 1505 pure function str_real_sp_matrix(xa) result(s) 1506 real(sp), dimension(:,:), intent(in) :: xa 1507#ifdef DUMMYLIB 1508 character(len=1) :: s 1509 s = " " 1510#else 1511#if defined(__PGI) 1512 character(len=len(xa)) :: s 1513#else 1514 character(len=len(xa(:,:))) :: s 1515#endif 1516 1517 s = safestr(xa, "") 1518#endif 1519 end function str_real_sp_matrix 1520 1521#ifndef DUMMYLIB 1522 pure function real_dp_str(x, sig) result(s) 1523 real(dp), intent(in) :: x 1524 integer, intent(in) :: sig 1525 character(len=sig) :: s 1526 ! make a string of numbers sig long of x. 1527 integer :: e, i, j, k, n 1528 real(dp) :: x_ 1529 1530 if (sig < 1) then 1531 s ="" 1532 return 1533 endif 1534 1535 if (x == 0.0_dp) then 1536 e = 1 1537 else 1538 e = floor(log10(abs(x))) 1539 endif 1540 x_ = abs(x) 1541 ! Have to do this next in a loop rather than just exponentiating in 1542 ! order to avoid under/over-flow. 1543 do i = 1, abs(e) 1544 ! Have to multiply by 10^-e rather than divide by 10^e 1545 ! to avoid rounding errors. 1546 x_ = x_ * (10.0_dp**(-abs(e)/e)) 1547 enddo 1548 n = 1 1549 do k = sig - 2, 0, -1 1550 ! This baroque way of taking int() ensures the optimizer definitely 1551 ! stores it in j without keeping a different value in cache. 1552 j = iachar(digit(int(x_)+1:int(x_)+1)) - 48 1553 if (j==10) then 1554 ! This can happen if, on the previous cycle, int(x_) in 1555 ! the line above gave a result almost exactly 1.0 less than 1556 ! expected - but FP arithmetic is not consistent. 1557 ! In this case we want to quit the cycle & just get 999... to the end 1558 s(n:) = repeat("9", sig - n + 1) 1559 return 1560 endif 1561 s(n:n) = digit(j+1:j+1) 1562 n = n + 1 1563 x_ = (x_ - j) * 10.0_dp 1564 enddo 1565 j = nint(x_) 1566 if (j == 10) then 1567 ! Now round ... 1568 s(n:n) = "9" 1569 i = verify(s, "9", .true.) 1570 if (i == 0) then 1571 s(1:1) = "!" 1572 !overflow 1573 return 1574 endif 1575 j = index(digit, s(i:i)) 1576 s(i:i) = digit(j+1:j+1) 1577 s(i+1:) = repeat("0", sig - i + 1) 1578 else 1579 s(n:n) = digit(j+1:j+1) 1580 endif 1581 1582 end function real_dp_str 1583 1584 1585#endif 1586 1587 function str_real_dp_fmt_chk(x, fmt) result(s) 1588 real(dp), intent(in) :: x 1589 character(len=*), intent(in) :: fmt 1590#ifdef DUMMYLIB 1591 character(len=1) :: s 1592 s = " " 1593#else 1594 character(len=len(x, fmt)) :: s 1595 1596 if (checkFmt(fmt)) then 1597 s = safestr(x, fmt) 1598 else 1599 call FoX_error("Invalid format: "//fmt) 1600 endif 1601#endif 1602 end function str_real_dp_fmt_chk 1603 1604#ifndef DUMMYLIB 1605 pure function str_real_dp_fmt(x, fmt) result(s) 1606 real(dp), intent(in) :: x 1607 character(len=*), intent(in) :: fmt 1608 character(len=len(x, fmt)) :: s 1609 1610 integer :: sig, dec 1611 integer :: e, n 1612 character(len=len(x, fmt)) :: num !this will always be enough memory. 1613 1614 if (x == 0.0_dp) then 1615 e = 0 1616 else 1617 e = floor(log10(abs(x))) 1618 endif 1619 1620 if (x < 0.0_dp) then 1621 s(1:1) = "-" 1622 n = 2 1623 else 1624 n = 1 1625 endif 1626 1627 if (len(fmt) == 0) then 1628 1629 sig = sig_dp 1630 1631 num = real_dp_str(abs(x), sig) 1632 if (num(1:1) == "!") then 1633 e = e + 1 1634 num = "1"//repeat("0",len(num)-1) 1635 endif 1636 1637 if (sig == 1) then 1638 s(n:n) = num 1639 n = n + 1 1640 else 1641 s(n:n+1) = num(1:1)//"." 1642 s(n+2:n+sig) = num(2:) 1643 n = n + sig + 1 1644 endif 1645 1646 s(n:n) = "e" 1647 s(n+1:) = safestr(e) 1648 1649 elseif (fmt(1:1) == "s") then 1650 1651 if (len(fmt) > 1) then 1652 sig = str_to_int_10(fmt(2:)) 1653 else 1654 sig = sig_dp 1655 endif 1656 sig = max(sig, 1) 1657 sig = min(sig, digits(1.0_dp)) 1658 1659 num = real_dp_str(abs(x), sig) 1660 if (num(1:1) == "!") then 1661 e = e + 1 1662 num = "1"//repeat("0",len(num)-1) 1663 endif 1664 1665 if (sig == 1) then 1666 s(n:n) = num 1667 n = n + 1 1668 else 1669 s(n:n+1) = num(1:1)//"." 1670 s(n+2:n+sig) = num(2:) 1671 n = n + sig + 1 1672 endif 1673 1674 s(n:n) = "e" 1675 s(n+1:) = safestr(e) 1676 1677 elseif (fmt(1:1) == "r") then 1678 1679 if (len(fmt) > 1) then 1680 dec = str_to_int_10(fmt(2:)) 1681 else 1682 dec = sig_dp - e - 1 1683 endif 1684 dec = min(dec, digits(1.0_dp)-e-1) 1685 dec = max(dec, 0) 1686 1687 if (e+dec+1 > 0) then 1688 num = real_dp_str(abs(x), e+dec+1) 1689 else 1690 num = "" 1691 endif 1692 if (num(1:1) == "!") then 1693 e = e + 1 1694 num = "1"//repeat("0",len(num)-1) 1695 endif 1696 1697 if (abs(x) >= 1.0_dp) then 1698 s(n:n+e) = num(:e+1) 1699 n = n + e + 1 1700 if (dec > 0) then 1701 s(n:n) = "." 1702 n = n + 1 1703 s(n:) = num(e+2:) 1704 endif 1705 else 1706 s(n:n) = "0" 1707 if (dec > 0) then 1708 s(n+1:n+1) = "." 1709 n = n + 2 1710 if (dec < -e-1) then 1711 s(n:) = repeat("0", dec) 1712 else 1713 s(n:n-e-2) = repeat("0", max(-e-1,0)) 1714 n = n - min(e,-1) - 1 1715 if (n <= len(s)) then 1716 s(n:) = num 1717 endif 1718 endif 1719 endif 1720 endif 1721 1722 endif 1723 1724 end function str_real_dp_fmt 1725 1726#endif 1727 1728 pure function str_real_dp(x) result(s) 1729 real(dp), intent(in) :: x 1730#ifdef DUMMYLIB 1731 character(len=1) :: s 1732 s = " " 1733#else 1734 character(len=len(x)) :: s 1735 1736 s = safestr(x, "") 1737#endif 1738 end function str_real_dp 1739 1740 pure function str_real_dp_array(xa) result(s) 1741 real(dp), dimension(:), intent(in) :: xa 1742#ifdef DUMMYLIB 1743 character(len=1) :: s 1744 s = " " 1745#else 1746#if defined(__PGI) 1747 character(len=len(xa)) :: s 1748#else 1749 character(len=len(xa(:))) :: s 1750#endif 1751 1752 integer :: j, k, n 1753 1754 n = 1 1755 do k = 1, size(xa) - 1 1756 j = len(xa(k), "") 1757 s(n:n+j) = safestr(xa(k), "")//" " 1758 n = n + j + 1 1759 enddo 1760 s(n:) = safestr(xa(k)) 1761#endif 1762 end function str_real_dp_array 1763 1764#ifndef DUMMYLIB 1765 pure function str_real_dp_array_fmt(xa, fmt) result(s) 1766 real(dp), dimension(:), intent(in) :: xa 1767 character(len=*), intent(in) :: fmt 1768#if defined(__PGI) 1769 character(len=len(xa, fmt)) :: s 1770#else 1771 character(len=len(xa(:), fmt)) :: s 1772#endif 1773 1774 integer :: j, k, n 1775 1776 n = 1 1777 do k = 1, size(xa) - 1 1778 j = len(xa(k), fmt) 1779 s(n:n+j) = safestr(xa(k), fmt)//" " 1780 n = n + j + 1 1781 enddo 1782 s(n:) = safestr(xa(k), fmt) 1783 1784 end function str_real_dp_array_fmt 1785#endif 1786 1787 function str_real_dp_array_fmt_chk(xa, fmt) result(s) 1788 real(dp), dimension(:), intent(in) :: xa 1789 character(len=*), intent(in) :: fmt 1790#ifdef DUMMYLIB 1791 character(len=1) :: s 1792 s = " " 1793#else 1794#if defined(__PGI) 1795 character(len=len(xa, fmt)) :: s 1796#else 1797 character(len=len(xa(:), fmt)) :: s 1798#endif 1799 if (checkFmt(fmt)) then 1800 s = safestr(xa, fmt) 1801 else 1802 call FoX_error("Invalid format: "//fmt) 1803 endif 1804#endif 1805 end function str_real_dp_array_fmt_chk 1806 1807#ifndef DUMMYLIB 1808 function str_real_dp_matrix_fmt(xa, fmt) result(s) 1809 real(dp), dimension(:,:), intent(in) :: xa 1810 character(len=*), intent(in) :: fmt 1811#if defined(__PGI) 1812 character(len=len(xa,fmt)) :: s 1813#else 1814 character(len=len(xa(:,:),fmt)) :: s 1815#endif 1816 integer :: i, j, k, n 1817 1818 i = len(xa(1,1), fmt) 1819 s(:i) = safestr(xa(1,1), fmt) 1820 n = i + 1 1821 do j = 2, size(xa, 1) 1822 i = len(xa(j,1), fmt) 1823 s(n:n+i) = " "//safestr(xa(j,1), fmt) 1824 n = n + i + 1 1825 enddo 1826 do k = 2, size(xa, 2) 1827 do j = 1, size(xa, 1) 1828 i = len(xa(j,k), fmt) 1829 s(n:n+i) = " "//safestr(xa(j,k), fmt) 1830 n = n + i + 1 1831 enddo 1832 enddo 1833 1834 end function str_real_dp_matrix_fmt 1835#endif 1836 1837 function str_real_dp_matrix_fmt_chk(xa, fmt) result(s) 1838 real(dp), dimension(:,:), intent(in) :: xa 1839 character(len=*), intent(in) :: fmt 1840#ifdef DUMMYLIB 1841 character(len=1) :: s 1842 s = " " 1843#else 1844#if defined(__PGI) 1845 character(len=len(xa,fmt)) :: s 1846#else 1847 character(len=len(xa(:,:),fmt)) :: s 1848#endif 1849 if (checkFmt(fmt)) then 1850 s = safestr(xa, fmt) 1851 else 1852 call FoX_error("Invalid format: "//fmt) 1853 end if 1854#endif 1855 end function str_real_dp_matrix_fmt_chk 1856 1857 function str_real_dp_matrix(xa) result(s) 1858 real(dp), dimension(:,:), intent(in) :: xa 1859#ifdef DUMMYLIB 1860 character(len=1) :: s 1861 s = " " 1862#else 1863#if defined(__PGI) 1864 character(len=len(xa)) :: s 1865#else 1866 character(len=len(xa(:,:))) :: s 1867#endif 1868 1869 s = safestr(xa, "") 1870#endif 1871 end function str_real_dp_matrix 1872 1873! For complex numbers, there's not really much prior art, so 1874! we use the easy solution: a+bi, where a & b are real numbers 1875! as output above. 1876 1877 function str_complex_sp_fmt_chk(c, fmt) result(s) 1878 complex(sp), intent(in) :: c 1879 character(len=*), intent(in) :: fmt 1880#ifdef DUMMYLIB 1881 character(len=1) :: s 1882 s = " " 1883#else 1884 character(len=len(c, fmt)) :: s 1885 1886 if (checkFmt(fmt)) then 1887 s = safestr(c, fmt) 1888 else 1889 call FoX_error("Invalid format: "//fmt) 1890 endif 1891#endif 1892 end function str_complex_sp_fmt_chk 1893 1894#ifndef DUMMYLIB 1895 pure function str_complex_sp_fmt(c, fmt) result(s) 1896 complex(sp), intent(in) :: c 1897 character(len=*), intent(in) :: fmt 1898 character(len=len(c, fmt)) :: s 1899 1900 real(sp) :: re, im 1901 integer :: i 1902 re = real(c) 1903 im = aimag(c) 1904 i = len(re, fmt) 1905 s(:i+4) = "("//safestr(re, fmt)//")+i" 1906 s(i+5:)="("//safestr(im,fmt)//")" 1907 end function str_complex_sp_fmt 1908#endif 1909 1910 pure function str_complex_sp(c) result(s) 1911 complex(sp), intent(in) :: c 1912#ifdef DUMMYLIB 1913 character(len=1) :: s 1914 s = " " 1915#else 1916 character(len=len(c, "")) :: s 1917 1918 s = safestr(c, "") 1919#endif 1920 end function str_complex_sp 1921 1922#ifndef DUMMYLIB 1923 pure function str_complex_sp_array_fmt(ca, fmt) result(s) 1924 complex(sp), dimension(:), intent(in) :: ca 1925 character(len=*), intent(in) :: fmt 1926#if defined(__PGI) 1927 character(len=len(ca, fmt)) :: s 1928#else 1929 character(len=len(ca(:), fmt)) :: s 1930#endif 1931 1932 integer :: i, n 1933 1934 s(1:len(ca(1), fmt)) = safestr(ca(1), fmt) 1935 n = len(ca(1), fmt)+1 1936 do i = 2, size(ca) 1937 s(n:n+len(ca(i), fmt)) = " "//safestr(ca(i), fmt) 1938 n = n + len(ca(i), fmt)+1 1939 enddo 1940 end function str_complex_sp_array_fmt 1941#endif 1942 1943 function str_complex_sp_array_fmt_chk(ca, fmt) result(s) 1944 complex(sp), dimension(:), intent(in) :: ca 1945 character(len=*), intent(in) :: fmt 1946#ifdef DUMMYLIB 1947 character(len=1) :: s 1948 s = " " 1949#else 1950#if defined(__PGI) 1951 character(len=len(ca, fmt)) :: s 1952#else 1953 character(len=len(ca(:), fmt)) :: s 1954#endif 1955 1956 if (checkFmt(fmt)) then 1957 s = safestr(ca, fmt) 1958 else 1959 call FoX_error("Invalid format: "//fmt) 1960 endif 1961#endif 1962 end function str_complex_sp_array_fmt_chk 1963 1964 pure function str_complex_sp_array(ca) result(s) 1965 complex(sp), dimension(:), intent(in) :: ca 1966#ifdef DUMMYLIB 1967 character(len=1) :: s 1968 s = " " 1969#else 1970#if defined(__PGI) 1971 character(len=len(ca)) :: s 1972#else 1973 character(len=len(ca(:))) :: s 1974#endif 1975 1976 s = safestr(ca, "") 1977#endif 1978 end function str_complex_sp_array 1979 1980#ifndef DUMMYLIB 1981 pure function str_complex_sp_matrix_fmt(ca, fmt) result(s) 1982 complex(sp), dimension(:, :), intent(in) :: ca 1983 character(len=*), intent(in) :: fmt 1984#if defined(__PGI) 1985 character(len=len(ca, fmt)) :: s 1986#else 1987 character(len=len(ca(:,:), fmt)) :: s 1988#endif 1989 1990 integer :: i, j, k, n 1991 1992 i = len(ca(1,1), fmt) 1993 s(:i) = safestr(ca(1,1), fmt) 1994 n = i + 1 1995 do j = 2, size(ca, 1) 1996 i = len(ca(j,1), fmt) 1997 s(n:n+i) = " "//safestr(ca(j,1), fmt) 1998 n = n + i + 1 1999 enddo 2000 do k = 2, size(ca, 2) 2001 do j = 1, size(ca, 1) 2002 i = len(ca(j,k), fmt) 2003 s(n:n+i) = " "//safestr(ca(j,k), fmt) 2004 n = n + i + 1 2005 enddo 2006 enddo 2007 2008 end function str_complex_sp_matrix_fmt 2009#endif 2010 2011 function str_complex_sp_matrix_fmt_chk(ca, fmt) result(s) 2012 complex(sp), dimension(:, :), intent(in) :: ca 2013 character(len=*), intent(in) :: fmt 2014#ifdef DUMMYLIB 2015 character(len=1) :: s 2016 s = " " 2017#else 2018#if defined(__PGI) 2019 character(len=len(ca, fmt)) :: s 2020#else 2021 character(len=len(ca(:,:), fmt)) :: s 2022#endif 2023 2024 if (checkFmt(fmt)) then 2025 s = safestr(ca, fmt) 2026 else 2027 call FoX_error("Invalid format: "//fmt) 2028 endif 2029#endif 2030 end function str_complex_sp_matrix_fmt_chk 2031 2032 pure function str_complex_sp_matrix(ca) result(s) 2033 complex(sp), dimension(:, :), intent(in) :: ca 2034#ifdef DUMMYLIB 2035 character(len=1) :: s 2036 s = " " 2037#else 2038#if defined(__PGI) 2039 character(len=len(ca)) :: s 2040#else 2041 character(len=len(ca(:,:))) :: s 2042#endif 2043 2044 s = safestr(ca, "") 2045#endif 2046 end function str_complex_sp_matrix 2047 2048 function str_complex_dp_fmt_chk(c, fmt) result(s) 2049 complex(dp), intent(in) :: c 2050 character(len=*), intent(in) :: fmt 2051#ifdef DUMMYLIB 2052 character(len=1) :: s 2053 s = " " 2054#else 2055 character(len=len(c, fmt)) :: s 2056 2057 if (checkFmt(fmt)) then 2058 s = safestr(c, fmt) 2059 else 2060 call FoX_error("Invalid format: "//fmt) 2061 endif 2062#endif 2063 end function str_complex_dp_fmt_chk 2064 2065#ifndef DUMMYLIB 2066 pure function str_complex_dp_fmt(c, fmt) result(s) 2067 complex(dp), intent(in) :: c 2068 character(len=*), intent(in) :: fmt 2069 character(len=len(c, fmt)) :: s 2070 2071 real(dp) :: re, im 2072 integer :: i 2073 re = real(c) 2074 im = aimag(c) 2075 i = len(re, fmt) 2076 s(:i+4) = "("//safestr(re, fmt)//")+i" 2077 s(i+5:)="("//safestr(im,fmt)//")" 2078 end function str_complex_dp_fmt 2079#endif 2080 2081 pure function str_complex_dp(c) result(s) 2082 complex(dp), intent(in) :: c 2083#ifdef DUMMYLIB 2084 character(len=1) :: s 2085 s = " " 2086#else 2087 character(len=len(c, "")) :: s 2088 2089 s = safestr(c, "") 2090#endif 2091 end function str_complex_dp 2092 2093#ifndef DUMMYLIB 2094 pure function str_complex_dp_array_fmt(ca, fmt) result(s) 2095 complex(dp), dimension(:), intent(in) :: ca 2096 character(len=*), intent(in) :: fmt 2097#if defined(__PGI) 2098 character(len=len(ca, fmt)) :: s 2099#else 2100 character(len=len(ca(:), fmt)) :: s 2101#endif 2102 2103 integer :: i, n 2104 2105 s(1:len(ca(1), fmt)) = safestr(ca(1), fmt) 2106 n = len(ca(1), fmt)+1 2107 do i = 2, size(ca) 2108 s(n:n+len(ca(i), fmt)) = " "//safestr(ca(i), fmt) 2109 n = n + len(ca(i), fmt)+1 2110 enddo 2111 end function str_complex_dp_array_fmt 2112#endif 2113 2114 function str_complex_dp_array_fmt_chk(ca, fmt) result(s) 2115 complex(dp), dimension(:), intent(in) :: ca 2116 character(len=*), intent(in) :: fmt 2117#ifdef DUMMYLIB 2118 character(len=1) :: s 2119 s = " " 2120#else 2121#if defined(__PGI) 2122 character(len=len(ca, fmt)) :: s 2123#else 2124 character(len=len(ca(:), fmt)) :: s 2125#endif 2126 2127 if (checkFmt(fmt)) then 2128 s = safestr(ca, fmt) 2129 else 2130 call FoX_error("Invalid format: "//fmt) 2131 endif 2132#endif 2133 end function str_complex_dp_array_fmt_chk 2134 2135 pure function str_complex_dp_array(ca) result(s) 2136 complex(dp), dimension(:), intent(in) :: ca 2137#ifdef DUMMYLIB 2138 character(len=1) :: s 2139 s = " " 2140#else 2141#if defined(__PGI) 2142 character(len=len(ca)) :: s 2143#else 2144 character(len=len(ca(:))) :: s 2145#endif 2146 2147 s = safestr(ca, "") 2148#endif 2149 end function str_complex_dp_array 2150 2151#ifndef DUMMYLIB 2152 pure function str_complex_dp_matrix_fmt(ca, fmt) result(s) 2153 complex(dp), dimension(:, :), intent(in) :: ca 2154 character(len=*), intent(in) :: fmt 2155#if defined(__PGI) 2156 character(len=len(ca, fmt)) :: s 2157#else 2158 character(len=len(ca(:,:), fmt)) :: s 2159#endif 2160 2161 integer :: i, j, k, n 2162 2163 i = len(ca(1,1), fmt) 2164 s(:i) = safestr(ca(1,1), fmt) 2165 n = i + 1 2166 do j = 2, size(ca, 1) 2167 i = len(ca(j,1), fmt) 2168 s(n:n+i) = " "//safestr(ca(j,1), fmt) 2169 n = n + i + 1 2170 enddo 2171 do k = 2, size(ca, 2) 2172 do j = 1, size(ca, 1) 2173 i = len(ca(j,k), fmt) 2174 s(n:n+i) = " "//safestr(ca(j,k), fmt) 2175 n = n + i + 1 2176 enddo 2177 enddo 2178 2179 end function str_complex_dp_matrix_fmt 2180#endif 2181 2182 function str_complex_dp_matrix_fmt_chk(ca, fmt) result(s) 2183 complex(dp), dimension(:, :), intent(in) :: ca 2184 character(len=*), intent(in) :: fmt 2185#ifdef DUMMYLIB 2186 character(len=1) :: s 2187 s = " " 2188#else 2189#if defined(__PGI) 2190 character(len=len(ca, fmt)) :: s 2191#else 2192 character(len=len(ca(:,:), fmt)) :: s 2193#endif 2194 2195 if (checkFmt(fmt)) then 2196 s = safestr(ca, fmt) 2197 else 2198 call FoX_error("Invalid format: "//fmt) 2199 endif 2200#endif 2201 end function str_complex_dp_matrix_fmt_chk 2202 2203 pure function str_complex_dp_matrix(ca) result(s) 2204 complex(dp), dimension(:, :), intent(in) :: ca 2205#ifdef DUMMYLIB 2206 character(len=1) :: s 2207 s = " " 2208#else 2209#if defined(__PGI) 2210 character(len=len(ca)) :: s 2211#else 2212 character(len=len(ca(:,:))) :: s 2213#endif 2214 2215 s = safestr(ca, "") 2216#endif 2217 end function str_complex_dp_matrix 2218 2219#ifndef DUMMYLIB 2220 pure function checkFmt(fmt) result(good) 2221 character(len=*), intent(in) :: fmt 2222 logical :: good 2223 2224 ! should be ([rs]\d*)? 2225 2226 if (len(fmt) > 0) then 2227 if (fmt(1:1) == "r" .or. fmt(1:1) == "s") then 2228 if (len(fmt) > 1) then 2229 good = (verify(fmt(2:), digit) == 0) 2230 else 2231 good = .true. 2232 endif 2233 else 2234 good = .false. 2235 endif 2236 else 2237 good = .true. 2238 endif 2239 end function checkFmt 2240#endif 2241 2242 pure function concat_str_int(s1, s2) result(s3) 2243 character(len=*), intent(in) :: s1 2244 integer, intent(in) :: s2 2245#ifdef DUMMYLIB 2246 character(len=1) :: s3 2247 s3 = " " 2248#else 2249 character(len=len(s1)+len(s2)) :: s3 2250 s3 = s1//str(s2) 2251#endif 2252 end function concat_str_int 2253 pure function concat_int_str(s1, s2) result(s3) 2254 integer, intent(in) :: s1 2255 character(len=*), intent(in) :: s2 2256#ifdef DUMMYLIB 2257 character(len=1) :: s3 2258 s3 = " " 2259#else 2260 character(len=len(s1)+len(s2)) :: s3 2261 s3 = str(s1)//s2 2262#endif 2263 end function concat_int_str 2264 2265 pure function concat_str_logical(s1, s2) result(s3) 2266 character(len=*), intent(in) :: s1 2267 logical, intent(in) :: s2 2268#ifdef DUMMYLIB 2269 character(len=1) :: s3 2270 s3 = " " 2271#else 2272 character(len=len(s1)+len(s2)) :: s3 2273 s3 = s1//str(s2) 2274#endif 2275 end function concat_str_logical 2276 pure function concat_logical_str(s1, s2) result(s3) 2277 logical, intent(in) :: s1 2278 character(len=*), intent(in) :: s2 2279#ifdef DUMMYLIB 2280 character(len=1) :: s3 2281 s3 = " " 2282#else 2283 character(len=len(s1)+len(s2)) :: s3 2284 s3 = str(s1)//s2 2285#endif 2286 end function concat_logical_str 2287 2288 pure function concat_str_real_sp(s1, s2) result(s3) 2289 character(len=*), intent(in) :: s1 2290 real(sp), intent(in) :: s2 2291#ifdef DUMMYLIB 2292 character(len=1) :: s3 2293 s3 = " " 2294#else 2295 character(len=len(s1)+len(s2)) :: s3 2296 s3 = s1//str(s2) 2297#endif 2298 end function concat_str_real_sp 2299 pure function concat_real_sp_str(s1, s2) result(s3) 2300 real(sp), intent(in) :: s1 2301 character(len=*), intent(in) :: s2 2302#ifdef DUMMYLIB 2303 character(len=1) :: s3 2304 s3 = " " 2305#else 2306 character(len=len(s1)+len(s2)) :: s3 2307 s3 = str(s1)//s2 2308#endif 2309 end function concat_real_sp_str 2310 2311 pure function concat_str_real_dp(s1, s2) result(s3) 2312 character(len=*), intent(in) :: s1 2313 real(dp), intent(in) :: s2 2314#ifdef DUMMYLIB 2315 character(len=1) :: s3 2316 s3 = " " 2317#else 2318 character(len=len(s1)+len(s2)) :: s3 2319 s3 = s1//str(s2) 2320#endif 2321 end function concat_str_real_dp 2322 pure function concat_real_dp_str(s1, s2) result(s3) 2323 real(dp), intent(in) :: s1 2324 character(len=*), intent(in) :: s2 2325#ifdef DUMMYLIB 2326 character(len=1) :: s3 2327 s3 = " " 2328#else 2329 character(len=len(s1)+len(s2)) :: s3 2330 s3 = str(s1)//s2 2331#endif 2332 end function concat_real_dp_str 2333 2334 pure function concat_str_complex_sp(s1, s2) result(s3) 2335 character(len=*), intent(in) :: s1 2336 complex(sp), intent(in) :: s2 2337#ifdef DUMMYLIB 2338 character(len=1) :: s3 2339 s3 = " " 2340#else 2341 character(len=len(s1)+len(s2)) :: s3 2342 s3 = s1//str(s2) 2343#endif 2344 end function concat_str_complex_sp 2345 pure function concat_complex_sp_str(s1, s2) result(s3) 2346 complex(sp), intent(in) :: s1 2347 character(len=*), intent(in) :: s2 2348#ifdef DUMMYLIB 2349 character(len=1) :: s3 2350 s3 = " " 2351#else 2352 character(len=len(s1)+len(s2)) :: s3 2353 s3 = str(s1)//s2 2354#endif 2355 end function concat_complex_sp_str 2356 2357 pure function concat_str_complex_dp(s1, s2) result(s3) 2358 character(len=*), intent(in) :: s1 2359 complex(dp), intent(in) :: s2 2360#ifdef DUMMYLIB 2361 character(len=1) :: s3 2362 s3 = " " 2363#else 2364 character(len=len(s1)+len(s2)) :: s3 2365 s3 = s1//str(s2) 2366#endif 2367 end function concat_str_complex_dp 2368 pure function concat_complex_dp_str(s1, s2) result(s3) 2369 complex(dp), intent(in) :: s1 2370 character(len=*), intent(in) :: s2 2371#ifdef DUMMYLIB 2372 character(len=1) :: s3 2373 s3 = " " 2374#else 2375 character(len=len(s1)+len(s2)) :: s3 2376 s3 = str(s1)//s2 2377#endif 2378 end function concat_complex_dp_str 2379 2380end module fox_m_fsys_format 2381