Changeset 12080 for utils/tools/SIREN/src/function.f90
- Timestamp:
- 2019-12-06T10:30:14+01:00 (4 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
utils/tools/SIREN/src/function.f90
r9598 r12080 3 3 !---------------------------------------------------------------------- 4 4 ! 5 ! MODULE: fct6 !7 5 ! DESCRIPTION: 8 6 !> @brief … … 89 87 !> @endcode 90 88 !> 89 !> to show help message:<br/> 90 !> @code 91 !> CALL fct_help(cd_filename, cd_err) 92 !> @endcode 93 !> - cd_filename : file name 94 !> - cd_err : error message [optional] 95 !> 96 !> to show Siren's version:<br/> 97 !> @code 98 !> CALL fct_version(cd_filename) 99 !> @endcode 100 !> - cd_filename : file name 101 !> 91 102 !> 92 103 !> @author 93 104 !> J.Paul 94 ! REVISION HISTORY:105 !> 95 106 !> @date November, 2013 - Initial Version 96 107 !> @date September, 2014 97 108 !> - add header 98 ! 99 !> @note Software governed by the CeCILL licence (./LICENSE) 109 !> @date October, 2019 110 !> - add help and version function 111 !> 112 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 100 113 !---------------------------------------------------------------------- 101 114 MODULE fct 115 116 USE global ! global variable 102 117 USE kind ! F90 kind parameter 118 103 119 IMPLICIT NONE 104 120 ! NOTE_avoid_public_variables_if_possible … … 118 134 PUBLIC :: fct_pause !< pause statement 119 135 PUBLIC :: fct_err !< handle fortran error status 136 PUBLIC :: fct_help !< show help message 137 PUBLIC :: fct_version !< show Siren's version 120 138 121 139 PRIVATE :: fct__i1_str ! convert integer(1) to string character … … 156 174 157 175 CONTAINS 176 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 177 PURE FUNCTION fct__i1_cat(cd_char, bd_val) & 178 & RESULT(cf_str) 158 179 !------------------------------------------------------------------- 159 180 !> @brief This function concatenate character and integer(1) (as character). 160 ! 181 !> 161 182 !> @author J.Paul 162 183 !> @date September, 2014 - Initial Version 163 ! 184 !> 164 185 !> @param[in] cd_char string character 165 186 !> @param[in] bd_val integer(1) variable value 166 187 !> @return string character 167 188 !------------------------------------------------------------------- 168 PURE CHARACTER(LEN=lc) FUNCTION fct__i1_cat(cd_char, bd_val) 189 190 IMPLICIT NONE 169 191 170 192 ! arguments … … 172 194 INTEGER(i1), INTENT(IN) :: bd_val 173 195 196 ! function 197 CHARACTER(LEN=lc) :: cf_str 198 174 199 ! local variable 175 200 CHARACTER(LEN=lc) :: cl_val … … 177 202 178 203 cl_val = fct_str(bd_val) 179 fct__i1_cat=TRIM(cd_char)//TRIM(cl_val)204 cf_str = TRIM(cd_char)//TRIM(cl_val) 180 205 181 206 END FUNCTION fct__i1_cat 207 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 208 PURE FUNCTION fct__i2_cat(cd_char, sd_val) & 209 & RESULT(cf_str) 182 210 !------------------------------------------------------------------- 183 211 !> @brief This function concatenate character and integer(2) (as character). 184 ! 212 !> 185 213 !> @author J.Paul 186 214 !> @date September, 2014 - Initial Version 187 ! 215 !> 188 216 !> @param[in] cd_char string character 189 217 !> @param[in] sd_val integer(2) variable value 190 218 !> @return string character 191 219 !------------------------------------------------------------------- 192 PURE CHARACTER(LEN=lc) FUNCTION fct__i2_cat(cd_char, sd_val) 220 221 IMPLICIT NONE 193 222 194 223 ! arguments … … 196 225 INTEGER(i2), INTENT(IN) :: sd_val 197 226 227 ! function 228 CHARACTER(LEN=lc) :: cf_str 229 198 230 ! local variable 199 231 CHARACTER(LEN=lc) :: cl_val … … 201 233 202 234 cl_val = fct_str(sd_val) 203 fct__i2_cat=TRIM(cd_char)//TRIM(cl_val)235 cf_str = TRIM(cd_char)//TRIM(cl_val) 204 236 205 237 END FUNCTION fct__i2_cat 238 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 239 PURE FUNCTION fct__i4_cat(cd_char, id_val) & 240 & RESULT(cf_str) 206 241 !------------------------------------------------------------------- 207 242 !> @brief This function concatenate character and integer(4) (as character). 208 ! 243 !> 209 244 !> @author J.Paul 210 245 !> @date November, 2013 - Initial Version 211 ! 246 !> 212 247 !> @param[in] cd_char string character 213 248 !> @param[in] id_val integer(4) variable value 214 249 !> @return string character 215 250 !------------------------------------------------------------------- 216 PURE CHARACTER(LEN=lc) FUNCTION fct__i4_cat(cd_char, id_val) 251 252 IMPLICIT NONE 217 253 218 254 ! arguments … … 220 256 INTEGER(i4), INTENT(IN) :: id_val 221 257 258 ! function 259 CHARACTER(LEN=lc) :: cf_str 260 222 261 ! local variable 223 262 CHARACTER(LEN=lc) :: cl_val … … 225 264 226 265 cl_val = fct_str(id_val) 227 fct__i4_cat=TRIM(cd_char)//TRIM(cl_val)266 cf_str = TRIM(cd_char)//TRIM(cl_val) 228 267 229 268 END FUNCTION fct__i4_cat 269 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 270 PURE FUNCTION fct__i8_cat(cd_char, kd_val) & 271 & RESULT(cf_str) 230 272 !------------------------------------------------------------------- 231 273 !> @brief This function concatenate character and integer(8) (as character). 232 ! 274 !> 233 275 !> @author J.Paul 234 276 !> @date November, 2013 - Initial Version 235 ! 277 !> 236 278 !> @param[in] cd_char string character 237 279 !> @param[in] kd_val integer(8) variable value 238 280 !> @return string character 239 281 !------------------------------------------------------------------- 240 PURE CHARACTER(LEN=lc) FUNCTION fct__i8_cat(cd_char, kd_val) 282 283 IMPLICIT NONE 241 284 242 285 ! arguments … … 244 287 INTEGER(i8), INTENT(IN) :: kd_val 245 288 289 ! function 290 CHARACTER(LEN=lc) :: cf_str 291 246 292 ! local variable 247 293 CHARACTER(LEN=lc) :: cl_val … … 249 295 250 296 cl_val = fct_str(kd_val) 251 fct__i8_cat=TRIM(cd_char)//TRIM(cl_val)297 cf_str = TRIM(cd_char)//TRIM(cl_val) 252 298 253 299 END FUNCTION fct__i8_cat 300 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 301 PURE FUNCTION fct__r4_cat(cd_char, rd_val) & 302 & RESULT(cf_str) 254 303 !------------------------------------------------------------------- 255 304 !> @brief This function concatenate character and real(4) (as character). 256 ! 305 !> 257 306 !> @author J.Paul 258 307 !> @date November, 2013 - Initial Version 259 ! 308 !> 260 309 !> @param[in] cd_char string character 261 310 !> @param[in] rd_val real(4) variable value 262 311 !> @return string character 263 312 !------------------------------------------------------------------- 264 PURE CHARACTER(LEN=lc) FUNCTION fct__r4_cat(cd_char, rd_val) 313 314 IMPLICIT NONE 265 315 266 316 ! arguments … … 268 318 REAL(sp), INTENT(IN) :: rd_val 269 319 320 ! function 321 CHARACTER(LEN=lc) :: cf_str 322 270 323 ! local variable 271 324 CHARACTER(LEN=lc) :: cl_val … … 273 326 274 327 cl_val = fct_str(rd_val) 275 fct__r4_cat=TRIM(cd_char)//TRIM(cl_val)328 cf_str = TRIM(cd_char)//TRIM(cl_val) 276 329 277 330 END FUNCTION fct__r4_cat 331 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 332 PURE FUNCTION fct__r8_cat(cd_char, dd_val) & 333 & RESULT(cf_str) 278 334 !------------------------------------------------------------------- 279 335 !> @brief This function concatenate character and real(8) (as character). … … 286 342 !> @return string character 287 343 !------------------------------------------------------------------- 288 PURE CHARACTER(LEN=lc) FUNCTION fct__r8_cat(cd_char, dd_val) 344 345 IMPLICIT NONE 289 346 290 347 ! arguments … … 292 349 REAL(dp), INTENT(IN) :: dd_val 293 350 351 ! function 352 CHARACTER(LEN=lc) :: cf_str 353 294 354 ! local variable 295 355 CHARACTER(LEN=lc) :: cl_val … … 297 357 298 358 cl_val = fct_str(dd_val) 299 fct__r8_cat=TRIM(cd_char)//TRIM(cl_val)359 cf_str = TRIM(cd_char)//TRIM(cl_val) 300 360 301 361 END FUNCTION fct__r8_cat 362 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 363 PURE FUNCTION fct__l_cat(cd_char, ld_val) & 364 & RESULT(cf_str) 302 365 !------------------------------------------------------------------- 303 366 !> @brief This function concatenate character and logical (as character). … … 310 373 !> @return string character 311 374 !------------------------------------------------------------------- 312 PURE CHARACTER(LEN=lc) FUNCTION fct__l_cat(cd_char, ld_val) 375 376 IMPLICIT NONE 313 377 314 378 ! arguments … … 316 380 LOGICAL, INTENT(IN) :: ld_val 317 381 382 ! function 383 CHARACTER(LEN=lc) :: cf_str 384 318 385 ! local variable 319 386 CHARACTER(LEN=lc) :: cl_val … … 321 388 322 389 cl_val = fct_str(ld_val) 323 fct__l_cat=TRIM(cd_char)//TRIM(cl_val)390 cf_str = TRIM(cd_char)//TRIM(cl_val) 324 391 325 392 END FUNCTION fct__l_cat 393 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 394 FUNCTION fct_getunit() & 395 & RESULT(if_unit) 326 396 !------------------------------------------------------------------- 327 397 !> @brief This function returns the next available I/O unit number. … … 332 402 !> @return file id 333 403 !------------------------------------------------------------------- 334 INTEGER(i4) FUNCTION fct_getunit() 335 404 405 IMPLICIT NONE 406 407 ! function 408 INTEGER(i4) :: if_unit 409 336 410 ! local variable 337 411 LOGICAL :: ll_opened 338 412 !---------------------------------------------------------------- 339 413 ! initialise 340 fct_getunit = 10341 342 INQUIRE(UNIT= fct_getunit, OPENED=ll_opened)414 if_unit = 10 415 416 INQUIRE(UNIT=if_unit, OPENED=ll_opened) 343 417 DO WHILE( ll_opened ) 344 fct_getunit = fct_getunit + 1345 INQUIRE(UNIT= fct_getunit, OPENED=ll_opened)418 if_unit = if_unit + 1 419 INQUIRE(UNIT=if_unit, OPENED=ll_opened) 346 420 ENDDO 347 421 348 422 END FUNCTION fct_getunit 423 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 424 SUBROUTINE fct_err(id_status) 349 425 !------------------------------------------------------------------- 350 426 !> @brief This subroutine handle Fortran status. 351 ! 427 !> 352 428 !> @author J.Paul 353 429 !> @date November, 2013 - Initial Version … … 355 431 !> @param[in] id_status 356 432 !------------------------------------------------------------------- 357 SUBROUTINE fct_err(id_status) 433 434 IMPLICIT NONE 358 435 359 436 ! Argument … … 363 440 IF( id_status /= 0 )THEN 364 441 !CALL ERRSNS() ! not F95 standard 365 PRINT *, "FORTRAN ERROR ", id_status442 PRINT *, "FORTRAN ERROR ", id_status 366 443 !STOP 367 444 ENDIF 368 445 369 446 END SUBROUTINE fct_err 447 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 448 SUBROUTINE fct_pause(cd_msg) 370 449 !------------------------------------------------------------------- 371 450 !> @brief This subroutine create a pause statement 372 ! 451 !> 373 452 !> @author J.Paul 374 453 !> @date November, 2014 - Initial Version … … 376 455 !> @param[in] cd_msg optional message to be added 377 456 !------------------------------------------------------------------- 378 SUBROUTINE fct_pause(cd_msg) 457 458 IMPLICIT NONE 379 459 380 460 ! Argument … … 390 470 391 471 END SUBROUTINE fct_pause 472 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 473 PURE FUNCTION fct__l_str(ld_var) & 474 & RESULT(cf_str) 392 475 !------------------------------------------------------------------- 393 476 !> @brief This function convert logical to string character. … … 395 478 !> @author J.Paul 396 479 !> @date November, 2013 - Initial Version 397 ! 480 !> 398 481 !> @param[in] ld_var logical variable 399 482 !> @return character of this integer variable 400 483 !------------------------------------------------------------------- 401 PURE CHARACTER(LEN=lc) FUNCTION fct__l_str(ld_var) 402 IMPLICIT NONE 484 485 IMPLICIT NONE 486 403 487 ! Argument 404 488 LOGICAL, INTENT(IN) :: ld_var 405 489 490 ! function 491 CHARACTER(LEN=lc) :: cf_str 492 406 493 ! local variable 407 494 CHARACTER(LEN=lc) :: cl_tmp 408 495 !---------------------------------------------------------------- 409 496 410 write(cl_tmp,*) ld_var411 fct__l_str=TRIM(ADJUSTL(cl_tmp))497 WRITE(cl_tmp,*) ld_var 498 cf_str=TRIM(ADJUSTL(cl_tmp)) 412 499 413 500 END FUNCTION fct__l_str 501 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 502 PURE FUNCTION fct__i1_str(bd_var) & 503 & RESULT(cf_str) 414 504 !------------------------------------------------------------------- 415 505 !> @brief This function convert integer(1) to string character. … … 417 507 !> @author J.Paul 418 508 !> @date November, 2013 - Initial Version 419 ! 509 !> 420 510 !> @param[in] bd_var integer(1) variable 421 511 !> @return character of this integer variable 422 512 !------------------------------------------------------------------- 423 PURE CHARACTER(LEN=lc) FUNCTION fct__i1_str(bd_var) 424 IMPLICIT NONE 513 514 IMPLICIT NONE 515 425 516 ! Argument 426 517 INTEGER(i1), INTENT(IN) :: bd_var 427 518 519 ! function 520 CHARACTER(LEN=lc) :: cf_str 521 428 522 ! local variable 429 523 CHARACTER(LEN=lc) :: cl_tmp 430 524 !---------------------------------------------------------------- 431 525 432 write(cl_tmp,*) bd_var433 fct__i1_str=TRIM(ADJUSTL(cl_tmp))526 WRITE(cl_tmp,*) bd_var 527 cf_str=TRIM(ADJUSTL(cl_tmp)) 434 528 435 529 END FUNCTION fct__i1_str 530 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 531 PURE FUNCTION fct__i2_str(sd_var) & 532 & RESULT(cf_str) 436 533 !------------------------------------------------------------------- 437 534 !> @brief This function convert integer(2) to string character. … … 439 536 !> @author J.Paul 440 537 !> @date November, 2013 - Initial Version 441 ! 538 !> 442 539 !> @param[in] sd_var integer(2) variable 443 540 !> @return character of this integer variable 444 541 !------------------------------------------------------------------- 445 PURE CHARACTER(LEN=lc) FUNCTION fct__i2_str(sd_var) 446 IMPLICIT NONE 542 543 IMPLICIT NONE 544 447 545 ! Argument 448 546 INTEGER(i2), INTENT(IN) :: sd_var 449 547 548 ! function 549 CHARACTER(LEN=lc) :: cf_str 550 450 551 ! local variable 451 552 CHARACTER(LEN=lc) :: cl_tmp 452 553 !---------------------------------------------------------------- 453 554 454 write(cl_tmp,*) sd_var455 fct__i2_str=TRIM(ADJUSTL(cl_tmp))555 WRITE(cl_tmp,*) sd_var 556 cf_str=TRIM(ADJUSTL(cl_tmp)) 456 557 457 558 END FUNCTION fct__i2_str 559 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 560 PURE FUNCTION fct__i4_str(id_var) & 561 & RESULT(cf_str) 458 562 !------------------------------------------------------------------- 459 563 !> @brief This function convert integer(4) to string character. … … 461 565 !> @author J.Paul 462 566 !> @date November, 2013 - Initial Version 463 ! 567 !> 464 568 !> @param[in] id_var integer(4) variable 465 569 !> @return character of this integer variable 466 570 !------------------------------------------------------------------- 467 PURE CHARACTER(LEN=lc) FUNCTION fct__i4_str(id_var) 468 IMPLICIT NONE 571 572 IMPLICIT NONE 573 469 574 ! Argument 470 575 INTEGER(i4), INTENT(IN) :: id_var 471 576 577 ! function 578 CHARACTER(LEN=lc) :: cf_str 579 472 580 ! local variable 473 581 CHARACTER(LEN=lc) :: cl_tmp 474 582 !---------------------------------------------------------------- 475 583 476 write(cl_tmp,*) id_var477 fct__i4_str=TRIM(ADJUSTL(cl_tmp))584 WRITE(cl_tmp,*) id_var 585 cf_str=TRIM(ADJUSTL(cl_tmp)) 478 586 479 587 END FUNCTION fct__i4_str 588 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 589 PURE FUNCTION fct__i8_str(kd_var) & 590 & RESULT(cf_str) 480 591 !------------------------------------------------------------------- 481 592 !> @brief This function convert integer(8) to string character. … … 483 594 !> @author J.Paul 484 595 !> @date November, 2013 - Initial Version 485 ! 596 !> 486 597 !> @param[in] kd_var integer(8) variable 487 598 !> @return character of this integer variable 488 599 !------------------------------------------------------------------- 489 PURE CHARACTER(LEN=lc) FUNCTION fct__i8_str(kd_var) 490 IMPLICIT NONE 600 601 IMPLICIT NONE 602 491 603 ! Argument 492 604 INTEGER(i8), INTENT(IN) :: kd_var 493 605 606 ! function 607 CHARACTER(LEN=lc) :: cf_str 608 494 609 ! local variable 495 610 CHARACTER(LEN=lc) :: cl_tmp 496 611 !---------------------------------------------------------------- 497 612 498 write(cl_tmp,*) kd_var499 fct__i8_str=TRIM(ADJUSTL(cl_tmp))613 WRITE(cl_tmp,*) kd_var 614 cf_str=TRIM(ADJUSTL(cl_tmp)) 500 615 501 616 END FUNCTION fct__i8_str 617 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 618 PURE FUNCTION fct__r4_str(rd_var) & 619 & RESULT(cf_str) 502 620 !------------------------------------------------------------------- 503 621 !> @brief This function convert real(4) to string character. … … 505 623 !> @author J.Paul 506 624 !> @date November, 2013 - Initial Version 507 ! 625 !> 508 626 !> @param[in] rd_var real(4) variable 509 627 !> @return character of this real variable 510 628 !------------------------------------------------------------------- 511 PURE CHARACTER(LEN=lc) FUNCTION fct__r4_str(rd_var) 512 IMPLICIT NONE 629 630 IMPLICIT NONE 631 513 632 ! Argument 514 633 REAL(sp), INTENT(IN) :: rd_var 515 634 635 ! function 636 CHARACTER(LEN=lc) :: cf_str 637 516 638 ! local variable 517 639 CHARACTER(LEN=lc) :: cl_tmp 518 640 !---------------------------------------------------------------- 519 641 520 write(cl_tmp,*) rd_var521 fct__r4_str=TRIM(ADJUSTL(cl_tmp))642 WRITE(cl_tmp,*) rd_var 643 cf_str=TRIM(ADJUSTL(cl_tmp)) 522 644 523 645 END FUNCTION fct__r4_str 646 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 647 PURE FUNCTION fct__r8_str(dd_var) & 648 & RESULT(cf_str) 524 649 !------------------------------------------------------------------- 525 650 !> @brief This function convert real(8) to string character. … … 527 652 !> @author J.Paul 528 653 !> @date November, 2013 - Initial Version 529 ! 654 !> 530 655 !> @param[in] dd_var real(8) variable 531 656 !> @return character of this real variable 532 657 !------------------------------------------------------------------- 533 PURE CHARACTER(LEN=lc) FUNCTION fct__r8_str(dd_var) 534 IMPLICIT NONE 658 659 IMPLICIT NONE 660 535 661 ! Argument 536 662 REAL(dp), INTENT(IN) :: dd_var 537 663 664 ! function 665 CHARACTER(LEN=lc) :: cf_str 666 538 667 ! local variable 539 668 CHARACTER(LEN=lc) :: cl_tmp 540 669 !---------------------------------------------------------------- 541 670 542 write(cl_tmp,*) dd_var543 fct__r8_str=TRIM(ADJUSTL(cl_tmp))671 WRITE(cl_tmp,*) dd_var 672 cf_str=TRIM(ADJUSTL(cl_tmp)) 544 673 545 674 END FUNCTION fct__r8_str 675 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 676 PURE FUNCTION fct_concat(cd_arr,cd_sep) & 677 & RESULT(cf_str) 546 678 !------------------------------------------------------------------- 547 679 !> @brief This function concatenate all the element of a character array … … 552 684 !> @author J.Paul 553 685 !> @date November, 2013 - Initial Version 554 ! 686 !> 555 687 !> @param[in] cd_arr array of character 556 688 !> @param[in] cd_sep separator character 557 689 !> @return character 558 690 !------------------------------------------------------------------- 559 PURE CHARACTER(LEN=lc) FUNCTION fct_concat(cd_arr,cd_sep) 560 IMPLICIT NONE 691 692 IMPLICIT NONE 693 561 694 ! Argument 562 695 CHARACTER(*), DIMENSION(:), INTENT(IN) :: cd_arr 563 696 CHARACTER(*), INTENT(IN), OPTIONAL :: cd_sep 697 698 ! function 699 CHARACTER(LEN=lc) :: cf_str 564 700 565 701 ! local variable … … 576 712 577 713 il_size=SIZE(cd_arr) 578 fct_concat=''714 cf_str='' 579 715 cl_tmp='' 580 716 DO ji=1,il_size 581 717 582 WRITE(cl_tmp,*) TRIM( fct_concat)//TRIM(ADJUSTL(cd_arr(ji)))//TRIM(cl_sep)583 fct_concat=TRIM(ADJUSTL(cl_tmp))718 WRITE(cl_tmp,*) TRIM(cf_str)//TRIM(ADJUSTL(cd_arr(ji)))//TRIM(cl_sep) 719 cf_str=TRIM(ADJUSTL(cl_tmp)) 584 720 585 721 ENDDO 586 722 587 723 END FUNCTION fct_concat 724 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 725 PURE FUNCTION fct_lower(cd_var) & 726 & RESULT(cf_str) 588 727 !------------------------------------------------------------------- 589 728 !> @brief This function convert string character upper case to lower case. 590 ! 729 !> 591 730 !> @details 592 731 !> The function IACHAR returns the ASCII value of the character passed … … 595 734 !> IACHAR('a')- IACHAR('A') would be the difference between the uppercase 596 735 !> and the lowercase codes. 597 ! 598 !> @author J.Paul 599 !> @date November, 2013 - Initial Version 600 ! 736 !> 737 !> @author J.Paul 738 !> @date November, 2013 - Initial Version 739 !> 601 740 !> @param[in] cd_var character 602 741 !> @return lower case character 603 742 !------------------------------------------------------------------- 604 PURE CHARACTER(LEN=lc) FUNCTION fct_lower(cd_var) 605 IMPLICIT NONE 743 744 IMPLICIT NONE 745 606 746 ! Argument 607 747 CHARACTER(*), INTENT(IN) :: cd_var 748 749 ! function 750 CHARACTER(LEN=lc) :: cf_str 608 751 609 752 ! local variable … … 639 782 ENDDO 640 783 641 fct_lower=TRIM(ADJUSTL(fct_concat(cl_tmp(:))))784 cf_str=TRIM(ADJUSTL(fct_concat(cl_tmp(:)))) 642 785 DEALLOCATE(cl_tmp) 643 786 644 787 END FUNCTION fct_lower 788 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 789 PURE FUNCTION fct_upper(cd_var) & 790 & RESULT(cf_str) 645 791 !------------------------------------------------------------------- 646 792 !> @brief This function convert string character lower case to upper case. 647 ! 793 !> 648 794 !> @details 649 795 !> The function IACHAR returns the ASCII value of the character passed … … 652 798 !> IACHAR('a')- IACHAR('A') would be the difference between the uppercase 653 799 !> and the lowercase codes. 654 ! 655 !> @author J.Paul 656 !> @date November, 2013 - Initial Version 657 ! 800 !> 801 !> @author J.Paul 802 !> @date November, 2013 - Initial Version 803 !> 658 804 !> @param[in] cd_var character 659 805 !> @return upper case character 660 806 !------------------------------------------------------------------- 661 PURE CHARACTER(LEN=lc) FUNCTION fct_upper(cd_var) 662 IMPLICIT NONE 807 808 IMPLICIT NONE 809 663 810 ! Argument 664 811 CHARACTER(*), INTENT(IN) :: cd_var 812 813 ! function 814 CHARACTER(LEN=lc) :: cf_str 665 815 666 816 ! local variable … … 696 846 ENDDO 697 847 698 fct_upper=TRIM(ADJUSTL(fct_concat(cl_tmp(:))))848 cf_str=TRIM(ADJUSTL(fct_concat(cl_tmp(:)))) 699 849 DEALLOCATE(cl_tmp) 700 850 701 851 END FUNCTION fct_upper 852 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 853 PURE FUNCTION fct_is_num(cd_var) & 854 & RESULT(lf_numeric) 702 855 !------------------------------------------------------------------- 703 856 !> @brief This function check if character is numeric. 704 ! 705 !> @author J.Paul 706 !> @date November, 2013 - Initial Version 707 ! 857 !> 858 !> @author J.Paul 859 !> @date November, 2013 - Initial Version 860 !> 708 861 !> @param[in] cd_var character 709 862 !> @return character is numeric 710 863 !------------------------------------------------------------------- 711 PURE LOGICAL FUNCTION fct_is_num(cd_var) 712 IMPLICIT NONE 864 865 IMPLICIT NONE 866 713 867 ! Argument 714 868 CHARACTER(LEN=*), INTENT(IN) :: cd_var 869 870 ! function 871 LOGICAL :: lf_numeric 715 872 716 873 ! loop indices … … 721 878 IF( IACHAR(cd_var(ji:ji)) >= IACHAR('0') .AND. & 722 879 & IACHAR(cd_var(ji:ji)) <= IACHAR('9') )THEN 723 fct_is_num=.TRUE.880 lf_numeric=.TRUE. 724 881 ELSE 725 fct_is_num=.FALSE.882 lf_numeric=.FALSE. 726 883 EXIT 727 884 ENDIF … … 729 886 730 887 END FUNCTION fct_is_num 888 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 889 PURE FUNCTION fct_is_real(cd_var) & 890 & RESULT(lf_real) 731 891 !------------------------------------------------------------------- 732 892 !> @brief This function check if character is real number. 733 ! 893 !> 734 894 !> @details 735 !> it allows exponantial and decimal number895 !> it permits exponantial and decimal number 736 896 !> exemple : 1e6, 2.3 737 897 !> 738 898 !> @author J.Paul 739 899 !> @date June, 2015 - Initial Version 740 ! 900 !> @date April, 2018 901 !> - permit negative exposant 902 !> - permit sign as first character 903 !> 741 904 !> @param[in] cd_var character 742 905 !> @return character is real number 743 906 !------------------------------------------------------------------- 744 PURE LOGICAL FUNCTION fct_is_real(cd_var) 745 IMPLICIT NONE 907 908 IMPLICIT NONE 909 746 910 ! Argument 747 911 CHARACTER(LEN=*), INTENT(IN) :: cd_var 748 912 913 ! function 914 LOGICAL :: lf_real 915 749 916 ! local variables 750 917 LOGICAL :: ll_exp … … 761 928 & IACHAR(cd_var(ji:ji)) <= IACHAR('9') )THEN 762 929 763 fct_is_real=.TRUE.930 lf_real=.TRUE. 764 931 ll_exp=.FALSE. 765 932 766 ELSEIF( TRIM( cd_var(ji:ji))=='e' )THEN933 ELSEIF( TRIM(fct_lower(cd_var(ji:ji)))=='e' )THEN 767 934 768 935 IF( ll_exp .OR. ji== LEN(TRIM(cd_var)) )THEN 769 fct_is_real=.FALSE.936 lf_real=.FALSE. 770 937 EXIT 771 938 ELSE 772 939 ll_exp=.TRUE. 773 940 ENDIF 774 941 942 ELSEIF( TRIM(cd_var(ji:ji))=='+' )THEN 943 IF( ji /= 1 )THEN 944 lf_real=.FALSE. 945 EXIT 946 ELSE 947 lf_real=.TRUE. 948 ENDIF 949 950 ELSEIF( TRIM(cd_var(ji:ji))=='-' )THEN 951 952 IF( ji <= 1 )THEN 953 IF( ji /= 1 )THEN 954 lf_real=.FALSE. 955 EXIT 956 ELSE 957 lf_real=.TRUE. 958 ENDIF 959 ELSE ! ji > 1 960 IF( TRIM(fct_lower(cd_var(ji-1:ji-1)))/='e' )THEN 961 lf_real=.FALSE. 962 EXIT 963 ELSE 964 lf_real=.TRUE. 965 ENDIF 966 ENDIF 967 775 968 ELSEIF( TRIM(cd_var(ji:ji))=='.' )THEN 776 969 777 970 IF( ll_dec )THEN 778 fct_is_real=.FALSE.971 lf_real=.FALSE. 779 972 EXIT 780 973 ELSE 781 fct_is_real=.TRUE.974 lf_real=.TRUE. 782 975 ll_dec=.TRUE. 783 976 ENDIF … … 785 978 ELSE 786 979 787 fct_is_real=.FALSE.980 lf_real=.FALSE. 788 981 EXIT 789 982 … … 792 985 793 986 END FUNCTION fct_is_real 987 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 988 PURE FUNCTION fct_split(cd_string, id_ind, cd_sep) & 989 & RESULT(cf_elt) 794 990 !------------------------------------------------------------------- 795 991 !> @brief This function split string of character 796 992 !> using separator character, by default '|', 797 993 !> and return the element on index ind. 798 ! 799 !> @author J.Paul 800 !> @date November, 2013 - Initial Version 801 ! 994 !> 995 !> @author J.Paul 996 !> @date November, 2013 - Initial Version 997 !> 802 998 !> @param[in] cd_string string of character 803 999 !> @param[in] id_ind indice 804 1000 !> @param[in] cd_sep separator character 805 !> @return return the element on index id_ind 806 !------------------------------------------------------------------- 807 PURE FUNCTION fct_split(cd_string, id_ind, cd_sep) 808 IMPLICIT NONE 1001 !> @return return the element of index id_ind 1002 !------------------------------------------------------------------- 1003 1004 IMPLICIT NONE 1005 809 1006 ! Argument 810 1007 CHARACTER(LEN=*), INTENT(IN) :: cd_string … … 813 1010 814 1011 ! function 815 CHARACTER(LEN=lc) :: fct_split1012 CHARACTER(LEN=lc) :: cf_elt 816 1013 817 1014 ! local variable … … 826 1023 !---------------------------------------------------------------- 827 1024 ! initialize 828 fct_split=''1025 cf_elt='' 829 1026 cl_string=ADJUSTL(cd_string) 830 1027 … … 845 1042 846 1043 IF( il_sep /= 0 )THEN 847 fct_split=TRIM(ADJUSTL(cl_string(1:il_sep-1)))1044 cf_elt=TRIM(ADJUSTL(cl_string(1:il_sep-1))) 848 1045 ELSE 849 fct_split=TRIM(ADJUSTL(cl_string))1046 cf_elt=TRIM(ADJUSTL(cl_string)) 850 1047 ENDIF 851 1048 … … 859 1056 860 1057 IF( il_sep /= 0 )THEN 861 fct_split=TRIM(ADJUSTL(cl_string(1:il_sep-1)))1058 cf_elt=TRIM(ADJUSTL(cl_string(1:il_sep-1))) 862 1059 ELSE 863 fct_split=TRIM(ADJUSTL(cl_string))1060 cf_elt=TRIM(ADJUSTL(cl_string)) 864 1061 ENDIF 865 1062 866 1063 ENDDO 867 1064 868 IF( ji /= id_ind ) fct_split=''1065 IF( ji /= id_ind ) cf_elt='' 869 1066 ELSE 870 fct_split=fct__split_space(TRIM(cl_string), id_ind)1067 cf_elt=fct__split_space(TRIM(cl_string), id_ind) 871 1068 ENDIF 872 1069 873 1070 END FUNCTION fct_split 1071 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1072 PURE FUNCTION fct__split_space(cd_string, id_ind) & 1073 & RESULT(cf_elt) 874 1074 !------------------------------------------------------------------- 875 1075 !> @brief This function split string of character 876 1076 !> using space as separator, 877 1077 !> and return the element on index ind. 878 ! 879 !> @author J.Paul 880 !> @date November, 2013 - Initial Version 881 ! 1078 !> 1079 !> @author J.Paul 1080 !> @date November, 2013 - Initial Version 1081 !> 882 1082 !> @param[in] cd_string string of character 883 1083 !> @param[in] id_ind indice 884 !> @return return the element on index id_ind 885 !------------------------------------------------------------------- 886 PURE FUNCTION fct__split_space(cd_string, id_ind) 887 IMPLICIT NONE 1084 !> @return return the element of index id_ind 1085 !------------------------------------------------------------------- 1086 1087 IMPLICIT NONE 1088 888 1089 ! Argument 889 1090 CHARACTER(LEN=*), INTENT(IN) :: cd_string … … 891 1092 892 1093 ! function 893 CHARACTER(LEN=lc) :: fct__split_space1094 CHARACTER(LEN=lc) :: cf_elt 894 1095 895 1096 ! local variable … … 903 1104 !---------------------------------------------------------------- 904 1105 ! initialize 905 fct__split_space=''1106 cf_elt='' 906 1107 cl_string=ADJUSTL(cd_string) 907 1108 … … 911 1112 912 1113 IF( il_sep /= 0 )THEN 913 fct__split_space=TRIM(ADJUSTL(cl_string(1:il_sep-1)))1114 cf_elt=TRIM(ADJUSTL(cl_string(1:il_sep-1))) 914 1115 ELSE 915 fct__split_space=TRIM(ADJUSTL(cl_string))1116 cf_elt=TRIM(ADJUSTL(cl_string)) 916 1117 ENDIF 917 1118 … … 925 1126 926 1127 IF( il_sep /= 0 )THEN 927 fct__split_space=TRIM(ADJUSTL(cl_string(1:il_sep-1)))1128 cf_elt=TRIM(ADJUSTL(cl_string(1:il_sep-1))) 928 1129 ELSE 929 fct__split_space=TRIM(ADJUSTL(cl_string))1130 cf_elt=TRIM(ADJUSTL(cl_string)) 930 1131 ENDIF 931 1132 932 1133 ENDDO 933 1134 934 IF( ji /= id_ind ) fct__split_space=''1135 IF( ji /= id_ind ) cf_elt='' 935 1136 936 1137 END FUNCTION fct__split_space 1138 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1139 PURE FUNCTION fct_basename(cd_string, cd_sep) & 1140 & RESULT(cf_file) 937 1141 !------------------------------------------------------------------- 938 1142 !> @brief This function return basename of a filename. 939 ! 1143 !> 940 1144 !> @details 941 1145 !> Actually it splits filename using sperarator '/' … … 944 1148 !> @author J.Paul 945 1149 !> @date November, 2013 - Initial Version 946 ! 1150 !> 947 1151 !> @param[in] cd_string filename 948 1152 !> @param[in] cd_sep separator character 949 1153 !> @return basename (filename without path) 950 1154 !------------------------------------------------------------------- 951 PURE FUNCTION fct_basename(cd_string, cd_sep) 952 IMPLICIT NONE 1155 1156 IMPLICIT NONE 1157 953 1158 ! Argument 954 1159 CHARACTER(LEN=*), INTENT(IN) :: cd_string … … 956 1161 957 1162 ! function 958 CHARACTER(LEN=lc) :: fct_basename1163 CHARACTER(LEN=lc) :: cf_file 959 1164 960 1165 ! local variable … … 973 1178 974 1179 il_sep=INDEX( TRIM(cl_string), TRIM(cl_sep), BACK=.TRUE.) 975 fct_basename=TRIM(cl_string(il_sep+1:))1180 cf_file=TRIM(cl_string(il_sep+1:)) 976 1181 977 1182 END FUNCTION fct_basename 1183 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1184 PURE FUNCTION fct_dirname(cd_string, cd_sep) & 1185 & RESULT(cf_dir) 978 1186 !------------------------------------------------------------------- 979 1187 !> @brief This function return dirname of a filename. 980 ! 1188 !> 981 1189 !> @details 982 1190 !> Actually it splits filename using sperarator '/' … … 985 1193 !> @author J.Paul 986 1194 !> @date November, 2013 - Initial Version 987 ! 1195 !> 988 1196 !> @param[in] cd_string filename 989 1197 !> @param[in] cd_sep separator character 990 1198 !> @return dirname (path of the filename) 991 1199 !------------------------------------------------------------------- 992 PURE FUNCTION fct_dirname(cd_string, cd_sep) 993 IMPLICIT NONE 1200 1201 IMPLICIT NONE 1202 994 1203 ! Argument 995 1204 CHARACTER(LEN=*), INTENT(IN) :: cd_string … … 997 1206 998 1207 ! function 999 CHARACTER(LEN=lc) :: fct_dirname1208 CHARACTER(LEN=lc) :: cf_dir 1000 1209 1001 1210 ! local variable … … 1015 1224 il_sep=INDEX( TRIM(cl_string), TRIM(cl_sep), BACK=.TRUE.) 1016 1225 IF( il_sep == 0 )THEN 1017 fct_dirname=''1226 cf_dir='' 1018 1227 ELSE 1019 fct_dirname=TRIM(cl_string(1:il_sep))1228 cf_dir=TRIM(cl_string(1:il_sep)) 1020 1229 ENDIF 1021 1230 1022 1231 END FUNCTION fct_dirname 1232 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1233 SUBROUTINE fct_help(cd_filename, cd_err) 1234 !------------------------------------------------------------------- 1235 !> @brief 1236 !> This function show help message. 1237 !> 1238 !> @details 1239 !> Optionaly, print error detected 1240 !> 1241 !> @author J.Paul 1242 !> @date October, 2019 - Initial Version 1243 !> 1244 !> @param[in] cd_filename file name 1245 !> @param[in] cd_err error message 1246 !> 1247 !> @return print help message 1248 !------------------------------------------------------------------- 1249 1250 IMPLICIT NONE 1251 1252 ! Argument 1253 CHARACTER(LEN=*), INTENT(IN) :: cd_filename 1254 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_err 1255 !---------------------------------------------------------------- 1256 1257 PRINT '( /, a,/)', 'USAGE: '//TRIM(cd_filename)//' namelist [-v] [-h]' 1258 PRINT '( 2x,a,/)', 'positional arguments:' 1259 PRINT '( 5x,a )', 'namelist '//TRIM(cd_filename)//" namelist" 1260 PRINT '( /,5x,a,/)', 'NB : a template of the namelist could be created running (in templates directory):' 1261 PRINT '( 8x,a )', 'python create_templates.py '//TRIM(cd_filename) 1262 PRINT '( /,2x,a,/)', 'optional arguments:' 1263 PRINT '( 5x,a )', "-h, --help display this help and exit" 1264 PRINT '( 5x,a,/)', "-v, --version output Siren's version information and exit" 1265 IF (PRESENT(cd_err)) THEN 1266 PRINT '(2x,a,/)', 'ERROR DETECTED:' 1267 PRINT '(5x,a,/)', TRIM(cd_err) 1268 ENDIF 1269 1270 END SUBROUTINE fct_help 1271 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1272 SUBROUTINE fct_version(cd_filename) 1273 !------------------------------------------------------------------- 1274 !> @brief 1275 !> This function show the version of Siren. 1276 !> 1277 !> @author J.Paul 1278 !> @date October, 2019 - Initial Version 1279 !> 1280 !> @param[in] cd_filename file name 1281 !> 1282 !> @return print version message 1283 !------------------------------------------------------------------- 1284 1285 IMPLICIT NONE 1286 1287 ! Argument 1288 CHARACTER(LEN=*), INTENT(IN) :: cd_filename 1289 !---------------------------------------------------------------- 1290 1291 PRINT '( /, a,/)', 'PROGRAM: Siren - '//TRIM(cd_filename) 1292 PRINT '(2x,2a )', 'Revision of last commit : ', TRIM(fct_split(fct_split(cp_version,2,'$'),2,'Revision:')) 1293 PRINT '(2x,2a )', 'Author of last commit : ', TRIM(fct_split(fct_split(cp_author,2,'$'),2,'Author:')) 1294 PRINT '(2x,2a )', 'Date of last commit : ', TRIM(fct_split(fct_split(cp_date,2,'$'),2,'Date:')) 1295 PRINT '(2x,2a,/)', 'SVN URL : ', TRIM(fct_split(fct_split(fct_split(cp_url,2,'$'),2,'URL:'),1,'/src/global.f90')) 1296 1297 END SUBROUTINE fct_version 1298 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1023 1299 END MODULE fct 1024 1300
Note: See TracChangeset
for help on using the changeset viewer.