1!--------------------------------------------------------------------------------------------------! 2! DFTB+: general package for performing fast atomistic simulations ! 3! Copyright (C) 2006 - 2019 DFTB+ developers group ! 4! ! 5! See the LICENSE file for terms of usage and distribution. ! 6!--------------------------------------------------------------------------------------------------! 7 8#:include 'common.fypp' 9 10!> Contains high level functions for converting the values in a XML/HSD DOM-tree to Fortran 11!> intrinsic types. 12!> Todo: Some more routines for complex numbers? 13module dftbp_hsdutils 14 use dftbp_assert 15 use dftbp_xmlf90 16 use dftbp_tokenreader 17 use dftbp_hsdparser 18 use dftbp_xmlutils 19 use dftbp_charmanip 20 use dftbp_message 21 use dftbp_linkedlist 22 use dftbp_accuracy 23 implicit none 24 private 25 26 public :: checkError, detailedError, detailedWarning 27 public :: getFirstTextChild, getChildValue, setChildValue 28 public :: writeChildValue, getAsString 29 public :: convAtomRangeToInt, convRangeToInt, appendPathAndLine 30 public :: getChild, getChildren, setChild 31 public :: attrProcessed 32 33 34 !> Returns the value (the child) of a child node identified by its name. 35 !> 36 !> These routines investigate the provided node and look for a child with the supplied name. If 37 !> this child found, its child (which should be a single text node or a usual node if the value 38 !> argument is of type node) is returned as value converted to the appropriate type. If the child 39 !> is not found, an error is raised, unless a default value was specified.In that case, a child is 40 !> created with the provided name and is appended to the node. Furthermore a text node containing 41 !> the string converted default value is appended to the child node. If default value is provided, 42 !> it must be also indicated, if the created child is only allowed to have one further child or 43 !> not. (This corresponds to an assignment with '=' in the HSD input.) If the child (identified by 44 !> the provided name) is allowed to have a modifier, an argument for the modifier must be provided 45 !> to contain the the parsed value on return. If the argument for the modifier is missing, but a 46 !> modifier is found, the program raises an error. The pointer to the found (or created) child can 47 !> be queried through an appropriate argument. If the name of the child to look for is an empty 48 !> string, the passed node itself is treated as if it would be the child, which had been found. 49 interface getChildValue 50 module procedure getChVal_logical 51 module procedure getChVal_logicalR1 52 module procedure getChVal_node 53 module procedure getChVal_string 54 module procedure getChVal_lString 55 module procedure getChVal_lReal 56 module procedure getChVal_lRealR1 57 module procedure getChVal_lInt 58 module procedure getChVal_lIntR1 59 module procedure getChVal_real 60 module procedure getChVal_realR1 61 module procedure getChVal_realR2 62 module procedure getChVal_int 63 module procedure getChVal_intR1 64 module procedure getChVal_intR2 65 module procedure getChVal_lIntR1RealR1 66 module procedure getChVal_lStringIntR1RealR1 67 end interface getChildValue 68 69 70 !> Sets the value (the child) of a child node identified by its name 71 !> 72 !> Those functions are the inverse of the getChildValue functions. They create a child with the 73 !> provided name and append to that child a text node (or a normal node, if the provided value is 74 !> of type node) containing the provided value. It must be indicated, if the created child is 75 !> allowed to have only one single further child. If a child with the specified name already 76 !> exists, the program raises an error, unless replacement flag is set on .true.. In that case, 77 !> the the existing child is replaced. If the name of the child is the empty string, the current 78 !> node is treated as if it would be the child, which had been found. 79 interface setChildValue 80 module procedure setChVal_logical 81 module procedure setChVal_logicalR1 82 module procedure setChVal_node 83 module procedure setChVal_char 84 module procedure setChVal_charR1 85 module procedure setChVal_real 86 module procedure setChVal_realR1 87 module procedure setChVal_realR2 88 module procedure setChVal_int 89 module procedure setChVal_intR1 90 module procedure setChVal_intR2 91 module procedure setChVal_intR2RealR2 92 module procedure setChVal_charR1intR2RealR2 93 end interface setChildValue 94 95 96 !> Writes a child and its value to an xml-write stream 97 interface writeChildValue 98 module procedure writeChVal_logical 99 module procedure writeChVal_logicalR1 100 module procedure writeChVal_real 101 module procedure writeChVal_realR1 102 module procedure writeChVal_realR2 103 module procedure writeChVal_int 104 module procedure writeChVal_intR1 105 module procedure writeChVal_intR2 106 module procedure writeChVal_intR2RealR2 107 module procedure writeChVal_charR1 108 module procedure writeChVal_charR1IntR2RealR2 109 end interface writeChildValue 110 111 112 !> Returns a string representation of an object 113 interface getAsString 114 module procedure getAsString_logical 115 module procedure getAsString_logicalR1 116 module procedure getAsString_real 117 module procedure getAsString_realR1 118 module procedure getAsString_realR2 119 module procedure getAsString_int 120 module procedure getAsString_intR1 121 module procedure getAsString_intR2 122 module procedure getAsString_intR2RealR2 123 module procedure getAsString_charR1 124 module procedure getAsString_charR1IntR2RealR2 125 end interface getAsString 126 127 128 !> Error messages 129 character(len=*), parameter :: MSG_MISSING_FIELD = "Missing child: " 130 character(len=*), parameter :: MSG_EXISTING_CHILD = "Already existing child: " 131 character(len=*), parameter :: MSG_NOMODIFIER = "Entity is not allowed to & 132 &have a modifier" 133 character(len=*), parameter :: MSG_MISSING_VALUES = "Not enough values & 134 &provided." 135 136 137 !> Length of a line (for wrapping long lines when writing values) 138 integer, parameter :: lineLength = 80 139 140 141 !> Maximal number of characters needed to represent an integer 142 integer, parameter :: nCharInt = 50 143 144 145 !> Maximal number of characters needed to represent a real number 146 integer, parameter :: nCharReal = 50 147 148 149 !> Maximal number of characters needed to represent a logical value 150 integer, parameter :: nCharLogical = 4 151 152 153 !> Attribute signals that a tag was processed 154 character(len=*), parameter :: attrProcessed = "proc" 155 156 157 !> Preallocateated size for temporary buffer strings 158 integer, parameter :: preAllocSize = 1024 159 160contains 161 162 163 !> Returns the value (the child) of a child node as logical. 164 subroutine getChVal_logical(node, name, variableValue, default, modifier, child) 165 166 !> The node to investigate. 167 type(fnode), pointer :: node 168 169 !> Name of the child to look for 170 character(len=*), intent(in) :: name 171 172 !> Value on return 173 logical, intent(out) :: variableValue 174 175 !> Default value for the child, if child is not found 176 logical, intent(in), optional :: default 177 178 !> Modifier of the child on return 179 type(string), intent(inout), optional :: modifier 180 181 !> Pointer to the child node (with the spec. name) on return 182 type(fnode), pointer, optional :: child 183 184 type(string) :: text, modif 185 integer :: iStart, iErr 186 type(fnode), pointer :: child2 187 188 @:ASSERT(associated(node)) 189 190 child2 => getFirstChildByName(node, tolower(name)) 191 if (associated(child2)) then 192 call getAttribute(child2, attrModifier, modif) 193 if (present(modifier)) then 194 modifier = modif 195 elseif (len(modif) > 0) then 196 call detailedError(child2, MSG_NOMODIFIER) 197 end if 198 iStart = 1 199 call getFirstTextChild(child2, text) 200 call getNextToken(char(text), variableValue, iStart, iErr) 201 call checkError(child2, iErr, "Invalid logical value") 202 call checkNoData(child2, char(text), iStart) 203 call setAttribute(child2, attrProcessed, "") 204 elseif (present(default)) then 205 variableValue = default 206 if (present(modifier)) then 207 modifier = "" 208 end if 209 call setChildValue(node, name, variableValue, .false., child=child2) 210 else 211 call detailedError(node, MSG_MISSING_FIELD // name) 212 end if 213 if (present(child)) then 214 child => child2 215 end if 216 217 end subroutine getChVal_logical 218 219 220 !> Returns the value (the child) of a child node as logical. 221 subroutine getChVal_logicalR1(node, name, variableValue, default, nItem, modifier, child) 222 223 !> The node to investigate. 224 type(fnode), pointer :: node 225 226 !> Name of the child to look for 227 character(len=*), intent(in) :: name 228 229 !> Value on return 230 logical, intent(out) :: variableValue(:) 231 232 !> Default value for the child, if child is not found 233 logical, intent(in), optional :: default(:) 234 235 !> Nr. of read items. If this argument is not passed, and the nr. of read items is less than the 236 !> size of the array, the subroutine raises an error. 237 integer, intent(out), optional :: nItem 238 239 !> Modifier of the child on return 240 type(string), intent(inout), optional :: modifier 241 242 !> Pointer to the child node (with the spec. name) on return 243 type(fnode), pointer, optional :: child 244 245 type(string) :: text, modif 246 integer :: iStart, iErr, nReadItem 247 type(fnode), pointer :: child2 248 249 @:ASSERT(associated(node)) 250 #:call ASSERT_CODE 251 if (present(default)) then 252 @:ASSERT(all(shape(default) == shape(variableValue))) 253 end if 254 #:endcall ASSERT_CODE 255 256 if (present(nItem)) then 257 nItem = 0 258 end if 259 child2 => getFirstChildByName(node, tolower(name)) 260 if (associated(child2)) then 261 call getAttribute(child2, attrModifier, modif) 262 if (present(modifier)) then 263 modifier = modif 264 elseif (len(modif) > 0) then 265 call detailedError(child2, MSG_NOMODIFIER) 266 end if 267 iStart = 1 268 call getFirstTextChild(child2, text) 269 call getNextToken(char(text), variableValue, iStart, iErr, nReadItem) 270 call checkError(child2, iErr, "Invalid logical value") 271 call checkNoData(child2, char(text), iStart) 272 if (present(nItem)) then 273 nItem = nReadItem 274 elseif (nReadItem /= size(variableValue)) then 275 call detailedError(node, MSG_MISSING_VALUES) 276 end if 277 call setAttribute(child2, attrProcessed, "") 278 elseif (present(default)) then 279 variableValue = default 280 if (present(nItem)) then 281 nItem = size(default) 282 end if 283 if (present(modifier)) then 284 modifier = "" 285 end if 286 call setChildValue(node, name, variableValue, .false., child=child2) 287 else 288 call detailedError(node, MSG_MISSING_FIELD // name) 289 end if 290 call setAttribute(child2, attrProcessed, "") 291 if (present(child)) then 292 child => child2 293 end if 294 295 end subroutine getChVal_logicalR1 296 297 298 !> Returns the value (the child) of a child node as string. 299 subroutine getChVal_string(node, name, variableValue, default, modifier, child, multiple) 300 301 !> The node to investigate. 302 type(fnode), pointer :: node 303 304 !> Name of the child to look for 305 character(len=*), intent(in) :: name 306 307 !> Value on return 308 type(string), intent(inout) :: variableValue 309 310 !> Default value for the child, if child is not found 311 character(len=*), intent(in), optional :: default 312 313 !> Modifier of the child on return 314 type(string), intent(inout), optional :: modifier 315 316 !> Pointer to the child node (with the spec. name) on return 317 type(fnode), pointer, optional :: child 318 319 !> If true, string contains as many tokens as possible, not just one (with spaces between the 320 !> tokens). 321 logical, intent(in), optional :: multiple 322 323 type(string) :: text, modif 324 integer :: iStart, iErr 325 type(fnode), pointer :: child2 326 logical :: tMultiple 327 328 @:ASSERT(associated(node)) 329 330 if (present(multiple)) then 331 tMultiple = multiple 332 else 333 tMultiple = .false. 334 end if 335 336 child2 => getFirstChildByName(node, tolower(name)) 337 if (associated(child2)) then 338 call getAttribute(child2, attrModifier, modif) 339 if (present(modifier)) then 340 modifier = modif 341 elseif (len(modif) > 0) then 342 call detailedError(child2, MSG_NOMODIFIER) 343 end if 344 call getFirstTextChild(child2, text) 345 if (tMultiple) then 346 variableValue = unquote(trim(adjustl(char(text)))) 347 else 348 iStart = 1 349 call getNextToken(char(text), variableValue, iStart, iErr) 350 call checkError(child2, iErr, "Invalid string value") 351 call checkNoData(child2, char(text), iStart) 352 end if 353 call setAttribute(child2, attrProcessed, "") 354 elseif (present(default)) then 355 variableValue = default 356 if (present(modifier)) then 357 modifier = "" 358 end if 359 call setChildValue(node, name, default, .false., child=child2) 360 else 361 call detailedError(node, MSG_MISSING_FIELD // name) 362 end if 363 if (present(child)) then 364 child => child2 365 end if 366 367 end subroutine getChVal_string 368 369 370 !> Returns the value (the child) of a child node as real. 371 subroutine getChVal_real(node, name, variableValue, default, modifier, child) 372 373 !> The node to investigate. 374 type(fnode), pointer :: node 375 376 !> Name of the child to look for 377 character(len=*), intent(in) :: name 378 379 !> Value on return 380 real(dp), intent(out) :: variableValue 381 382 !> Default value for the child, if child is not found 383 real(dp), intent(in), optional :: default 384 385 !> Modifier of the child on return 386 type(string), intent(inout), optional :: modifier 387 388 !> Pointer to the child node (with the spec. name) on return 389 type(fnode), pointer, optional :: child 390 391 type(string) :: text, modif 392 integer :: iStart, iErr 393 type(fnode), pointer :: child2 394 395 @:ASSERT(associated(node)) 396 397 child2 => getFirstChildByName(node, tolower(name)) 398 if (associated(child2)) then 399 call getAttribute(child2, attrModifier, modif) 400 if (present(modifier)) then 401 modifier = modif 402 elseif (len(modif) > 0) then 403 call detailedError(child2, MSG_NOMODIFIER) 404 end if 405 iStart = 1 406 call getFirstTextChild(child2, text) 407 call getNextToken(char(text), variableValue, iStart, iErr) 408 call checkError(child2, iErr, "Invalid real value") 409 call checkNoData(child2, char(text), iStart) 410 call setAttribute(child2, attrProcessed, "") 411 elseif (present(default)) then 412 variableValue = default 413 if (present(modifier)) then 414 modifier = "" 415 end if 416 call setChildValue(node, name, variableValue, .false., child=child2) 417 else 418 call detailedError(node, MSG_MISSING_FIELD // name) 419 end if 420 call setAttribute(child2, attrProcessed, "") 421 if (present(child)) then 422 child => child2 423 end if 424 425 end subroutine getChVal_real 426 427 428 !> Returns the value (the child) of a child node as a rank one real array. 429 subroutine getChVal_realR1(node, name, variableValue, default, nItem, modifier, child) 430 431 !> The node to investigate. 432 type(fnode), pointer :: node 433 434 !> Name of the child to look for 435 character(len=*), intent(in) :: name 436 437 !> Value on return 438 real(dp), intent(out) :: variableValue(:) 439 440 !> Default value for the child, if child is not found 441 real(dp), intent(in), optional :: default(:) 442 443 !> Nr. of read items. If this argument is not passed, and the nr. of read items is less than the 444 !> size of the array, the subroutine raises an error. 445 integer, intent(out), optional :: nItem 446 447 !> Modifier of the child on return 448 type(string), intent(inout), optional :: modifier 449 450 !> Pointer to the child node (with the spec. name) on return 451 type(fnode), pointer, optional :: child 452 453 type(string) :: text, modif 454 integer :: iStart, iErr, nReadItem 455 type(fnode), pointer :: child2 456 457 @:ASSERT(associated(node)) 458 #:call ASSERT_CODE 459 if (present(default)) then 460 @:ASSERT(all(shape(default) == shape(variableValue))) 461 end if 462 #:endcall ASSERT_CODE 463 464 if (present(nItem)) then 465 nItem = 0 466 end if 467 child2 => getFirstChildByName(node, tolower(name)) 468 if (associated(child2)) then 469 call getAttribute(child2, attrModifier, modif) 470 if (present(modifier)) then 471 modifier = modif 472 elseif (len(modif) > 0) then 473 call detailedError(child2, MSG_NOMODIFIER) 474 end if 475 iStart = 1 476 call getFirstTextChild(child2, text) 477 call getNextToken(char(text), variableValue, iStart, iErr, nReadItem) 478 call checkError(child2, iErr, "Invalid real value") 479 call checkNoData(child2, char(text), iStart) 480 if (present(nItem)) then 481 nItem = nReadItem 482 elseif (nReadItem /= size(variableValue)) then 483 call detailedError(node, MSG_MISSING_VALUES) 484 end if 485 call setAttribute(child2, attrProcessed, "") 486 elseif (present(default)) then 487 variableValue = default 488 if (present(nItem)) then 489 nItem = size(default) 490 end if 491 if (present(modifier)) then 492 modifier = "" 493 end if 494 call setChildValue(node, name, variableValue, .false., child=child2) 495 else 496 call detailedError(node, MSG_MISSING_FIELD // name) 497 end if 498 call setAttribute(child2, attrProcessed, "") 499 if (present(child)) then 500 child => child2 501 end if 502 503 end subroutine getChVal_realR1 504 505 506 !> Returns the value (the child) of a child node as a rank two real array. 507 !> 508 !> This is just a wrapper around the rank one version, to make sure that two dimensional arrays 509 !> are pretty printed. For higher ranked arrays the rank one version should be used with some 510 !> reshaping after. 511 subroutine getChVal_realR2(node, name, variableValue, default, nItem, modifier, child) 512 513 !> The node to investigate. 514 type(fnode), pointer :: node 515 516 !> Name of the child to look for 517 character(len=*), intent(in) :: name 518 519 !> Value on return 520 real(dp), intent(out) :: variableValue(:,:) 521 522 !> Default value for the child, if child is not found 523 real(dp), intent(in), optional :: default(:,:) 524 525 !> Nr. of read items. If this argument is not passed, and the nr. of read items is less than the 526 !> size of the array, the subroutine raises an error. 527 integer, intent(out), optional :: nItem 528 529 !> Modifier of the child on return 530 type(string), intent(inout), optional :: modifier 531 532 !> Pointer to the child node (with the spec. name) on return 533 type(fnode), pointer, optional :: child 534 535 real(dp) :: buffer(size(variableValue)) 536 integer :: nReadItem 537 type(string) :: modif 538 type(fnode), pointer :: child2 539 540 @:ASSERT(associated(node)) 541 #:call ASSERT_CODE 542 if (present(default)) then 543 @:ASSERT(all(shape(default) == shape(variableValue))) 544 end if 545 #:endcall ASSERT_CODE 546 547 nReadItem = 0 548 variableValue = 0.0_dp 549 if (present(default)) then 550 call getChildValue(node, name, buffer, reshape(default, shape(buffer)), & 551 &nReadItem, modifier=modif, child=child2) 552 else 553 call getChildValue(node, name, buffer, nItem=nReadItem, modifier=modif, & 554 &child=child2) 555 end if 556 if (present(nItem)) then 557 nItem = nReadItem 558 elseif (nReadItem /= size(variableValue)) then 559 call detailedError(node, MSG_MISSING_VALUES) 560 end if 561 if (present(modifier)) then 562 modifier = modif 563 elseif (len(modif) > 0) then 564 call detailedError(child2, MSG_NOMODIFIER) 565 end if 566 variableValue(:,:) = reshape(buffer, shape(variableValue)) 567 if (present(child)) then 568 child => child2 569 end if 570 571 end subroutine getChVal_realR2 572 573 574 !> Returns the value (the child) of a child node as integer. 575 subroutine getChVal_int(node, name, variableValue, default, modifier, child) 576 577 !> The node to investigate. 578 type(fnode), pointer :: node 579 580 !> Name of the child to look for 581 character(len=*), intent(in) :: name 582 583 !> Value on return 584 integer, intent(out) :: variableValue 585 586 !> Default value for the child, if child is not found 587 integer, intent(in), optional :: default 588 589 !> Modifier of the child on return 590 type(string), intent(inout), optional :: modifier 591 592 !> Pointer to the child node (with the spec. name) on return 593 type(fnode), pointer, optional :: child 594 595 type(string) :: text, modif 596 integer :: iStart, iErr 597 type(fnode), pointer :: child2 598 599 @:ASSERT(associated(node)) 600 601 child2 => getFirstChildByName(node, tolower(name)) 602 if (associated(child2)) then 603 call getAttribute(child2, attrModifier, modif) 604 if (present(modifier)) then 605 modifier = modif 606 elseif (len(modif) > 0) then 607 call detailedError(child2, MSG_NOMODIFIER) 608 end if 609 iStart = 1 610 call getFirstTextChild(child2, text) 611 call getNextToken(char(text), variableValue, iStart, iErr) 612 call checkError(child2, iErr, "Invalid integer variableValue") 613 call checkNoData(child2, char(text), iStart) 614 call setAttribute(child2, attrProcessed, "") 615 elseif (present(default)) then 616 variableValue = default 617 if (present(modifier)) then 618 modifier = "" 619 end if 620 call setChildValue(node, name, variableValue, .false., child=child2) 621 else 622 call detailedError(node, MSG_MISSING_FIELD // name) 623 end if 624 if (present(child)) then 625 child => child2 626 end if 627 628 end subroutine getChVal_int 629 630 631 !> Returns the value (the child) of a child node as a rank one integer array. 632 subroutine getChVal_intR1(node, name, variableValue, default, nItem, modifier, child) 633 634 !> The node to investigate. 635 type(fnode), pointer :: node 636 637 !> Name of the child to look for 638 character(len=*), intent(in) :: name 639 640 !> Value on return 641 integer, intent(out) :: variableValue(:) 642 643 !> Default value for the child, if child is not found 644 integer, intent(in), optional :: default(:) 645 646 !> Nr. of read items. If this argument is not passed, and the nr. of read items is less than the 647 !> size of the array, the subroutine raises an error. 648 integer, intent(out), optional :: nItem 649 650 !> Modifier of the child on return 651 type(string), intent(inout), optional :: modifier 652 653 !> Pointer to the child node (with the spec. name) on return 654 type(fnode), pointer, optional :: child 655 656 type(string) :: text, modif 657 integer :: iStart, iErr, nReadItem 658 type(fnode), pointer :: child2 659 660 @:ASSERT(associated(node)) 661 #:call ASSERT_CODE 662 if (present(default)) then 663 @:ASSERT(all(shape(default) == shape(variableValue))) 664 end if 665 #:endcall ASSERT_CODE 666 667 if (present(nItem)) then 668 nItem = 0 669 end if 670 child2 => getFirstChildByName(node, tolower(name)) 671 if (associated(child2)) then 672 call getAttribute(child2, attrModifier, modif) 673 if (present(modifier)) then 674 modifier = modif 675 elseif (len(modif) > 0) then 676 call detailedError(child2, MSG_NOMODIFIER) 677 end if 678 iStart = 1 679 call getFirstTextChild(child2, text) 680 call getNextToken(char(text), variableValue, iStart, iErr, nReadItem) 681 call checkError(child2, iErr, "Invalid integer value") 682 call checkNoData(child2, char(text), iStart) 683 if (present(nItem)) then 684 nItem = nReadItem 685 elseif (nReadItem /= size(variableValue)) then 686 call detailedError(node, MSG_MISSING_VALUES) 687 end if 688 call setAttribute(child2, attrProcessed, "") 689 elseif (present(default)) then 690 variableValue = default 691 if (present(nItem)) then 692 nItem = size(default) 693 end if 694 if (present(modifier)) then 695 modifier = "" 696 end if 697 call setChildValue(node, name, variableValue, .false., child=child2) 698 else 699 call detailedError(node, MSG_MISSING_FIELD // name) 700 end if 701 if (present(child)) then 702 child => child2 703 end if 704 705 end subroutine getChVal_intR1 706 707 708 !> Returns the value (the child) of a child node as a rank two integer array. 709 !> 710 !> This is just a wrapper around the rank one version, to make sure that two dimensional arrays 711 !> are pretty printed. For higher ranked arrays the rank one version should be used with some 712 !> reshaping after. 713 subroutine getChVal_intR2(node, name, variableValue, default, nItem, modifier, child) 714 715 !> The node to investigate. 716 type(fnode), pointer :: node 717 718 !> Name of the child to look for 719 character(len=*), intent(in) :: name 720 721 !> Value on return 722 integer, intent(out) :: variableValue(:,:) 723 724 !> Default value for the child, if child is not found 725 integer, intent(in), optional :: default(:,:) 726 727 !> Nr. of read items. If this argument is not passed, and the nr. of read items is less than the 728 !> size of the array, the subroutine raises an error. 729 integer, intent(out), optional :: nItem 730 731 !> Modifier of the child on return 732 type(string), intent(inout), optional :: modifier 733 734 !> Pointer to the child node (with the spec. name) on return 735 type(fnode), pointer, optional :: child 736 737 integer :: buffer(size(variableValue)) 738 integer :: nReadItem 739 type(string) :: modif 740 type(fnode), pointer :: child2 741 742 @:ASSERT(associated(node)) 743 #:call ASSERT_CODE 744 if (present(default)) then 745 @:ASSERT(all(shape(default) == shape(variableValue))) 746 end if 747 #:endcall ASSERT_CODE 748 749 nReadItem = 0 750 if (present(default)) then 751 call getChildValue(node, name, buffer, reshape(default, shape(buffer)), & 752 &nReadItem, modif, child=child2) 753 else 754 call getChildValue(node, name, buffer, nItem=nReadItem, modifier=modif, & 755 &child=child2) 756 end if 757 if (present(nItem)) then 758 nItem = nReadItem 759 elseif (nReadItem /= size(variableValue)) then 760 call detailedError(node, MSG_MISSING_VALUES) 761 end if 762 if (present(modifier)) then 763 modifier = modif 764 elseif (len(modif) > 0) then 765 call detailedError(child2, MSG_NOMODIFIER) 766 end if 767 variableValue(:,:) = reshape(buffer, shape(variableValue)) 768 if (present(child)) then 769 child => child2 770 end if 771 772 end subroutine getChVal_intR2 773 774 775 !> Returns the value (the child) of a child node as a linked list of strings. 776 !> 777 !> In order to prevent a double packaging (from array to linked list and then from linked list to 778 !> array), the setting of defaults for list types is not allowed. The presence of the child must 779 !> be explicitely queried in the caller routine and an eventual default setting must be set with 780 !> an explicit setChildValue call. 781 subroutine getChVal_lString(node, name, variableValue, modifier, child) 782 783 !> The node to investigate. 784 type(fnode), pointer :: node 785 786 !> Name of the child to look for 787 character(len=*), intent(in) :: name 788 789 !> Value on return 790 type(listString), intent(inout) :: variableValue 791 792 !> Modifier of the child on return 793 type(string), intent(inout), optional :: modifier 794 795 !> Pointer to the child node (with the spec. name) on return 796 type(fnode), pointer, optional :: child 797 798 type(string) :: text, modif 799 type(fnode), pointer :: child2 800 801 @:ASSERT(associated(node)) 802 child2 => getFirstChildByName(node, tolower(name)) 803 if (associated(child2)) then 804 call getAttribute(child2, attrModifier, modif) 805 if (present(modifier)) then 806 modifier = modif 807 elseif (len(modif) > 0) then 808 call detailedError(child2, MSG_NOMODIFIER) 809 end if 810 call getFirstTextChild(child2, text) 811 call getChVal_lString_h(char(text), variableValue, child2) 812 call setAttribute(child2, attrProcessed, "") 813 else 814 call detailedError(node, MSG_MISSING_FIELD // name) 815 end if 816 if (present(child)) then 817 child => child2 818 end if 819 820 end subroutine getChVal_lString 821 822 823 !> Helper function for getChVal_lString to avoid string to character conversion in the do-loop. 824 subroutine getChVal_lString_h(text, variableValue, node) 825 826 !> Text to parse 827 character(len=*), intent(in) :: text 828 829 !> Contains the value of the parsed text 830 type(listString), intent(inout) :: variableValue 831 832 !> node for error handling 833 type(fnode), pointer :: node 834 835 integer :: iStart, iErr 836 type(string) :: token 837 838 iStart = 1 839 call getNextToken(text, token, iStart, iErr) 840 do while (iErr == TOKEN_OK) 841 call append(variableValue, trim(unquote(char(token)))) 842 call getNextToken(text, token, iStart, iErr) 843 end do 844 if (iErr == TOKEN_ERROR) then 845 call detailedError(node, "Invalid string") 846 end if 847 848 end subroutine getChVal_lString_h 849 850 851 !> Returns the value (the child) of a child node as a linked list of reals. 852 !> 853 !> In order to prevent a double packaging (from array to linked list and then from linked list to 854 !> array), the setting of defaults for list types is not allowed. The presence of the child must 855 !> be explicitely queried in the caller routine and an eventual default setting must be set with 856 !> an explicit setChildValue call. 857 subroutine getChVal_lReal(node, name, variableValue, modifier, child) 858 859 !> The node to investigate. 860 type(fnode), pointer :: node 861 862 !> Name of the child to look for 863 character(len=*), intent(in) :: name 864 865 !> Value on return 866 type(listReal), intent(inout) :: variableValue 867 868 !> Modifier of the child on return 869 type(string), intent(inout), optional :: modifier 870 871 !> Pointer to the child node (with the spec. name) on return 872 type(fnode), pointer, optional :: child 873 874 type(string) :: text, modif 875 type(fnode), pointer :: child2 876 877 @:ASSERT(associated(node)) 878 879 child2 => getFirstChildByName(node, tolower(name)) 880 if (associated(child2)) then 881 call getAttribute(child2, attrModifier, modif) 882 if (present(modifier)) then 883 modifier = modif 884 elseif (len(modif) > 0) then 885 call detailedError(child2, MSG_NOMODIFIER) 886 end if 887 call getFirstTextChild(child2, text) 888 call getChVal_lReal_h(char(text), variableValue, child2) 889 call setAttribute(child2, attrProcessed, "") 890 else 891 call detailedError(node, MSG_MISSING_FIELD // name) 892 end if 893 if (present(child)) then 894 child => child2 895 end if 896 897 end subroutine getChVal_lReal 898 899 900 !> Helper function for getChVal_lReal to avoid string to character conversion in the do-loop. 901 subroutine getChVal_lReal_h(text, variableValue, node) 902 903 !> text Text to parse 904 character(len=*), intent(in) :: text 905 906 !> value Contains the value of the parsed text 907 type(listReal), intent(inout) :: variableValue 908 type(fnode), pointer :: node 909 910 integer :: iStart, iErr 911 real(dp) :: buffer 912 913 iStart = 1 914 call getNextToken(text, buffer, iStart, iErr) 915 do while (iErr == TOKEN_OK) 916 call append(variableValue, buffer) 917 call getNextToken(text, buffer, iStart, iErr) 918 end do 919 if (iErr == TOKEN_ERROR) then 920 call detailedError(node, "Invalid real value") 921 end if 922 923 end subroutine getChVal_lReal_h 924 925 926 !> Returns the value (the child) of a child node as a linked list of rank one real arrays. 927 !> 928 !> In order to prevent a double packaging (from array to linked list and then from linked list to 929 !> array), the setting of defaults for list types is not allowed. The presence of the child must 930 !> be explicitely queried in the caller routine and an eventual default setting must be set with 931 !> an explicit setChildValue call. 932 subroutine getChVal_lRealR1(node, name, dim, variableValue, modifier, child) 933 934 !> The node to investigate. 935 type(fnode), pointer :: node 936 937 !> Name of the child to look for 938 character(len=*), intent(in) :: name 939 940 !> Dimension of the arrays 941 integer, intent(in) :: dim 942 943 !> Value on return 944 type(listRealR1), intent(inout) :: variableValue 945 946 !> Modifier of the child on return 947 type(string), intent(inout), optional :: modifier 948 949 !> Pointer to the child node (with the spec. name) on return 950 type(fnode), pointer, optional :: child 951 952 type(string) :: text, modif 953 type(fnode), pointer :: child2 954 955 @:ASSERT(associated(node)) 956 957 child2 => getFirstChildByName(node, tolower(name)) 958 if (associated(child2)) then 959 call getAttribute(child2, attrModifier, modif) 960 if (present(modifier)) then 961 modifier = modif 962 elseif (len(modif) > 0) then 963 call detailedError(child2, MSG_NOMODIFIER) 964 end if 965 call getFirstTextChild(child2, text) 966 call getChVal_lRealR1_h(char(text), dim, variableValue, child2) 967 call setAttribute(child2, attrProcessed, "") 968 else 969 call detailedError(node, MSG_MISSING_FIELD // name) 970 end if 971 if (present(child)) then 972 child => child2 973 end if 974 975 end subroutine getChVal_lRealR1 976 977 978 !> Helper function for getChVal_lReal to avoid string to character conversion in the do-loop. 979 subroutine getChVal_lRealR1_h(text, dim, variableValue, node) 980 981 !> Text to parse 982 character(len=*), intent(in) :: text 983 984 !> buffer sizing 985 integer, intent(in) :: dim 986 987 !> Contains the value of the parsed text 988 type(listRealR1), intent(inout) :: variableValue 989 990 !> nodes for error handling 991 type(fnode), pointer :: node 992 993 integer :: iStart, iErr 994 real(dp) :: buffer(dim) 995 integer :: nItem 996 997 iStart = 1 998 call getNextToken(text, buffer, iStart, iErr, nItem) 999 do while (iErr == TOKEN_OK) 1000 call append(variableValue, buffer) 1001 call getNextToken(text, buffer, iStart, iErr, nItem) 1002 end do 1003 if (iErr == TOKEN_ERROR) then 1004 call detailedError(node, "Invalid real value") 1005 elseif (iErr == TOKEN_EOS .and. nItem /= 0) then 1006 call detailedError(node, "Unexpected end of data") 1007 end if 1008 1009 end subroutine getChVal_lRealR1_h 1010 1011 1012 !> Returns the value (the child) of a child node as linked list of integers. 1013 !> 1014 !> In order to prevent a double packaging (from array to linked list and then from linked list to 1015 !> array), the setting of defaults for list types is not allowed. The presence of the child must 1016 !> be explicitely queried in the caller routine and an eventual default setting must be set with 1017 !> an explicit setChildValue call. 1018 subroutine getChVal_lInt(node, name, variableValue, modifier, child) 1019 1020 !> The node to investigate. 1021 type(fnode), pointer :: node 1022 1023 !> Name of the child to look for 1024 character(len=*), intent(in) :: name 1025 1026 !> Value on return 1027 type(listInt), intent(inout) :: variableValue 1028 1029 !> Modifier of the child on return 1030 type(string), intent(inout), optional :: modifier 1031 1032 !> Pointer to the child node (with the spec. name) on return 1033 type(fnode), pointer, optional :: child 1034 1035 type(string) :: text, modif 1036 type(fnode), pointer :: child2 1037 1038 @:ASSERT(associated(node)) 1039 1040 child2 => getFirstChildByName(node, tolower(name)) 1041 if (associated(child2)) then 1042 call getAttribute(child2, attrModifier, modif) 1043 if (present(modifier)) then 1044 modifier = modif 1045 elseif (len(modif) > 0) then 1046 call detailedError(child2, MSG_NOMODIFIER) 1047 end if 1048 call getFirstTextChild(child2, text) 1049 call getChVal_lInt_h(char(text), variableValue, child2) 1050 call setAttribute(child2, attrProcessed, "") 1051 else 1052 call detailedError(node, MSG_MISSING_FIELD // name) 1053 end if 1054 if (present(child)) then 1055 child => child2 1056 end if 1057 1058 end subroutine getChVal_lInt 1059 1060 1061 !> Helper function for getChVal_lReal to avoid string to character conversion in the do-loop. 1062 subroutine getChVal_lInt_h(text, variableValue, node) 1063 1064 !> Text to parse 1065 character(len=*), intent(in) :: text 1066 1067 !> Contains the value of the parsed text 1068 type(listInt), intent(inout) :: variableValue 1069 1070 !> node for error handling 1071 type(fnode), pointer :: node 1072 1073 integer :: iStart, iErr 1074 integer :: buffer 1075 1076 iStart = 1 1077 call getNextToken(text, buffer, iStart, iErr) 1078 do while (iErr == TOKEN_OK) 1079 call append(variableValue, buffer) 1080 call getNextToken(text, buffer, iStart, iErr) 1081 end do 1082 if (iErr == TOKEN_ERROR) then 1083 call detailedError(node, "Invalid real value") 1084 end if 1085 1086 end subroutine getChVal_lInt_h 1087 1088 1089 !> Returns the value (the child) of a child node as linked list of rank one integer arrays. 1090 !> 1091 !> In order to prevent a double packaging (from array to linked list and then from linked list to 1092 !> array), the setting of defaults for list types is not allowed. The presence of the child must 1093 !> be explicitely queried in the caller routine and an eventual default setting must be set with 1094 !> an explicit setChildValue call. 1095 subroutine getChVal_lIntR1(node, name, dim, variableValue, modifier, child) 1096 1097 !> The node to investigate. 1098 type(fnode), pointer :: node 1099 1100 !> Name of the child to look for 1101 character(len=*), intent(in) :: name 1102 1103 !> Value on return 1104 integer, intent(in) :: dim 1105 1106 !> Modifier of the child on return 1107 type(listIntR1), intent(inout) :: variableValue 1108 1109 !> Pointer to the child node (with the spec. name) on return 1110 type(string), intent(inout), optional :: modifier 1111 1112 !> the child itself 1113 type(fnode), pointer, optional :: child 1114 1115 type(string) :: text, modif 1116 type(fnode), pointer :: child2 1117 1118 @:ASSERT(associated(node)) 1119 1120 child2 => getFirstChildByName(node, tolower(name)) 1121 if (associated(child2)) then 1122 call getAttribute(child2, attrModifier, modif) 1123 if (present(modifier)) then 1124 modifier = modif 1125 elseif (len(modif) > 0) then 1126 call detailedError(child2, MSG_NOMODIFIER) 1127 end if 1128 call getFirstTextChild(child2, text) 1129 call getChVal_lIntR1_h(char(text), dim, variableValue, child2) 1130 call setAttribute(child2, attrProcessed, "") 1131 else 1132 call detailedError(node, MSG_MISSING_FIELD // name) 1133 end if 1134 if (present(child)) then 1135 child => child2 1136 end if 1137 1138 end subroutine getChVal_lIntR1 1139 1140 1141 !> Helper function for getChVal_lReal to avoid string to character conversion in the do-loop. 1142 subroutine getChVal_lIntR1_h(text, dim, variableValue, node) 1143 1144 !> Text to parse 1145 character(len=*), intent(in) :: text 1146 1147 !> buffer sizing 1148 integer, intent(in) :: dim 1149 1150 !> Contains the value of the parsed text 1151 type(listIntR1), intent(inout) :: variableValue 1152 1153 !> node for error handling 1154 type(fnode), pointer :: node 1155 1156 integer :: iStart, iErr 1157 integer :: buffer(dim) 1158 integer :: nItem 1159 1160 iStart = 1 1161 call getNextToken(text, buffer, iStart, iErr, nItem) 1162 do while (iErr == TOKEN_OK) 1163 call append(variableValue, buffer) 1164 call getNextToken(text, buffer, iStart, iErr, nItem) 1165 end do 1166 if (iErr == TOKEN_ERROR) then 1167 call detailedError(node, "Invalid real value") 1168 elseif (iErr == TOKEN_EOS .and. nItem /= 0) then 1169 call detailedError(node, "Unexpected end of data") 1170 end if 1171 1172 end subroutine getChVal_lIntR1_h 1173 1174 1175 !> Returns the value (the child) of a child node as a linked list rank one integer and rank one 1176 !> real arrays. 1177 !> 1178 !> In order to prevent a double packaging (from array to linked list and then from linked list to 1179 !> array), the setting of defaults for list types is not allowed. The presence of the child must 1180 !> be explicitely queried in the caller routine and an eventual default setting must be set with 1181 !> an explicit setChildValue call. 1182 subroutine getChVal_lIntR1RealR1(node, name, dimInt, valueInt, dimReal, valueReal, modifier, & 1183 & child) 1184 1185 !> The node to investigate. 1186 type(fnode), pointer :: node 1187 1188 !> Name of the child to look for 1189 character(len=*), intent(in) :: name 1190 1191 !> Dimension of the integer arrays in the list 1192 integer, intent(in) :: dimInt 1193 1194 !> List of integer arrays on return 1195 integer, intent(in) :: dimReal 1196 1197 !> Dimensio of the real arrays in the list 1198 type(listIntR1), intent(inout) :: valueInt 1199 1200 !> List of real array on return 1201 type(listRealR1), intent(inout) :: valueReal 1202 1203 !> Modifier of the child on return 1204 type(string), intent(inout), optional :: modifier 1205 1206 !> Pointer to the child on return 1207 type(fnode), pointer, optional :: child 1208 1209 type(string) :: text, modif 1210 type(fnode), pointer :: child2 1211 1212 @:ASSERT(associated(node)) 1213 @:ASSERT(dimInt > 0) 1214 @:ASSERT(dimReal > 0) 1215 1216 child2 => getFirstChildByName(node, tolower(name)) 1217 if (associated(child2)) then 1218 call getAttribute(child2, attrModifier, modif) 1219 if (present(modifier)) then 1220 modifier = modif 1221 elseif (len(modif) > 0) then 1222 call detailedError(child2, MSG_NOMODIFIER) 1223 end if 1224 call getFirstTextChild(child2, text) 1225 call getChVal_lIntR1RealR1_h(char(text), dimInt, valueInt, & 1226 &dimReal, valueReal, child2) 1227 if (len(valueInt) /= len(valueReal)) then 1228 call detailedError(node, "Unexpected end of data") 1229 end if 1230 call setAttribute(child2, attrProcessed, "") 1231 else 1232 call detailedError(node, MSG_MISSING_FIELD // name) 1233 end if 1234 if (present(child)) then 1235 child => child2 1236 end if 1237 1238 end subroutine getChVal_lIntR1RealR1 1239 1240 1241 !> Helper function for getChVal_lIntR1RealR1 to avoid string to char conversion in the do-loop. 1242 subroutine getChVal_lIntR1RealR1_h(text, dimInt, valueInt, dimReal, valueReal, node) 1243 1244 !> Text to parse 1245 character(len=*), intent(in) :: text 1246 1247 !> integer buffer dimensioning 1248 integer, intent(in) :: dimInt 1249 1250 !> Contains the value of the integer in the parsed text 1251 type(listIntR1), intent(inout) :: valueInt 1252 1253 !> real buffer dimensioning 1254 integer, intent(in) :: dimReal 1255 1256 !> Contains the value of the real in the parsed text 1257 type(listRealR1), intent(inout) :: valueReal 1258 1259 !> for error handling 1260 type(fnode), pointer :: node 1261 1262 integer :: iStart, iErr 1263 real(dp) :: bufferReal(dimReal) 1264 integer :: bufferInt(dimInt) 1265 integer :: nItem 1266 1267 iErr = TOKEN_OK 1268 iStart = 1 1269 do while (iErr == TOKEN_OK) 1270 call getNextToken(text, bufferInt, iStart, iErr, nItem) 1271 if (iErr == TOKEN_ERROR) then 1272 call detailedError(node, "Invalid integer") 1273 elseif (iErr == TOKEN_EOS .and. nItem /= 0) then 1274 call detailedError(node, "Unexpected end of data") 1275 end if 1276 if (iErr == TOKEN_OK) then 1277 call append(valueInt, bufferInt) 1278 call getNextToken(text, bufferReal, iStart, iErr, nItem) 1279 call checkError(node, iErr, "Invalid real") 1280 if (iErr == TOKEN_OK) then 1281 call append(valueReal, bufferReal) 1282 end if 1283 end if 1284 end do 1285 1286 end subroutine getChVal_lIntR1RealR1_h 1287 1288 1289 !> Returns the value (the child) of a child node as a linked list of string, rank one integer and 1290 !> rank one real arrays. 1291 !> 1292 !> In order to prevent a double packaging (from array to linked list and then from linked list to 1293 !> array), the setting of defaults for list types is not allowed. The presence of the child must 1294 !> be explicitely queried in the caller routine and an eventual default setting must be set with 1295 !> an explicit setChildValue call. 1296 subroutine getChVal_lStringIntR1RealR1(node, name, valueStr, dimInt, valueInt, dimReal, & 1297 & valueReal, modifier, child) 1298 1299 !> The node to investigate. 1300 type(fnode), pointer :: node 1301 1302 !> Name of the child to look for 1303 character(len=*), intent(in) :: name 1304 1305 !> List of strings on return. 1306 type(listString), intent(inout) :: valueStr 1307 1308 !> Dimension of the integer arrays in the list 1309 integer, intent(in) :: dimInt 1310 1311 !> List of integer arrays on return 1312 type(listIntR1), intent(inout) :: valueInt 1313 1314 !> Dimension of the real arrays in the list 1315 integer, intent(in) :: dimReal 1316 1317 !> List of real array on return 1318 type(listRealR1), intent(inout) :: valueReal 1319 1320 !> Modifier of the child on return 1321 type(string), intent(inout), optional :: modifier 1322 1323 !> Pointer to the child on return 1324 type(fnode), pointer, optional :: child 1325 1326 type(string) :: text, modif 1327 type(fnode), pointer :: child2 1328 1329 @:ASSERT(associated(node)) 1330 @:ASSERT(dimInt > 0) 1331 @:ASSERT(dimReal > 0) 1332 1333 child2 => getFirstChildByName(node, tolower(name)) 1334 if (associated(child2)) then 1335 call getAttribute(child2, attrModifier, modif) 1336 if (present(modifier)) then 1337 modifier = modif 1338 elseif (len(modif) > 0) then 1339 call detailedError(child2, MSG_NOMODIFIER) 1340 end if 1341 call getFirstTextChild(child2, text) 1342 call getChVal_lStringIntR1RealR1_h(char(text), valueStr, & 1343 &dimInt, valueInt, dimReal, valueReal, child2) 1344 if (len(valueStr) /= len(valueInt) & 1345 &.or. len(valueInt) /= len(valueReal)) then 1346 call detailedError(node, "Unexpected end of data") 1347 end if 1348 call setAttribute(child2, attrProcessed, "") 1349 else 1350 call detailedError(node, MSG_MISSING_FIELD // name) 1351 end if 1352 if (present(child)) then 1353 child => child2 1354 end if 1355 1356 end subroutine getChVal_lStringIntR1RealR1 1357 1358 1359 !> Helper function for getChVal_lIntR1RealR1 to avoid string to char conversion in the do-loop. 1360 subroutine getChVal_lStringIntR1RealR1_h(text, valueStr, dimInt, valueInt, dimReal, valueReal, & 1361 & node) 1362 1363 !> Text to parse 1364 character(len=*), intent(in) :: text 1365 1366 !> Contains the string part of the parsed text 1367 type(listString), intent(inout) :: valueStr 1368 1369 !> integer buffer dimensioning 1370 integer, intent(in) :: dimInt 1371 1372 !> Contains the integer part of the parsed text 1373 type(listIntR1), intent(inout) :: valueInt 1374 1375 !> integer buffer dimensioning 1376 integer, intent(in) :: dimReal 1377 1378 !> Contains the real value part of the parsed text 1379 type(listRealR1), intent(inout) :: valueReal 1380 1381 !> for error handling 1382 type(fnode), pointer :: node 1383 1384 integer :: iStart, iErr 1385 real(dp) :: bufferReal(dimReal) 1386 integer :: bufferInt(dimInt) 1387 integer :: nItem 1388 type(string) :: bufferStr 1389 1390 iErr = TOKEN_OK 1391 iStart = 1 1392 do while (iErr == TOKEN_OK) 1393 call getNextToken(text, bufferStr, iStart, iErr) 1394 if (iErr == TOKEN_ERROR) then 1395 call detailedError(node, "Invalid string") 1396 elseif (iErr == TOKEN_EOS) then 1397 exit 1398 end if 1399 call append(valueStr, char(bufferStr)) 1400 1401 call getNextToken(text, bufferInt, iStart, iErr, nItem) 1402 call checkError(node, iErr, "Invalid integer") 1403 call append(valueInt, bufferInt) 1404 1405 call getNextToken(text, bufferReal, iStart, iErr, nItem) 1406 call checkError(node, iErr, "Invalid real") 1407 call append(valueReal, bufferReal) 1408 end do 1409 1410 end subroutine getChVal_lStringIntR1RealR1_h 1411 1412 1413 !> Returns the value (the child) of a child node as a node. 1414 !> 1415 !> Caveat: If allowEmptyValue is set to .true. and the child has no subnodes (empty value) then 1416 !> the returned value is an unassociated pointer 1417 subroutine getChVal_node(node, name, variableValue, default, modifier, child, list, & 1418 & allowEmptyValue, dummyValue) 1419 1420 !> The node to investigate. 1421 type(fnode), pointer :: node 1422 1423 !> Name of the child to look for 1424 character(len=*), intent(in) :: name 1425 1426 !> Value on return 1427 type(fnode), pointer :: variableValue 1428 1429 !> Default value for the child, if child is not found. If the empty string is passed as default 1430 !> value, the child is created but no value is added to it. The returned value pointer will be 1431 1432 !> unassociated. (allowEmptyValue must be explicitely set to .true.) 1433 character(len=*), intent(in), optional :: default 1434 1435 !> Modifier of the child on return 1436 type(string), intent(inout), optional :: modifier 1437 1438 !> Pointer to the child node (with the spec. name) on return 1439 type(fnode), pointer, optional :: child 1440 1441 !> If the node created as default should be tagged as list. 1442 logical, intent(in), optional :: list 1443 1444 !> If the child is allowed to have an empty value. 1445 logical, intent(in), optional :: allowEmptyValue 1446 1447 !> If true, the value is not marked as processed. 1448 logical, intent(in), optional :: dummyValue 1449 1450 type(string) :: modif 1451 type(fnode), pointer :: child2 1452 logical :: tList, tAllowEmptyVal, tDummyValue 1453 1454 @:ASSERT(associated(node)) 1455 #:call ASSERT_CODE 1456 if (present(default)) then 1457 if (len(default) == 0) then 1458 @:ASSERT(present(allowEmptyValue)) 1459 @:ASSERT(allowEmptyValue) 1460 end if 1461 end if 1462 #:endcall ASSERT_CODE 1463 1464 if (present(list)) then 1465 tList = list 1466 else 1467 tList = .false. 1468 end if 1469 if (present(allowEmptyValue)) then 1470 tAllowEmptyVal = allowEmptyValue 1471 else 1472 tAllowEmptyVal = .false. 1473 end if 1474 if (present(dummyValue)) then 1475 tDummyValue = dummyValue 1476 else 1477 tDummyValue = .false. 1478 end if 1479 1480 child2 => getFirstChildByName(node, tolower(name)) 1481 if (associated(child2)) then 1482 call getAttribute(child2, attrModifier, modif) 1483 if (present(modifier)) then 1484 modifier = modif 1485 elseif (len(modif) > 0) then 1486 call detailedError(child2, MSG_NOMODIFIER) 1487 end if 1488 variableValue => getFirstChild(child2) 1489 if ((.not. associated(variableValue)) .and. (.not. tAllowEmptyVal)) then 1490 call detailedError(child2, "Missing value") 1491 end if 1492 call setAttribute(child2, attrProcessed, "") 1493 elseif (present(default)) then 1494 if (present(modifier)) then 1495 modifier = "" 1496 end if 1497 if (len(default) > 0) then 1498 variableValue => createElement(tolower(default)) 1499 call setChildValue(node, name, variableValue, .false., child=child2, list=tList) 1500 call setAttribute(variableValue, attrName, default) 1501 else 1502 nullify(variableValue) 1503 call setChild(node, name, child2, .false., list=tList) 1504 end if 1505 else 1506 call detailedError(node, MSG_MISSING_FIELD // name) 1507 end if 1508 if (associated(variableValue) .and. .not. tDummyValue) then 1509 if (getNodeType(variableValue) == ELEMENT_NODE) then 1510 call setAttribute(variableValue, attrProcessed, "") 1511 end if 1512 end if 1513 if (present(child)) then 1514 child => child2 1515 end if 1516 1517 end subroutine getChVal_node 1518 1519 1520 !> Converts a string containing atom indices, ranges and species names to a list of atom indices. 1521 subroutine convAtomRangeToInt(str, speciesNames, species, node, val, ishift, maxRange) 1522 1523 !> String to convert 1524 character(len=*), intent(in) :: str 1525 1526 !> Contains the valid species names. 1527 character(len=*), intent(in) :: speciesNames(:) 1528 1529 !> Contains for every atom its species index 1530 integer, intent(in) :: species(:) 1531 1532 !> Master node for detailed errors. 1533 type(fnode), pointer :: node 1534 1535 !> Integer list of atom indices on return. 1536 integer, allocatable, intent(out) :: val(:) 1537 1538 !> Shift to be applied to provided atomic indices 1539 integer, intent(in), optional :: ishift 1540 1541 !> Upper range of atoms 1542 integer, intent(in), optional :: maxRange 1543 1544 type(string) :: buffer 1545 type(ListInt) :: li 1546 integer :: nAtom, iStart, iostat, shift 1547 1548 shift = 0 1549 if (present(ishift)) then 1550 shift = ishift 1551 end if 1552 if (present(maxRange)) then 1553 nAtom = maxRange 1554 else 1555 nAtom = size(species) 1556 end if 1557 call init(li) 1558 iStart = 1 1559 call getNextToken(str, buffer, iStart, iostat) 1560 do while (iostat == TOKEN_OK) 1561 call convAtomRangeToIntProcess(char(buffer), speciesNames, species, nAtom, node, li, shift) 1562 call getNextToken(str, buffer, iStart, iostat) 1563 end do 1564 allocate(val(len(li))) 1565 if (len(li) > 0) then 1566 call asArray(li, val) 1567 end if 1568 call destruct(li) 1569 1570 end subroutine convAtomRangeToInt 1571 1572 1573 !> Helper routine. 1574 subroutine convAtomRangeToIntProcess(cbuffer, speciesNames, species, nAtom, node, li, shift) 1575 1576 !> Chunk of the specified atoms 1577 character(len=*), intent(in) :: cbuffer 1578 1579 !> Name of chemical species 1580 character(len=*), intent(in) :: speciesNames(:) 1581 1582 !> Chemical species of atoms 1583 integer, intent(in) :: species(:) 1584 1585 !> Upper limit on range of atoms 1586 integer, intent(in) :: nAtom 1587 1588 !> Master node for detailed errors. 1589 type(fnode), pointer :: node 1590 1591 !> List of the converted atom numbers 1592 type(ListInt), intent(inout) :: li 1593 1594 !> Shift in lower range of index 1595 integer, intent(in) :: shift 1596 1597 integer :: iPos, bounds(2), iSp, ii 1598 integer :: iStart1, iStart2, iost(2) 1599 1600 if ((cbuffer(1:1) >= "0" .and. cbuffer(1:1) <= "9") & 1601 &.or. cbuffer(1:1) == "-") then 1602 iPos = scan(cbuffer, ":") 1603 if (iPos /= 0) then 1604 iStart1 = 1 1605 iStart2 = iPos + 1 1606 call getNextToken(cbuffer(1:iPos-1), bounds(1), iStart1, iost(1)) 1607 call getNextToken(cbuffer, bounds(2), iStart2, iost(2)) 1608 bounds = bounds + shift 1609 if (any(iost /= TOKEN_OK)) then 1610 call detailedError(node, "Invalid range specification '" & 1611 &// trim(cbuffer) // "'") 1612 end if 1613 if (any(bounds > nAtom) .or. any(bounds < -nAtom) & 1614 &.or. any(bounds == 0)) then 1615 call detailedError(node, "Specified number out of range in '" & 1616 &// trim(cbuffer) // "'") 1617 end if 1618 bounds = modulo(bounds, nAtom + 1) 1619 if (bounds(1) > bounds(2)) then 1620 call detailedError(node, "Negative range '" // trim(cbuffer) & 1621 &// "'") 1622 end if 1623 do ii = bounds(1), bounds(2) 1624 call append(li, ii) 1625 end do 1626 else 1627 iStart1 = 1 1628 call getNextToken(cbuffer, ii, iStart1, iost(1)) 1629 ii = ii + shift 1630 if (iost(1) /= TOKEN_OK) then 1631 call detailedError(node, "Invalid integer '" // trim(cbuffer) & 1632 &// "'") 1633 end if 1634 if (ii > nAtom .or. ii < -nAtom .or. ii == 0) then 1635 call detailedError(node, "Specified number (" // trim(cbuffer) // & 1636 &") out of range.") 1637 end if 1638 ii = modulo(ii, nAtom + 1) 1639 call append(li, ii) 1640 end if 1641 else 1642 ! Try to interprete it as a species name 1643 iPos = 0 1644 do iSp = 1, size(speciesNames) 1645 if (speciesNames(iSp) == cbuffer) then 1646 iPos = iSp 1647 exit 1648 end if 1649 end do 1650 if (iPos == 0) then 1651 call detailedError(node, "Invalid species name '" // trim(cbuffer) & 1652 &// "'") 1653 end if 1654 do ii = 1, nAtom 1655 if (species(ii) == iPos) then 1656 call append(li, ii) 1657 end if 1658 end do 1659 end if 1660 1661 end subroutine convAtomRangeToIntProcess 1662 1663 1664 !> Converts a string containing indices and ranges to a list of indices. 1665 subroutine convRangeToInt(str, node, val, nMax) 1666 1667 !> String to convert 1668 character(len=*), intent(in) :: str 1669 1670 !> Master node for detailed errors. 1671 type(fnode), pointer :: node 1672 1673 !> Integer list of atom indices on return. 1674 integer, allocatable, intent(out) :: val(:) 1675 1676 !> Maximum number for an index 1677 integer, intent(in) :: nMax 1678 1679 type(string) :: buffer 1680 type(ListInt) :: li 1681 integer :: iStart, iostat 1682 1683 call init(li) 1684 iStart = 1 1685 call getNextToken(str, buffer, iStart, iostat) 1686 do while (iostat == TOKEN_OK) 1687 call convRangeToIntProcess(char(buffer), nMax, node, li) 1688 call getNextToken(str, buffer, iStart, iostat) 1689 end do 1690 allocate(val(len(li))) 1691 if (len(li) > 0) then 1692 call asArray(li, val) 1693 end if 1694 call destruct(li) 1695 1696 end subroutine convRangeToInt 1697 1698 !> Helper routine. 1699 subroutine convRangeToIntProcess(cbuffer, nMax, node, li) 1700 character(len=*), intent(in) :: cbuffer 1701 integer, intent(in) :: nMax 1702 type(fnode), pointer :: node 1703 type(ListInt), intent(inout) :: li 1704 1705 integer :: iPos, bounds(2), ii 1706 integer :: iStart1, iStart2, iost(2) 1707 1708 if ((cbuffer(1:1) >= "0" .and. cbuffer(1:1) <= "9") & 1709 &.or. cbuffer(1:1) == "-") then 1710 iPos = scan(cbuffer, ":") 1711 if (iPos /= 0) then 1712 iStart1 = 1 1713 iStart2 = iPos + 1 1714 call getNextToken(cbuffer(1:iPos-1), bounds(1), iStart1, iost(1)) 1715 call getNextToken(cbuffer, bounds(2), iStart2, iost(2)) 1716 if (any(iost /= TOKEN_OK)) then 1717 call detailedError(node, "Invalid range specification '" & 1718 &// trim(cbuffer) // "'") 1719 end if 1720 if (any(bounds > nMax) .or. any(bounds < -nMax) & 1721 &.or. any(bounds == 0)) then 1722 call detailedError(node, "Specified number out of range in '" & 1723 &// trim(cbuffer) // "'") 1724 end if 1725 bounds = modulo(bounds, nMax + 1) 1726 if (bounds(1) > bounds(2)) then 1727 call detailedError(node, "Negative range '" // trim(cbuffer) & 1728 &// "'") 1729 end if 1730 do ii = bounds(1), bounds(2) 1731 call append(li, ii) 1732 end do 1733 else 1734 iStart1 = 1 1735 call getNextToken(cbuffer, ii, iStart1, iost(1)) 1736 if (iost(1) /= TOKEN_OK) then 1737 call detailedError(node, "Invalid integer '" // trim(cbuffer) & 1738 &// "'") 1739 end if 1740 if (ii > nMax .or. ii < -nMax .or. ii == 0) then 1741 call detailedError(node, "Specified number (" // trim(cbuffer) // & 1742 &") out of range.") 1743 end if 1744 call append(li, ii) 1745 end if 1746 else 1747 call detailedError(node, "Invalid range '" // trim(cbuffer) // "'") 1748 end if 1749 1750 end subroutine convRangeToIntProcess 1751 1752 !> Returns a child node with a specified name 1753 subroutine getChild(node, name, child, requested, modifier) 1754 1755 !> Node to investigate 1756 type(fnode), pointer :: node 1757 1758 !> Name of the child node to look for 1759 character(len=*), intent(in) :: name 1760 1761 !> Contains a pointer to the child on return 1762 type(fnode), pointer :: child 1763 1764 !> If true and child not found, error is issued 1765 logical, intent(in), optional :: requested 1766 1767 !> Contains modifier on exit. 1768 type(string), intent(inout), optional :: modifier 1769 1770 logical :: tRequested 1771 type(string) :: modif 1772 1773 @:ASSERT(associated(node)) 1774 1775 if (present(requested)) then 1776 tRequested = requested 1777 else 1778 tRequested = .true. 1779 end if 1780 1781 child => getFirstChildByName(node, tolower(name)) 1782 if (associated(child)) then 1783 call getAttribute(child, attrModifier, modif) 1784 if (present(modifier)) then 1785 modifier = modif 1786 elseif (len(modif) > 0) then 1787 call detailedError(child, MSG_NOMODIFIER) 1788 end if 1789 call setAttribute(child, attrProcessed, "") 1790 elseif (tRequested) then 1791 call detailedError(node, MSG_MISSING_FIELD // name) 1792 end if 1793 1794 end subroutine getChild 1795 1796 1797 !> Returns a list of children with the specified name. 1798 subroutine getChildren(node, name, children) 1799 1800 !> Parent node to investigate 1801 type(fnode), pointer :: node 1802 1803 !> Name of the children to look for 1804 character(len=*), intent(in) :: name 1805 1806 !> List of the children. 1807 type(fnodeList), pointer :: children 1808 1809 type(fnode), pointer :: child 1810 integer :: ii 1811 1812 children => getChildrenByName(node, tolower(name)) 1813 do ii = 1, getLength(children) 1814 call getItem1(children, ii, child) 1815 call setAttribute(child, attrProcessed, "") 1816 end do 1817 1818 end subroutine getChildren 1819 1820 1821 !> Sets the value (child) of a child with given name. 1822 subroutine setChVal_logical(node, name, variableValue, replace, child, modifier) 1823 1824 !> The node to investigate 1825 type(fnode), pointer :: node 1826 1827 !> Name of the child to look for 1828 character(len=*), intent(in) :: name 1829 1830 !> Value to set 1831 logical, intent(in) :: variableValue 1832 1833 !> Replace if child with same name already exists 1834 logical, intent(in), optional :: replace 1835 1836 !> Pointer to the child node (with the provided name) 1837 type(fnode), pointer, optional :: child 1838 1839 !> Optional modifier for the child 1840 character(len=*), optional, intent(in) :: modifier 1841 1842 type(string) :: strBuffer 1843 type(fnode), pointer :: child2 1844 logical :: tReplace 1845 1846 if (present(replace)) then 1847 tReplace = replace 1848 else 1849 tReplace = .false. 1850 end if 1851 1852 call getAsString(variableValue, strBuffer) 1853 call createChild_local(node, name, .false., tReplace, child2, & 1854 &variableValue=char(strBuffer)) 1855 if (present(child)) then 1856 child => child2 1857 end if 1858 if (present(modifier)) then 1859 call setAttribute(child2, attrModifier, modifier) 1860 end if 1861 1862 end subroutine setChVal_logical 1863 1864 1865 !> Sets the value (child) of a child with given name. 1866 subroutine setChVal_logicalR1(node, name, variableValue, replace, child, modifier) 1867 1868 !> The node to investigate 1869 type(fnode), pointer :: node 1870 1871 !> Name of the child to look for 1872 character(len=*), intent(in) :: name 1873 1874 !> Value to set 1875 logical, intent(in) :: variableValue(:) 1876 1877 !> Replace if child with same name already exists 1878 logical, intent(in), optional :: replace 1879 1880 !> Pointer to the child node (with the provided name) 1881 type(fnode), pointer, optional :: child 1882 1883 !> Optional modifier for the child 1884 character(len=*), optional, intent(in) :: modifier 1885 1886 type(string) :: strBuffer 1887 type(fnode), pointer :: child2 1888 logical :: tReplace 1889 1890 if (present(replace)) then 1891 tReplace = replace 1892 else 1893 tReplace = .false. 1894 end if 1895 1896 call getAsString(variableValue, strBuffer) 1897 call createChild_local(node, name, .false., tReplace, child2, & 1898 &variableValue=char(strBuffer)) 1899 if (present(child)) then 1900 child => child2 1901 end if 1902 if (present(modifier)) then 1903 call setAttribute(child2, attrModifier, modifier) 1904 end if 1905 1906 end subroutine setChVal_logicalR1 1907 1908 1909 !> Writes the text representation of a node and its value to an xmlwriter. 1910 subroutine writeChVal_logical(xf, name, variableValue) 1911 1912 !> Xmlwriter stream 1913 type(xmlf_t), intent(inout) :: xf 1914 1915 !> Name of the node 1916 character(len=*), intent(in) :: name 1917 1918 !> Value of the node 1919 logical, intent(in) :: variableValue 1920 1921 type(string) :: strBuffer 1922 1923 call getAsString(variableValue, strBuffer) 1924 call writeChild_local(xf, name, char(strBuffer)) 1925 1926 end subroutine writeChVal_logical 1927 1928 1929 !> Writes the text representation of a node and its value to an xmlwriter. 1930 subroutine writeChVal_logicalR1(xf, name, variableValue) 1931 1932 !> Xmlwriter stream 1933 type(xmlf_t), intent(inout) :: xf 1934 1935 !> Name of the node 1936 character(len=*), intent(in) :: name 1937 1938 !> Value of the node 1939 logical, intent(in) :: variableValue(:) 1940 1941 type(string) :: strBuffer 1942 1943 call getAsString(variableValue, strBuffer) 1944 call writeChild_local(xf, name, char(strBuffer)) 1945 1946 end subroutine writeChVal_logicalR1 1947 1948 1949 !> Returns the text representation of the passed object 1950 subroutine getAsString_logical(variableValue, strBuffer) 1951 1952 !> Value to represent 1953 logical, intent(in) :: variableValue 1954 1955 !> Text representation on exit 1956 type(string), intent(inout) :: strBuffer 1957 1958 if (variableValue) then 1959 strBuffer = LOGICAL_TRUE 1960 else 1961 strBuffer = LOGICAL_FALSE 1962 end if 1963 1964 end subroutine getAsString_logical 1965 1966 1967 !> Returns the text representation of the passed object 1968 subroutine getAsString_logicalR1(variableValue, strBuffer) 1969 1970 !> Value to represent 1971 logical, intent(in) :: variableValue(:) 1972 1973 !> Text representation on exit 1974 type(string), intent(inout) :: strBuffer 1975 1976 character(len=nCharLogical) :: buffer 1977 integer :: buffLen, len 1978 integer :: ii 1979 1980 call resize_string(strBuffer, preAllocSize) 1981 len = 0 1982 do ii = 1, size(variableValue) 1983 if (variableValue(ii)) then 1984 write (buffer, *)LOGICAL_TRUE 1985 else 1986 write (buffer, *)LOGICAL_FALSE 1987 end if 1988 buffer = adjustl(buffer) 1989 buffLen = len_trim(buffer) 1990 len = len + buffLen 1991 if (len > lineLength) then 1992 call append_to_string(strBuffer, newline // trim(buffer)) 1993 len = buffLen 1994 else 1995 call append_to_string(strBuffer, space // trim(buffer)) 1996 end if 1997 end do 1998 1999 end subroutine getAsString_logicalR1 2000 2001 2002 !> Sets the value (child) of a child with given name. 2003 !> 2004 !> Caveat: This subroutines assumes, that a real can be represented as text with less than 2005 !> nCharReal characters. 2006 subroutine setChVal_real(node, name, variableValue, replace, child, modifier) 2007 2008 !> The node to investigate 2009 type(fnode), pointer :: node 2010 2011 !> Name of the child to look for 2012 character(len=*), intent(in) :: name 2013 2014 !> Value to set 2015 real(dp), intent(in) :: variableValue 2016 2017 !> Replace if child with same name already exists 2018 logical, intent(in), optional :: replace 2019 2020 !> Pointer to the child node (with the provided name) 2021 type(fnode), pointer, optional :: child 2022 2023 !> Optional modifier for the child 2024 character(len=*), optional, intent(in) :: modifier 2025 2026 type(string) :: strBuffer 2027 type(fnode), pointer :: child2 2028 logical :: tReplace 2029 2030 if (present(replace)) then 2031 tReplace = replace 2032 else 2033 tReplace = .false. 2034 end if 2035 2036 call getAsString(variableValue, strBuffer) 2037 call createChild_local(node, name, .false., tReplace, child2, & 2038 &variableValue=char(strBuffer)) 2039 if (present(child)) then 2040 child => child2 2041 end if 2042 if (present(modifier)) then 2043 call setAttribute(child2, attrModifier, modifier) 2044 end if 2045 2046 end subroutine setChVal_real 2047 2048 2049 !> Writes the text representation of a node and its value to an xmlwriter. 2050 subroutine writeChVal_real(xf, name, variableValue) 2051 2052 !> Xmlwriter stream 2053 type(xmlf_t), intent(inout) :: xf 2054 2055 !> Name of the node 2056 character(len=*), intent(in) :: name 2057 2058 !> Value of the node 2059 real(dp), intent(in) :: variableValue 2060 2061 type(string) :: strBuffer 2062 2063 call getAsString(variableValue, strBuffer) 2064 call writeChild_local(xf, name, char(strBuffer)) 2065 2066 end subroutine writeChVal_real 2067 2068 2069 !> Returns the text representation of the passed object 2070 subroutine getAsString_real(variableValue, strBuffer) 2071 2072 !> Value to represent 2073 real(dp), intent(in) :: variableValue 2074 2075 !> Text representation on exit 2076 type(string), intent(inout) :: strBuffer 2077 2078 character(len=nCharReal) :: buffer 2079 2080 write (buffer, *) variableValue 2081 strBuffer = trim(adjustl(buffer)) 2082 2083 end subroutine getAsString_real 2084 2085 2086 !> Sets the value (child) of a child with given name. 2087 !> 2088 !> Caveat: This subroutines assumes, that a real can be represented as text with less than 2089 !> nCharReal characters. 2090 subroutine setChVal_realR1(node, name, variableValue, replace, child, modifier) 2091 2092 !> The node to investigate 2093 type(fnode), pointer :: node 2094 2095 !> Name of the child to look for 2096 character(len=*), intent(in) :: name 2097 2098 !> Value to set 2099 real(dp), intent(in) :: variableValue(:) 2100 2101 !> Replace if child with same name already exists 2102 logical, intent(in), optional :: replace 2103 2104 !> Pointer to the child node (with the provided name) 2105 type(fnode), pointer, optional :: child 2106 2107 !> Optional modifier for the child 2108 character(len=*), optional, intent(in) :: modifier 2109 2110 type(string) :: strBuffer 2111 type(fnode), pointer :: child2 2112 logical :: tReplace 2113 2114 if (present(replace)) then 2115 tReplace = replace 2116 else 2117 tReplace = .false. 2118 end if 2119 call getAsString(variableValue, strBuffer) 2120 call createChild_local(node, name, .true., tReplace, child2, & 2121 &variableValue=char(strBuffer)) 2122 if (present(child)) then 2123 child => child2 2124 end if 2125 if (present(modifier)) then 2126 call setAttribute(child2, attrModifier, modifier) 2127 end if 2128 2129 end subroutine setChVal_realR1 2130 2131 2132 !> Writes the text representation of a node and its value to an xmlwriter. 2133 subroutine writeChVal_realR1(xf, name, variableValue) 2134 2135 !> Xmlwriter stream 2136 type(xmlf_t), intent(inout) :: xf 2137 2138 !> Name of the node 2139 character(len=*), intent(in) :: name 2140 2141 !> Value of the node 2142 real(dp), intent(in) :: variableValue(:) 2143 2144 type(string) :: strBuffer 2145 2146 call getAsString(variableValue, strBuffer) 2147 call writeChild_local(xf, name, char(strBuffer)) 2148 2149 end subroutine writeChVal_realR1 2150 2151 2152 !> Returns the text representation of the passed object 2153 subroutine getAsString_realR1(variableValue, strBuffer) 2154 2155 !> Value to represent 2156 real(dp), intent(in) :: variableValue(:) 2157 2158 !> Text representation on exit 2159 type(string), intent(inout) :: strBuffer 2160 2161 character(len=nCharReal) :: buffer 2162 integer :: buffLen, len 2163 integer :: ii 2164 2165 call resize_string(strBuffer, preAllocSize) 2166 len = 0 2167 do ii = 1, size(variableValue) 2168 write (buffer, *) variableValue(ii) 2169 buffer = adjustl(buffer) 2170 buffLen = len_trim(buffer) 2171 len = len + buffLen 2172 if (len > lineLength) then 2173 call append_to_string(strBuffer, newline // trim(buffer)) 2174 len = buffLen 2175 else 2176 call append_to_string(strBuffer, space // trim(buffer)) 2177 end if 2178 end do 2179 2180 end subroutine getAsString_realR1 2181 2182 2183 !> Sets the value (child) of a child with given name. The node to investigate 2184 !> 2185 !> This is just a wrapper around the rank one version, to make sure that two dimensional arrays 2186 !> are pretty printed. For higher ranked arrays the rank one version should be used with some 2187 !> reshaping before. 2188 !> 2189 !> This subroutines assumes, that a real can be represented as text with less than nCharReal 2190 !> characters. 2191 subroutine setChVal_realR2(node, name, variableValue, replace, child, modifier) 2192 2193 !> node to process from 2194 type(fnode), pointer :: node 2195 2196 !> Name of the child to look for 2197 character(len=*), intent(in) :: name 2198 2199 !> Value to set 2200 real(dp), intent(in) :: variableValue(:,:) 2201 2202 !> Replace if child with same name already exists 2203 logical, intent(in), optional :: replace 2204 2205 !> Pointer to the child node (with the provided name) 2206 type(fnode), pointer, optional :: child 2207 2208 !> Optional modifier for the child 2209 character(len=*), intent(in), optional :: modifier 2210 2211 type(fnode), pointer :: child2 2212 type(string) :: strBuffer 2213 logical :: tReplace 2214 2215 if (present(replace)) then 2216 tReplace = replace 2217 else 2218 tReplace = .false. 2219 end if 2220 2221 call getAsString(variableValue, strBuffer) 2222 call createChild_local(node, name, .true., tReplace, child2, & 2223 &variableValue=char(strBuffer)) 2224 if (present(child)) then 2225 child => child2 2226 end if 2227 if (present(modifier)) then 2228 call setAttribute(child2, attrModifier, modifier) 2229 end if 2230 2231 end subroutine setChVal_realR2 2232 2233 2234 !> Writes the text representation of a node and its value to an xmlwriter. 2235 subroutine writeChVal_realR2(xf, name, variableValue) 2236 2237 !> Xmlwriter stream 2238 type(xmlf_t), intent(inout) :: xf 2239 2240 !> Name of the node 2241 character(len=*), intent(in) :: name 2242 2243 !> Value of the node 2244 real(dp), intent(in) :: variableValue(:,:) 2245 2246 type(string) :: strBuffer 2247 2248 call getAsString(variableValue, strBuffer) 2249 call writeChild_local(xf, name, char(strBuffer)) 2250 2251 end subroutine writeChVal_realR2 2252 2253 2254 !> Returns the text representation of the passed object 2255 subroutine getAsString_realR2(variableValue, strBuffer) 2256 2257 !> Value to represent 2258 real(dp), intent(in) :: variableValue(:,:) 2259 2260 !> Text representation on exit 2261 type(string), intent(inout) :: strBuffer 2262 2263 character(len=nCharReal) :: buffer 2264 integer :: ii, jj 2265 2266 call resize_string(strBuffer, preAllocSize) 2267 do ii = 1, size(variableValue, dim=2) 2268 do jj = 1, size(variableValue, dim=1) 2269 write (buffer, *) variableValue(jj, ii) 2270 buffer = adjustl(buffer) 2271 call append_to_string(strBuffer, space // trim(buffer)) 2272 end do 2273 call append_to_string(strBuffer, newline) 2274 end do 2275 2276 end subroutine getAsString_realR2 2277 2278 2279 !> Sets the value (child) of a child with given name. 2280 !> 2281 !> Caveat: This subroutines assumes, that an integer can be represented as text with less than 2282 !> nCharInt characters. 2283 subroutine setChVal_int(node, name, variableValue, replace, child, modifier) 2284 2285 !> The node to investigate 2286 type(fnode), pointer :: node 2287 2288 !> Name of the child to look for 2289 character(len=*), intent(in) :: name 2290 2291 !> Value to set 2292 integer, intent(in) :: variableValue 2293 2294 !> Replace if child with same name already exists 2295 logical, intent(in), optional :: replace 2296 2297 !> Pointer to the child node (with the provided name) 2298 type(fnode), pointer, optional :: child 2299 2300 !> Optional modifier for the child 2301 character(len=*), optional, intent(in) :: modifier 2302 2303 type(fnode), pointer :: child2 2304 type(string) :: strBuffer 2305 logical :: tReplace 2306 2307 if (present(replace)) then 2308 tReplace = replace 2309 else 2310 tReplace = .false. 2311 end if 2312 call getAsString(variableValue, strBuffer) 2313 call createChild_local(node, name, .false., tReplace, child2, & 2314 &variableValue=char(strBuffer)) 2315 if (present(child)) then 2316 child => child2 2317 end if 2318 if (present(modifier)) then 2319 call setAttribute(child2, attrModifier, modifier) 2320 end if 2321 2322 end subroutine setChVal_int 2323 2324 2325 !> Writes the text representation of a node and its value to an xmlwriter. 2326 subroutine writeChVal_int(xf, name, variableValue) 2327 2328 !> Xmlwriter stream 2329 type(xmlf_t), intent(inout) :: xf 2330 2331 !> Name of the node 2332 character(len=*), intent(in) :: name 2333 2334 !> Value of the node 2335 integer, intent(in) :: variableValue 2336 2337 type(string) :: strBuffer 2338 2339 call getAsString(variableValue, strBuffer) 2340 call writeChild_local(xf, name, char(strBuffer)) 2341 2342 end subroutine writeChVal_int 2343 2344 2345 !> Returns the text representation of the passed object 2346 subroutine getAsString_int(variableValue, strBuffer) 2347 2348 !> Value to represent 2349 integer, intent(in) :: variableValue 2350 2351 !> Text representation on exit 2352 type(string), intent(inout) :: strBuffer 2353 2354 character(len=nCharInt) :: buffer 2355 2356 write (buffer, *) variableValue 2357 strBuffer = trim(adjustl(buffer)) 2358 2359 end subroutine getAsString_int 2360 2361 2362 !> Sets the value (child) of a child with given name. 2363 !> 2364 !> Caveat: This subroutines assumes, that an integer can be represented as text with less than 2365 !> nCharInt characters. 2366 subroutine setChVal_intR1(node, name, variableValue, replace, child, modifier) 2367 2368 !> The node to investigate 2369 type(fnode), pointer :: node 2370 2371 !> Name of the child to look for 2372 character(len=*), intent(in) :: name 2373 2374 !> Value to set 2375 integer, intent(in) :: variableValue(:) 2376 2377 !> Replace if child with same name already exists 2378 logical, intent(in), optional :: replace 2379 2380 !> Optional modifier for the child 2381 type(fnode), pointer, optional :: child 2382 2383 character(len=*), optional, intent(in) :: modifier 2384 2385 type(fnode), pointer :: child2 2386 type(string) :: strBuffer 2387 logical :: tReplace 2388 2389 if (present(replace)) then 2390 tReplace = replace 2391 else 2392 tReplace = .false. 2393 end if 2394 call getAsString(variableValue, strBuffer) 2395 call createChild_local(node, name, .true., tReplace, child2, & 2396 &variableValue=char(strBuffer)) 2397 if (present(child)) then 2398 child => child2 2399 end if 2400 if (present(modifier)) then 2401 call setAttribute(child2, attrModifier, modifier) 2402 end if 2403 2404 end subroutine setChVal_intR1 2405 2406 2407 !> Writes the text representation of a node and its value to an xmlwriter. 2408 subroutine writeChVal_intR1(xf, name, variableValue) 2409 2410 !> Xmlwriter stream 2411 type(xmlf_t), intent(inout) :: xf 2412 2413 !> Name of the node 2414 character(len=*), intent(in) :: name 2415 2416 !> Value of the node 2417 integer, intent(in) :: variableValue(:) 2418 2419 type(string) :: strBuffer 2420 2421 call getAsString(variableValue, strBuffer) 2422 call writeChild_local(xf, name, char(strBuffer)) 2423 2424 end subroutine writeChVal_intR1 2425 2426 2427 !> Returns the text representation of the passed object 2428 subroutine getAsString_intR1(variableValue, strBuffer) 2429 2430 !> Value to represent 2431 integer, intent(in) :: variableValue(:) 2432 2433 !> Text representation on exit 2434 type(string), intent(inout) :: strBuffer 2435 2436 character(len=nCharInt) :: buffer 2437 integer :: buffLen, len 2438 integer :: ii 2439 2440 call resize_string(strBuffer, preAllocSize) 2441 len = 0 2442 do ii = 1, size(variableValue) 2443 write (buffer, *) variableValue(ii) 2444 buffer = adjustl(buffer) 2445 buffLen = len_trim(buffer) 2446 len = len + buffLen 2447 if (len > lineLength) then 2448 call append_to_string(strBuffer, newline // trim(buffer)) 2449 len = buffLen 2450 else 2451 call append_to_string(strBuffer, space // trim(buffer)) 2452 end if 2453 end do 2454 2455 end subroutine getAsString_intR1 2456 2457 2458 !> Sets the value (child) of a child with given name. 2459 !> 2460 !> This is just a wrapper around the rank one version, to make sure that two dimensional arrays 2461 !> are pretty printed. For higher ranked arrays the rank one version should be used with some 2462 !> reshaping beforehand. 2463 !> 2464 !> Caveat: This subroutines assumes, that an integer can be represented as text with less than 2465 !> nCharInt characters. 2466 subroutine setChVal_intR2(node, name, variableValue, replace, child, modifier) 2467 2468 !> The node to investigate 2469 type(fnode), pointer :: node 2470 2471 !> Name of the child to look for 2472 character(len=*), intent(in) :: name 2473 2474 !> Value to set 2475 integer, intent(in) :: variableValue(:,:) 2476 2477 !> Replace if child with same name already exists 2478 logical, intent(in), optional :: replace 2479 2480 !> Pointer to the child node (with the provided name) 2481 type(fnode), pointer, optional :: child 2482 2483 !> Optional modifier for the child 2484 character(len=*), optional, intent(in) :: modifier 2485 2486 type(fnode), pointer :: child2 2487 type(string) :: strBuffer 2488 logical :: tReplace 2489 2490 if (present(replace)) then 2491 tReplace = replace 2492 else 2493 tReplace = .false. 2494 end if 2495 call getAsString(variableValue, strBuffer) 2496 call createChild_local(node, name, .true., tReplace, child2, & 2497 &variableValue=char(strBuffer)) 2498 if (present(child)) then 2499 child => child2 2500 end if 2501 if (present(modifier)) then 2502 call setAttribute(child2, attrModifier, modifier) 2503 end if 2504 2505 end subroutine setChVal_intR2 2506 2507 2508 !> Writes the text representation of a node and its value to an xmlwriter. 2509 subroutine writeChVal_intR2(xf, name, variableValue) 2510 2511 !> Xmlwriter stream 2512 type(xmlf_t), intent(inout) :: xf 2513 2514 !> Name of the node 2515 character(len=*), intent(in) :: name 2516 2517 !> Value of the node 2518 integer, intent(in) :: variableValue(:,:) 2519 2520 type(string) :: strBuffer 2521 2522 call getAsString(variableValue, strBuffer) 2523 call writeChild_local(xf, name, char(strBuffer)) 2524 2525 end subroutine writeChVal_intR2 2526 2527 2528 !> Returns the text representation of the passed object 2529 subroutine getAsString_intR2(variableValue, strBuffer) 2530 2531 !> Value to represent 2532 integer, intent(in) :: variableValue(:,:) 2533 2534 !> Text representation on exit 2535 type(string), intent(inout) :: strBuffer 2536 2537 character(len=nCharInt) :: buffer 2538 integer :: ii, jj 2539 2540 call resize_string(strBuffer, preAllocSize) 2541 do ii = 1, size(variableValue, dim=2) 2542 do jj = 1, size(variableValue, dim=1) 2543 write (buffer, *) variableValue(jj, ii) 2544 buffer = adjustl(buffer) 2545 call append_to_string(strBuffer, space // trim(buffer)) 2546 end do 2547 call append_to_string(strBuffer, newline) 2548 end do 2549 2550 end subroutine getAsString_intR2 2551 2552 2553 !> Sets the value (child) of a child with given name. 2554 subroutine setChVal_char(node, name, variableValue, replace, child, omitQuotes, modifier) 2555 2556 !> The node to investigate 2557 type(fnode), pointer :: node 2558 2559 !> Name of the child to look for 2560 character(len=*), intent(in) :: name 2561 2562 !> Value to set 2563 character(len=*), intent(in) :: variableValue 2564 2565 !> Replace if child with same name already exists 2566 logical, intent(in), optional :: replace 2567 2568 !> Pointer to the child node (with the provided name) 2569 type(fnode), pointer, optional :: child 2570 2571 !> If quotes around the string should be omitted 2572 logical, intent(in), optional :: omitQuotes 2573 2574 !> Optional modifier for the child 2575 character(len=*), optional, intent(in) :: modifier 2576 2577 type(fnode), pointer :: child2 2578 logical :: tReplace, tQuotes 2579 2580 if (present(replace)) then 2581 tReplace = replace 2582 else 2583 tReplace = .false. 2584 end if 2585 if (present(omitQuotes)) then 2586 tQuotes = .not. omitQuotes 2587 else 2588 tQuotes = .true. 2589 end if 2590 if (tQuotes) then 2591 call createChild_local(node, name, .false., tReplace, child2, & 2592 &variableValue='"'//variableValue//'"') 2593 else 2594 call createChild_local(node, name, .false., tReplace, child2, variableValue=variableValue) 2595 end if 2596 2597 if (present(child)) then 2598 child => child2 2599 end if 2600 if (present(modifier)) then 2601 call setAttribute(child2, attrModifier, modifier) 2602 end if 2603 2604 end subroutine setChVal_char 2605 2606 2607 !> Sets the value (child) of a child with given name. 2608 subroutine setChVal_charR1(node, name, variableValue, replace, child, modifier) 2609 2610 !> The node to investigate 2611 type(fnode), pointer :: node 2612 2613 !> Name of the child to look for 2614 character(len=*), intent(in) :: name 2615 2616 !> Value to set 2617 character(len=*), intent(in) :: variableValue(:) 2618 2619 !> Replace if child with same name already exists 2620 logical, intent(in), optional :: replace 2621 2622 !> Pointer to the child node (with the provided name) 2623 type(fnode), pointer, optional :: child 2624 2625 !> Optional modifier for the child 2626 character(len=*), optional, intent(in) :: modifier 2627 2628 type(string) :: strBuffer 2629 type(fnode), pointer :: child2 2630 logical :: tReplace 2631 2632 if (present(replace)) then 2633 tReplace = replace 2634 else 2635 tReplace = .false. 2636 end if 2637 call getAsString(variableValue, strBuffer) 2638 call createChild_local(node, name, .true., tReplace, child2, & 2639 &variableValue=char(strBuffer)) 2640 if (present(child)) then 2641 child => child2 2642 end if 2643 if (present(modifier)) then 2644 call setAttribute(child2, attrModifier, modifier) 2645 end if 2646 2647 end subroutine setChVal_charR1 2648 2649 2650 !> Writes the text representation of a node and its value to an xmlwriter. 2651 subroutine writeChVal_charR1(xf, name, variableValue) 2652 2653 !> Xmlwriter stream 2654 type(xmlf_t), intent(inout) :: xf 2655 2656 !> Name of the node 2657 character(len=*), intent(in) :: name 2658 2659 !> Value of the node 2660 character(len=*), intent(in) :: variableValue(:) 2661 2662 type(string) :: strBuffer 2663 2664 call getAsString(variableValue, strBuffer) 2665 call writeChild_local(xf, name, char(strBuffer)) 2666 2667 end subroutine writeChVal_charR1 2668 2669 2670 !> Returns the text representation of the passed object 2671 subroutine getAsString_charR1(variableValue, strBuffer) 2672 2673 !> Value to represent 2674 character(len=*), intent(in) :: variableValue(:) 2675 2676 !> Text representation on exit 2677 type(string), intent(inout) :: strBuffer 2678 2679 integer :: buffLen, len 2680 integer :: ii 2681 2682 call resize_string(strBuffer, preAllocSize) 2683 len = 0 2684 do ii = 1, size(variableValue) 2685 buffLen = len_trim(variableValue(ii)) 2686 len = len + buffLen 2687 if (len > lineLength) then 2688 call append_to_string(strBuffer, newline // '"'//trim(variableValue(ii))//'"') 2689 len = buffLen 2690 else 2691 call append_to_string(strBuffer, space // '"'//trim(variableValue(ii))//'"') 2692 end if 2693 end do 2694 2695 end subroutine getAsString_charR1 2696 2697 2698 !> Sets the value (child) of a child with given name. 2699 subroutine setChVal_intR2RealR2(node, name, intValue, realValue, replace, child, modifier) 2700 2701 !> The node to investigate 2702 type(fnode), pointer :: node 2703 2704 !> Name of the child to look for 2705 character(len=*), intent(in) :: name 2706 2707 !> Value for the integers 2708 integer, intent(in) :: intValue(:,:) 2709 2710 !> Value for the reals 2711 real(dp), intent(in) :: realValue(:,:) 2712 2713 !> Replace if child with same name already exists 2714 logical, intent(in), optional :: replace 2715 2716 !> Pointer to the child node (with the provided name) 2717 type(fnode), pointer, optional :: child 2718 2719 !> Optional modifier for the child 2720 character(len=*), optional, intent(in) :: modifier 2721 2722 type(fnode), pointer :: child2 2723 type(string) :: strBuffer 2724 logical :: tReplace 2725 2726 if (present(replace)) then 2727 tReplace = replace 2728 else 2729 tReplace = .false. 2730 end if 2731 call getAsString(intValue, realValue, strBuffer) 2732 call createChild_local(node, name, .true., tReplace, child2, & 2733 &variableValue=char(strBuffer)) 2734 if (present(child)) then 2735 child => child2 2736 end if 2737 if (present(modifier)) then 2738 call setAttribute(child2, attrModifier, modifier) 2739 end if 2740 2741 end subroutine setChVal_intR2RealR2 2742 2743 2744 !> Writes the text representation of a node and its value to an xmlwriter. 2745 subroutine writeChVal_intR2RealR2(xf, name, intValue, realValue) 2746 2747 !> Xmlwriter stream 2748 type(xmlf_t), intent(inout) :: xf 2749 2750 !> Name of the node 2751 character(len=*), intent(in) :: name 2752 2753 !> Integer value of the node 2754 integer, intent(in) :: intValue(:,:) 2755 2756 !> real values of the node 2757 real(dp), intent(in) :: realValue(:,:) 2758 2759 type(string) :: strBuffer 2760 2761 call getAsString(intValue, realValue, strBuffer) 2762 call writeChild_local(xf, name, char(strBuffer)) 2763 2764 end subroutine writeChVal_intR2RealR2 2765 2766 2767 !> Returns the text representation of the passed object 2768 subroutine getAsString_intR2RealR2(intValue, realValue, strBuffer) 2769 2770 !> integer value in node 2771 integer, intent(in) :: intValue(:,:) 2772 2773 !> real value in node 2774 real(dp), intent(in) :: realValue(:,:) 2775 2776 !> Text representation on exit 2777 type(string), intent(inout) :: strBuffer 2778 2779 character(len=100) :: buffer 2780 integer :: nRow, nCol1, nCol2 2781 integer :: ii, jj 2782 2783 nRow = size(intValue, dim=2) 2784 @:ASSERT(size(realValue, dim=2) == nRow) 2785 2786 nCol1 = size(intValue, dim=1) 2787 nCol2 = size(realValue, dim=1) 2788 call resize_string(strBuffer, preAllocSize) 2789 do ii = 1, nRow 2790 do jj = 1, nCol1 2791 write (buffer, *) intValue(jj, ii) 2792 buffer = adjustl(buffer) 2793 call append_to_string(strBuffer, space // trim(buffer)) 2794 end do 2795 do jj = 1, nCol2 2796 write (buffer, *) realValue(jj, ii) 2797 buffer = adjustl(buffer) 2798 call append_to_string(strBuffer, space // trim(buffer)) 2799 end do 2800 call append_to_string(strBuffer, newline) 2801 end do 2802 2803 end subroutine getAsString_intR2RealR2 2804 2805 2806 !> Sets the value (child) of a child with given name. 2807 subroutine setChVal_charR1IntR2RealR2(node, name, charValue, intValue, realValue, replace, & 2808 & child, modifier) 2809 2810 !> The node to investigate 2811 type(fnode), pointer :: node 2812 2813 !> Name of the child to look for 2814 character(len=*), intent(in) :: name 2815 2816 !> Value for the characters 2817 character(len=*), intent(in) :: charValue(:) 2818 2819 !> Value for the integers 2820 integer, intent(in) :: intValue(:,:) 2821 2822 !> Value for the reals 2823 real(dp), intent(in) :: realValue(:,:) 2824 2825 !> Replace if child with same name already exists 2826 logical, intent(in), optional :: replace 2827 2828 !> Pointer to the child node (with the provided name) 2829 type(fnode), pointer, optional :: child 2830 2831 !> Optional modifier for the child 2832 character(len=*), optional, intent(in) :: modifier 2833 2834 type(fnode), pointer :: child2 2835 type(string) :: strBuffer 2836 logical :: tReplace 2837 2838 if (present(replace)) then 2839 tReplace = replace 2840 else 2841 tReplace = .false. 2842 end if 2843 call getAsString(charValue, intValue, realValue, strBuffer) 2844 call createChild_local(node, name, .true., tReplace, child2, & 2845 &variableValue=char(strBuffer)) 2846 if (present(child)) then 2847 child => child2 2848 end if 2849 if (present(modifier)) then 2850 call setAttribute(child2, attrModifier, modifier) 2851 end if 2852 2853 end subroutine setChVal_charR1IntR2RealR2 2854 2855 2856 !> Writes the text representation of a node and its value to an xmlwriter. 2857 subroutine writeChVal_charR1IntR2RealR2(xf, name, charValue, intValue, realValue) 2858 2859 !> Xmlwriter stream 2860 type(xmlf_t), intent(inout) :: xf 2861 2862 !> Name of the node 2863 character(len=*), intent(in) :: name 2864 2865 !> character part of node 2866 character(len=*), intent(in) :: charValue(:) 2867 2868 !> integer part of node 2869 integer, intent(in) :: intValue(:,:) 2870 2871 !> real value part of node 2872 real(dp), intent(in) :: realValue(:,:) 2873 2874 type(string) :: strBuffer 2875 2876 call getAsString(charValue, intValue, realValue, strBuffer) 2877 call writeChild_local(xf, name, char(strBuffer)) 2878 2879 end subroutine writeChVal_charR1IntR2RealR2 2880 2881 2882 !> Returns the text representation of the passed object 2883 subroutine getAsString_charR1IntR2RealR2(charValue, intValue, realValue, strBuffer) 2884 2885 !> character part of node 2886 character(len=*), intent(in) :: charValue(:) 2887 2888 !> integer part of node 2889 integer, intent(in) :: intValue(:,:) 2890 2891 !> real value part of node 2892 real(dp), intent(in) :: realValue(:,:) 2893 2894 !> Text representation on exit 2895 type(string), intent(inout) :: strBuffer 2896 2897 character(len=100) :: buffer 2898 integer :: nRow, nCol1, nCol2 2899 integer :: ii, jj 2900 2901 nRow = size(charValue) 2902 @:ASSERT(size(intValue, dim=2) == nRow) 2903 @:ASSERT(size(realValue, dim=2) == nRow) 2904 2905 nCol1 = size(intValue, dim=1) 2906 nCol2 = size(realValue, dim=1) 2907 call resize_string(strBuffer, preAllocSize) 2908 do ii = 1, nRow 2909 call append_to_string(strBuffer, charValue(ii)) 2910 do jj = 1, nCol1 2911 write (buffer, *) intValue(jj, ii) 2912 buffer = adjustl(buffer) 2913 call append_to_string(strBuffer, space // trim(buffer)) 2914 end do 2915 do jj = 1, nCol2 2916 write (buffer, *) realValue(jj, ii) 2917 buffer = adjustl(buffer) 2918 call append_to_string(strBuffer, space // trim(buffer)) 2919 end do 2920 call append_to_string(strBuffer, newline) 2921 end do 2922 2923 end subroutine getAsString_charR1IntR2RealR2 2924 2925 2926 !> Sets the value (child) of a child with given name. 2927 subroutine setChVal_node(node, name, variableValue, replace, child, modifier, list) 2928 2929 !> The node to investigate 2930 type(fnode), pointer :: node 2931 2932 !> Name of the child to look for 2933 character(len=*), intent(in) :: name 2934 2935 !> Value to set 2936 type(fnode), pointer :: variableValue 2937 2938 !> Replace if child with same name already exists 2939 logical, intent(in), optional :: replace 2940 2941 !> Pointer to the child node (with the provided name) 2942 type(fnode), pointer, optional :: child 2943 2944 !> Optional modifier for the child 2945 character(len=*), optional, intent(in) :: modifier 2946 2947 !> If created child should be marked as a list. 2948 logical, optional, intent(in) :: list 2949 2950 type(fnode), pointer :: child2, dummy 2951 logical :: tReplace, tList 2952 2953 if (present(replace)) then 2954 tReplace = replace 2955 else 2956 tReplace = .false. 2957 end if 2958 if (present(list)) then 2959 tList = list 2960 else 2961 tList = .false. 2962 end if 2963 call createChild_local(node, name, tList, tReplace, child2) 2964 if (associated(variableValue)) then 2965 dummy => appendChild(child2, variableValue) 2966 end if 2967 if (present(child)) then 2968 child => child2 2969 end if 2970 if (present(modifier)) then 2971 call setAttribute(child2, attrModifier, modifier) 2972 end if 2973 2974 end subroutine setChVal_node 2975 2976 2977 !> Workhorse for the setChildValue routines 2978 !> 2979 !> If an empty string is provided as child name, no child is created, and the current node is 2980 !> replace instead. The pointer "node" becames associated with the new node, since the old 2981 !> instance will be destroyed. 2982 subroutine createChild_local(node, name, list, replace, child, variableValue) 2983 2984 !> The node to investigate 2985 type(fnode), pointer :: node 2986 2987 !> Name of the child to create 2988 character(len=*), intent(in) :: name 2989 2990 !> True, if child should be signed as a list 2991 logical, intent(in) :: list 2992 2993 !> Replace if child with same name already exists 2994 logical, intent(in) :: replace 2995 2996 !> Pointer to the created child on return 2997 type(fnode), pointer :: child 2998 2999 !> Value to set (if empty, no child is appended to the created child) 3000 character(len=*), intent(in), optional :: variableValue 3001 3002 type(fnode), pointer :: parent, oldChild, child2, text, dummy 3003 character(len=len(name)) :: loName 3004 type(string) :: newName, parentname 3005 3006 if (replace) then 3007 if (len(name) == 0) then 3008 call getNodeHSDName(node, newName) 3009 parent => getParentNode(node) 3010 oldChild => node 3011 child2 => createElement(tolower(char(newName))) 3012 node => child2 3013 else 3014 newName = name 3015 parent => node 3016 loName = tolower(name) 3017 oldChild => getFirstChildByName(node, loName) 3018 child2 => createElement(loName) 3019 end if 3020 else 3021 newName = name 3022 parent => node 3023 oldChild => null() 3024 child2 => createElement(tolower(name)) 3025 end if 3026 3027 ! If parent is a text mode, no subnodes should be allowed. 3028 dummy => getFirstChild(parent) 3029 if (associated(dummy)) then 3030 call getNodeName(dummy, parentname) 3031 if (char(parentname) == textNodeName) then 3032 call detailedError(node, "Node contains superfluous free text: '"& 3033 & // trim(dummy%nodeValue) // "'") 3034 end if 3035 end if 3036 3037 if (associated(oldChild)) then 3038 dummy => replaceChild(parent, child2, oldChild) 3039 call destroyNode(oldChild) 3040 else 3041 dummy => appendChild(parent, child2) 3042 end if 3043 3044 if (len(newName) > 0) then 3045 call setAttribute(child2, attrName, char(newName)) 3046 end if 3047 if (list) then 3048 call setAttribute(child2, attrList, "") 3049 end if 3050 3051 child => child2 3052 call setAttribute(child, attrProcessed, "") 3053 if (present(variableValue)) then 3054 text => createTextNode(variableValue) 3055 dummy => appendChild(child, text) 3056 end if 3057 3058 end subroutine createChild_local 3059 3060 3061 !> new child in the xml 3062 subroutine writeChild_local(xf, name, variableValue) 3063 3064 !> xmlWriter stream 3065 type(xmlf_t), intent(inout) :: xf 3066 3067 !> node name 3068 character(len=*), intent(in) :: name 3069 3070 !> stored variale string 3071 character(len=*), intent(in) :: variableValue 3072 3073 call xml_NewElement(xf, name) 3074 call xml_AddPCData(xf, variableValue) 3075 call xml_EndElement(xf, name) 3076 3077 end subroutine writeChild_local 3078 3079 3080 !> Creates a child with the given name 3081 subroutine setChild(node, name, child, replace, list, modifier) 3082 3083 !> Node to append the child to 3084 type(fnode), pointer :: node 3085 3086 !> Name of the child node to append 3087 character(len=*), intent(in) :: name 3088 3089 !> Contains the pointer to the added child node on return 3090 type(fnode), pointer :: child 3091 3092 !> If an already existing child with the same name should be replaced 3093 logical, intent(in), optional :: replace 3094 3095 !> If child should be signed as a list tag 3096 logical, intent(in), optional :: list 3097 3098 !> Optional modifier for the child 3099 character(len=*), optional, intent(in) :: modifier 3100 3101 logical :: tReplace, tList 3102 type(fnode), pointer :: dummy 3103 3104 if (present(replace)) then 3105 tReplace = replace 3106 else 3107 tReplace = .false. 3108 end if 3109 if (present(list)) then 3110 tList = list 3111 else 3112 tList = .false. 3113 end if 3114 3115 child => getFirstChildByName(node, tolower(name)) 3116 if (associated(child)) then 3117 if (tReplace) then 3118 dummy => removeChild(node, child) 3119 call destroyNode(child) 3120 else 3121 call detailedError(node, MSG_EXISTING_CHILD // name) 3122 end if 3123 end if 3124 child => createElement(tolower(name)) 3125 dummy => appendChild(node, child) 3126 call setAttribute(child, attrName, name) 3127 call setAttribute(child, attrProcessed, "") 3128 if (tList) then 3129 call setAttribute(child, attrList, "") 3130 end if 3131 if (present(modifier)) then 3132 call setAttribute(child, attrModifier, modifier) 3133 end if 3134 3135 end subroutine setChild 3136 3137 3138 !> Returns the content of the first TEXT_NODE child of a given node or empty string, if such a 3139 !> node does not exist. 3140 !> 3141 !> Note: the document tree is normalized, every node has only one TEXT_NODE child. 3142 subroutine getFirstTextChild(node, str) 3143 3144 !> The node to investigate. 3145 type(fnode), pointer :: node 3146 3147 !> String representation of the TEXT_NODE. 3148 type(string), intent(out) :: str 3149 3150 type(fnode), pointer :: child 3151 3152 child => getFirstChild(node) 3153 if (.not. associated(child)) then 3154 str = "" 3155 elseif (getNodeType(child) /= TEXT_NODE) then 3156 call detailedError(child, "Invalid node type.") 3157 else 3158 call getNodeValue(child, str) 3159 end if 3160 3161 end subroutine getFirstTextChild 3162 3163 3164 !> Checks if error flag signals an error. If yes, raises error. 3165 subroutine checkError(node, iErr, msg) 3166 3167 !> Node which the error flag was set for 3168 type(fnode), pointer :: node 3169 3170 !> Content of the error flag. 3171 integer, intent(in) :: iErr 3172 3173 !> Message to print, if error occured 3174 character(len=*), intent(in) :: msg 3175 3176 if (iErr == TOKEN_ERROR) then 3177 call detailedError(node, msg) 3178 elseif (iErr == TOKEN_EOS) then 3179 call detailedError(node, "Unexpected end of data") 3180 end if 3181 3182 end subroutine checkError 3183 3184 3185 !> Issues an error, if the string from a given position contains non-whitespace characters. 3186 subroutine checkNoData(node, str, start) 3187 3188 !> Node which is being processed (for error message) 3189 type(fnode), pointer :: node 3190 3191 !> String content of the child. 3192 character(len=*), intent(in) :: str 3193 3194 !> Starting position, after which the string should not contain any whitespace characters. 3195 integer, intent(in) :: start 3196 3197 if (complementaryScan(str(start:), whiteSpaces) > 0) then 3198 call detailedError(node, "Superfluous data found.") 3199 end if 3200 3201 end subroutine checkNoData 3202 3203 3204 !> Prints detailed error, including line number and path 3205 subroutine detailedError(node, msg) 3206 3207 !> Node where the error occured. 3208 type(fnode), pointer :: node 3209 3210 !> Message to print 3211 character(len=*), intent(in) :: msg 3212 3213 type(string) :: str 3214 3215 str = msg 3216 call appendPathAndLine(node, str) 3217 call error(char(str) // newline) 3218 3219 end subroutine detailedError 3220 3221 3222 !> Prints detailed warning, including line number and path 3223 subroutine detailedWarning(node, msg) 3224 3225 !> Node where the error occured. 3226 type(fnode), pointer :: node 3227 3228 !> Message to print 3229 character(len=*), intent(in) :: msg 3230 3231 type(string) :: str 3232 3233 str = msg 3234 call appendPathAndLine(node, str) 3235 call warning(char(str) // newline) 3236 3237 end subroutine detailedWarning 3238 3239 3240 !> Appends path and line information to a string. 3241 subroutine appendPathAndLine(node, str) 3242 3243 !> Node, for which path and line should be added 3244 type(fnode), pointer :: node 3245 3246 !> String prepending the path and line information 3247 type(string), intent(inout) :: str 3248 3249 type(string) :: str2, str3 3250 3251 call append_to_string(str, newline // "Path: ") 3252 call getHSDPath(node, str2, excludeRoot=.true.) 3253 call append_to_string(str, str2) 3254 call getAttribute(node, attrStart, str2) 3255 call getAttribute(node, attrEnd, str3) 3256 if (len(str2) /= 0) then 3257 call append_to_string(str, newline // "Line: ") 3258 call append_to_string(str, str2) 3259 if (len(str3) /= 0) then 3260 call append_to_string(str, "-") 3261 call append_to_string(str, str3) 3262 end if 3263 end if 3264 call getAttribute(node, attrFile, str2) 3265 if (len(str2) /= 0) then 3266 call append_to_string(str, " (File: ") 3267 call append_to_string(str, str2) 3268 call append_to_string(str, ")") 3269 end if 3270 3271 end subroutine appendPathAndLine 3272 3273end module dftbp_hsdutils 3274