1!! Copyright (C) 2003-2006 M. Marques, A. Castro, A. Rubio, G. Bertsch 2!! 3!! This program is free software; you can redistribute it and/or modify 4!! it under the terms of the GNU General Public License as published by 5!! the Free Software Foundation; either version 2, or (at your option) 6!! any later version. 7!! 8!! This program is distributed in the hope that it will be useful, 9!! but WITHOUT ANY WARRANTY; without even the implied warranty of 10!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11!! GNU General Public License for more details. 12!! 13!! You should have received a copy of the GNU General Public License 14!! along with this program; if not, write to the Free Software 15!! Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 16!! 02110-1301, USA. 17!! 18 19#include "global.h" 20 21module parser_oct_m 22 use global_oct_m 23 use loct_oct_m 24 use mpi_oct_m 25 use namespace_oct_m 26 use unit_oct_m 27 use varinfo_oct_m 28 29 implicit none 30 31 private 32 public :: & 33 block_t, & 34 parser_init, & 35 parser_end, & 36 parse_init, & 37 parse_putsym, & 38 parse_end, & 39 parse_is_defined, & 40 parse_variable, & 41 parse_block, & 42 parse_block_end, & 43 parse_block_n, & 44 parse_block_cols, & 45 parse_block_integer, & 46 parse_block_float, & 47 parse_block_cmplx, & 48 parse_block_string, & 49 parse_block_logical, & 50 parse_expression, & 51 parse_array 52 53 type :: block_t 54 private 55 integer, pointer :: p 56 end type block_t 57 58 interface parse_init 59 integer function oct_parse_init(file_out, mpiv_node) 60 implicit none 61 character(len=*), intent(in) :: file_out 62 integer, intent(in) :: mpiv_node 63 end function oct_parse_init 64 end interface parse_init 65 66 interface parse_putsym 67 subroutine oct_parse_putsym_int(sym, i) 68 implicit none 69 character(len=*), intent(in) :: sym 70 integer, intent(in) :: i 71 end subroutine oct_parse_putsym_int 72 subroutine oct_parse_putsym_double(sym, d) 73 implicit none 74 character(len=*), intent(in) :: sym 75 real(8), intent(in) :: d 76 end subroutine oct_parse_putsym_double 77 module procedure oct_parse_putsym_double4 78 end interface parse_putsym 79 80 interface parse_input_file 81 integer function oct_parse_input(file_in, set_used) 82 implicit none 83 character(len=*), intent(in) :: file_in 84 integer, intent(in) :: set_used 85 end function oct_parse_input 86 end interface parse_input_file 87 88 interface parse_environment 89 subroutine oct_parse_environment(prefix) 90 implicit none 91 character(len=*), intent(in) :: prefix 92 end subroutine oct_parse_environment 93 end interface parse_environment 94 95 interface parse_end 96 subroutine oct_parse_end() 97 implicit none 98 end subroutine oct_parse_end 99 end interface parse_end 100 101 interface sym_output_table 102 subroutine oct_sym_output_table(only_unused, mpiv_node) 103 implicit none 104 integer, intent(in) :: only_unused 105 integer, intent(in) :: mpiv_node 106 end subroutine oct_sym_output_table 107 end interface sym_output_table 108 109 interface parse_isdef 110 integer function oct_parse_isdef(name) 111 implicit none 112 character(len=*), intent(in) :: name 113 end function oct_parse_isdef 114 end interface parse_isdef 115 116 interface 117 subroutine oct_parse_int(name, def, res) 118 implicit none 119 character(len=*), intent(in) :: name 120 integer(8), intent(in) :: def 121 integer(8), intent(out) :: res 122 end subroutine oct_parse_int 123 124 subroutine oct_parse_double(name, def, res) 125 implicit none 126 character(len=*), intent(in) :: name 127 real(8), intent(in) :: def 128 real(8), intent(out) :: res 129 end subroutine oct_parse_double 130 131 subroutine oct_parse_complex(name, def, res) 132 implicit none 133 character(len=*), intent(in) :: name 134 complex(8), intent(in) :: def 135 complex(8), intent(out) :: res 136 end subroutine oct_parse_complex 137 138 subroutine oct_parse_string(name, def, res) 139 implicit none 140 character(len=*), intent(in) :: name, def 141 character(len=*), intent(out):: res 142 end subroutine oct_parse_string 143 144 integer function oct_parse_block(name, blk) 145 import block_t 146 implicit none 147 character(len=*), intent(in) :: name 148 type(block_t), intent(out) :: blk 149 end function oct_parse_block 150 151 end interface 152 153 interface parse_variable 154 module procedure parse_integer 155 module procedure parse_integer8 156 module procedure parse_integer48 157 module procedure parse_integer84 158 module procedure parse_logical 159 module procedure parse_string 160 module procedure parse_cmplx 161 module procedure oct_parse_double4_unit 162 module procedure oct_parse_double8_unit 163 end interface parse_variable 164 165 interface parse_block_end 166 subroutine oct_parse_block_end(blk) 167 import block_t 168 implicit none 169 type(block_t), intent(inout) :: blk 170 end subroutine oct_parse_block_end 171 end interface parse_block_end 172 173 interface parse_block_n 174 integer function oct_parse_block_n(blk) 175 import block_t 176 implicit none 177 type(block_t), intent(in) :: blk 178 end function oct_parse_block_n 179 end interface parse_block_n 180 181 interface parse_block_cols 182 integer function oct_parse_block_cols(blk, line) 183 import block_t 184 implicit none 185 type(block_t), intent(in) :: blk 186 integer, intent(in) :: line 187 end function oct_parse_block_cols 188 end interface parse_block_cols 189 190 interface parse_block_integer 191 subroutine oct_parse_block_int(blk, l, c, res) 192 import block_t 193 implicit none 194 type(block_t), intent(in) :: blk 195 integer, intent(in) :: l, c 196 integer, intent(out) :: res 197 end subroutine oct_parse_block_int 198 end interface parse_block_integer 199 200 interface parse_block_float 201 subroutine oct_parse_block_double(blk, l, c, res) 202 import block_t 203 implicit none 204 type(block_t), intent(in) :: blk 205 integer, intent(in) :: l, c 206 real(8), intent(out) :: res 207 end subroutine oct_parse_block_double 208 module procedure oct_parse_block_double4 209 module procedure oct_parse_block_double4_unit 210 module procedure oct_parse_block_double8_unit 211 end interface parse_block_float 212 213 interface parse_block_cmplx 214 subroutine oct_parse_block_complex(blk, l, c, res) 215 import block_t 216 implicit none 217 type(block_t), intent(in) :: blk 218 integer, intent(in) :: l, c 219 complex(8), intent(out) :: res 220 end subroutine oct_parse_block_complex 221 module procedure oct_parse_block_complex4 222 end interface parse_block_cmplx 223 224 interface parse_block_string 225 subroutine oct_parse_block_string(blk, l, c, res) 226 import block_t 227 implicit none 228 type(block_t), intent(in) :: blk 229 integer, intent(in) :: l, c 230 character(len=*), intent(out):: res 231 end subroutine oct_parse_block_string 232 end interface parse_block_string 233 234 ! --------------------------------------------------------- 235 !> The public subroutine parse_expression accepts two 236 !! possible interfaces, one which assumes that the variables 237 !! in the expression are "x(:)", "r" and "t", and another 238 !! one which permits to set one variable to whichever string. 239 !! Examples of usage: 240 !! 241 !! call parse_expression(f_re, f_im, ndim, x(:), r, t, & 242 !! "0.5*0.01*r^2") 243 !! 244 !! call parse_expression(f_re, f_im, "t", t, "cos(0.01*t)") 245 ! --------------------------------------------------------- 246 247 interface 248 subroutine oct_parse_expression(re, im, ndim, x, r, t, pot) 249 implicit none 250 real(8), intent(in) :: x, r, t 251 integer, intent(in) :: ndim 252 real(8), intent(out) :: re, im 253 character(len=*), intent(in) :: pot 254 end subroutine oct_parse_expression 255 end interface 256 257 interface parse_expression 258 subroutine oct_parse_expression1(re, im, c, x, string) 259 implicit none 260 real(8), intent(out) :: re, im 261 character(len=*), intent(in) :: c 262 real(8), intent(in) :: x 263 character(len=*), intent(in) :: string 264 end subroutine oct_parse_expression1 265 module procedure oct_parse_expression_vec 266 module procedure oct_parse_expression_vec4 267 module procedure oct_parse_expression14 268 end interface 269 270contains 271 272 ! --------------------------------------------------------- 273 subroutine parser_init() 274 275 integer :: ierr 276 logical :: file_exists 277 278 ! check files are present 279 inquire(file=trim(conf%share)//'/variables', exist=file_exists) 280 if(.not. file_exists) then 281 write(stderr,'(a)') '*** Fatal Error (description follows)' 282 write(stderr,'(a)') 'Error initializing parser' 283 write(stderr,'(a)') 'Cannot open variables file: '//trim(conf%share)//'/variables' 284 call parse_fatal() 285 end if 286 287 inquire(file='inp', exist=file_exists) 288 if(.not. file_exists) then 289 write(stderr,'(a)') '*** Fatal Error (description follows)' 290 write(stderr,'(a)') 'Error initializing parser' 291 write(stderr,'(a)') 'Cannot open input file!' 292 write(stderr,'(a)') 'Please provide an input file with name inp in the current workdir' 293 call parse_fatal() 294 end if 295 296 ! initialize the parser 297 if(mpi_grp_is_root(mpi_world)) call loct_mkdir('exec') 298 ierr = parse_init('exec/parser.log', mpi_world%rank) 299 if(ierr /= 0) then 300 write(stderr,'(a)') '*** Fatal Error (description follows)' 301 write(stderr,'(a)') 'Error initializing parser: cannot write to exec/parser.log.' 302 write(stderr,'(a)') 'Do you have write permissions in this directory?' 303 call parse_fatal() 304 end if 305 306 ! read in option definitions 307 ierr = parse_input_file(trim(conf%share)//'/variables', set_used = 1) 308 if(ierr /= 0) then 309 write(stderr,'(a)') '*** Fatal Error (description follows)' 310 write(stderr,'(a)') 'Error initializing parser' 311 write(stderr,'(a)') 'Cannot open variables file: '//trim(conf%share)//'/variables' 312 call parse_fatal() 313 end if 314 315 ! setup standard input 316 ierr = parse_input_file('inp', set_used = 0) 317 if(ierr /= 0) then 318 write(stderr,'(a)') '*** Fatal Error (description follows)' 319 write(stderr,'(a)') 'Error initializing parser' 320 write(stderr,'(a)') 'Cannot open input file!' 321 write(stderr,'(a)') 'Please provide an input file with name inp in the current workdir' 322 call parse_fatal() 323 end if 324 325 ! parse OCT_ prefixed variables from environment 326 call parse_environment("OCT_") 327 328 end subroutine parser_init 329 330 331 ! --------------------------------------------------------- 332 subroutine parser_end() 333 334 call sym_output_table(only_unused = 1, mpiv_node = mpi_world%rank) 335 call parse_end() 336 337 end subroutine parser_end 338 339 ! --------------------------------------------------------- 340 341 logical function parse_is_defined(namespace, name) result(isdef) 342 type(namespace_t), intent(in) :: namespace 343 character(len=*), intent(in) :: name 344 345 isdef = parse_isdef(parse_get_full_name(namespace, name)) /= 0 346 347 end function parse_is_defined 348 349 ! --------------------------------------------------------- 350 351 subroutine parse_integer(namespace, name, def, res) 352 type(namespace_t), intent(in) :: namespace 353 character(len=*), intent(in) :: name 354 integer, intent(in) :: def 355 integer, intent(out) :: res 356 357 integer(8) :: res8 358 359 call parse_check_varinfo(name) 360 call oct_parse_int(parse_get_full_name(namespace, name), int(def, 8), res8) 361 362 res = int(res8) 363 364 end subroutine parse_integer 365 366 ! --------------------------------------------------------- 367 368 subroutine parse_integer8(namespace, name, def, res) 369 type(namespace_t), intent(in) :: namespace 370 character(len=*), intent(in) :: name 371 integer(8), intent(in) :: def 372 integer(8), intent(out) :: res 373 374 call parse_check_varinfo(name) 375 call oct_parse_int(parse_get_full_name(namespace, name), def, res) 376 377 end subroutine parse_integer8 378 379 ! --------------------------------------------------------- 380 381 subroutine parse_integer48(namespace, name, def, res) 382 type(namespace_t), intent(in) :: namespace 383 character(len=*), intent(in) :: name 384 integer, intent(in) :: def 385 integer(8), intent(out) :: res 386 387 call parse_check_varinfo(name) 388 call oct_parse_int(parse_get_full_name(namespace, name), int(def, 8), res) 389 390 end subroutine parse_integer48 391 392 ! --------------------------------------------------------- 393 394 subroutine parse_integer84(namespace, name, def, res) 395 type(namespace_t), intent(in) :: namespace 396 character(len=*), intent(in) :: name 397 integer(8), intent(in) :: def 398 integer, intent(out) :: res 399 400 integer(8) :: res8 401 402 call parse_check_varinfo(name) 403 call oct_parse_int(parse_get_full_name(namespace, name), def, res8) 404 405 res = int(res8) 406 407 end subroutine parse_integer84 408 409 ! --------------------------------------------------------- 410 411 subroutine parse_string(namespace, name, def, res) 412 type(namespace_t), intent(in) :: namespace 413 character(len=*), intent(in) :: name 414 character(len=*), intent(in) :: def 415 character(len=*), intent(out) :: res 416 417 call parse_check_varinfo(name) 418 call oct_parse_string(parse_get_full_name(namespace, name), def, res) 419 420 end subroutine parse_string 421 422 ! --------------------------------------------------------- 423 !> logical is a FORTRAN type, so we emulate the routine with integers 424 subroutine parse_logical(namespace, name, def, res) 425 type(namespace_t), intent(in) :: namespace 426 character(len=*), intent(in) :: name 427 logical, intent(in) :: def 428 logical, intent(out) :: res 429 430 integer(8) :: idef, ires 431 432 call parse_check_varinfo(name) 433 434 idef = 0 435 if(def) idef = 1 436 437 call oct_parse_int(parse_get_full_name(namespace, name), idef, ires) 438 res = (ires /= 0) 439 440 end subroutine parse_logical 441 442 ! --------------------------------------------------------- 443 444 subroutine parse_cmplx(namespace, name, def, res) 445 type(namespace_t), intent(in) :: namespace 446 character(len=*), intent(in) :: name 447 complex(8), intent(in) :: def 448 complex(8), intent(out) :: res 449 450 call parse_check_varinfo(name) 451 call oct_parse_complex(parse_get_full_name(namespace, name), def, res) 452 453 end subroutine parse_cmplx 454 455 ! --------------------------------------------------------- 456 457 integer function parse_block(namespace, name, blk, check_varinfo_) 458 type(namespace_t), intent(in) :: namespace 459 character(len=*), intent(in) :: name 460 type(block_t), intent(out) :: blk 461 logical, optional, intent(in) :: check_varinfo_ 462 463 logical check_varinfo 464 465 check_varinfo = .true. 466 if(present(check_varinfo_)) check_varinfo = check_varinfo_ 467 468 if(check_varinfo) then 469 call parse_check_varinfo(name) 470 end if 471 parse_block = oct_parse_block(parse_get_full_name(namespace, name), blk) 472 473 end function parse_block 474 475 ! --------------------------------------------------------- 476 477 subroutine parse_block_logical(blk, l, c, res) 478 type(block_t), intent(in) :: blk 479 integer, intent(in) :: l, c 480 logical, intent(out) :: res 481 482 integer :: ires 483 484 call oct_parse_block_int(blk, l, c, ires) 485 res = (ires /= 0) 486 487 end subroutine parse_block_logical 488 489 !> The code may want to compile in single-precision mode. 490 !! As I did not want to change the parser library, these 491 !! driver functions just convert their arguments. 492 493 ! --------------------------------------------------------- 494 subroutine oct_parse_putsym_double4(sym, d4) 495 character(len=*), intent(in) :: sym 496 real(4), intent(in) :: d4 497 498 call oct_parse_putsym_double(sym, real(d4, 8)) 499 end subroutine oct_parse_putsym_double4 500 501 502 ! --------------------------------------------------------- 503 504 subroutine oct_parse_double4_unit(namespace, name, def4, res4, unit) 505 type(namespace_t), intent(in) :: namespace 506 character(len=*), intent(in) :: name 507 real(4), intent(in) :: def4 508 real(4), intent(out) :: res4 509 type(unit_t), optional, intent(in) :: unit 510 511 real(8) :: res8 512 513 call parse_check_varinfo(name) 514 515 if(present(unit)) then 516 call oct_parse_double(parse_get_full_name(namespace, name), units_from_atomic(unit, real(def4, 8)), res8) 517 res4 = real(units_to_atomic(unit, res8), kind=4) 518 else 519 call oct_parse_double(parse_get_full_name(namespace, name), real(def4, 8), res8) 520 res4 = real(res8, kind=4) 521 end if 522 523 end subroutine oct_parse_double4_unit 524 525 ! --------------------------------------------------------- 526 527 subroutine oct_parse_double8_unit(namespace, name, def, res, unit) 528 type(namespace_t), intent(in) :: namespace 529 character(len=*), intent(in) :: name 530 real(8), intent(in) :: def 531 real(8), intent(out) :: res 532 type(unit_t), optional, intent(in) :: unit 533 534 call parse_check_varinfo(name) 535 536 if(present(unit)) then 537 call oct_parse_double(parse_get_full_name(namespace, name), units_from_atomic(unit, def), res) 538 res = units_to_atomic(unit, res) 539 else 540 call oct_parse_double(parse_get_full_name(namespace, name), def, res) 541 end if 542 543 end subroutine oct_parse_double8_unit 544 545 ! --------------------------------------------------------- 546 subroutine oct_parse_block_double4(blk, l, c, res4) 547 type(block_t), intent(in) :: blk 548 integer, intent(in) :: l, c 549 real(4), intent(out) :: res4 550 551 real(8) :: res8 552 call oct_parse_block_double(blk, l, c, res8) 553 res4 = real(res8, kind=4) 554 end subroutine oct_parse_block_double4 555 556 ! --------------------------------------------------------- 557 558 subroutine oct_parse_block_double4_unit(blk, l, c, res4, unit) 559 type(block_t), intent(in) :: blk 560 integer, intent(in) :: l, c 561 real(4), intent(out) :: res4 562 type(unit_t), intent(in) :: unit 563 564 real(8) :: res8 565 call oct_parse_block_double(blk, l, c, res8) 566 res4 = real(units_to_atomic(unit, res8), kind=4) 567 end subroutine oct_parse_block_double4_unit 568 569 ! --------------------------------------------------------- 570 571 subroutine oct_parse_block_double8_unit(blk, l, c, res, unit) 572 type(block_t), intent(in) :: blk 573 integer, intent(in) :: l, c 574 real(8), intent(out) :: res 575 type(unit_t), intent(in) :: unit 576 577 call oct_parse_block_double(blk, l, c, res) 578 res = units_to_atomic(unit, res) 579 580 end subroutine oct_parse_block_double8_unit 581 582 ! --------------------------------------------------------- 583 subroutine oct_parse_block_complex4(blk, l, c, res4) 584 type(block_t), intent(in) :: blk 585 integer, intent(in) :: l, c 586 complex(4), intent(out) :: res4 587 588 complex(8) :: res8 589 call oct_parse_block_complex(blk, l, c, res8) 590 res4 = cmplx(res8, kind=4) 591 end subroutine oct_parse_block_complex4 592 593 ! --------------------------------------------------------- 594 subroutine oct_parse_expression_vec(re, im, ndim, x, r, t, pot) 595 real(8), intent(out) :: re, im 596 integer, intent(in) :: ndim 597 real(8), intent(in) :: x(:), r, t 598 character(len=*), intent(in) :: pot 599 600 real(8) :: xc(1:MAX_DIM) 601 602 xc = M_ZERO 603 xc(1:ndim) = x(1:ndim) 604 call oct_parse_expression(re, im, ndim, xc(1), r, t, pot) 605 end subroutine oct_parse_expression_vec 606 607 ! --------------------------------------------------------- 608 subroutine oct_parse_expression_vec4(re, im, ndim, x, r, t, pot) 609 real(4), intent(out) :: re, im 610 integer, intent(in) :: ndim 611 real(4), intent(in) :: x(:), r, t 612 character(len=*), intent(in) :: pot 613 614 real(8) :: xc(1:MAX_DIM) 615 real(8) :: re8, im8 616 617 xc = M_ZERO 618 xc(1:ndim) = real(x(1:ndim), 8) 619 call oct_parse_expression(re8, im8, ndim, xc(1), real(r, 8), real(t, 8), pot) 620 re = real(re8, 4) 621 im = real(im8, 4) 622 end subroutine oct_parse_expression_vec4 623 624 ! --------------------------------------------------------- 625 subroutine oct_parse_expression14(re, im, c, x, string) 626 real(4), intent(out) :: re, im 627 character(len=*), intent(in) :: c 628 real(4), intent(in) :: x 629 character(len=*), intent(in) :: string 630 real(8) :: re8, im8 631 call oct_parse_expression1(re8, im8, c, real(x, 8), string) 632 re = real(re8, 4) 633 im = real(im8, 4) 634 end subroutine oct_parse_expression14 635 636 637 ! ---------------------------------------------------------------------- 638 !> A very primitive way to "preprocess" a string that contains reference 639 !! to the elements of a two-dimensional array, substituting them with 640 !! the values of the array x. This way the string can be processed by 641 !! the parser later. 642 subroutine parse_array(inp_string, x, arraychar) 643 character(len=*), intent(inout) :: inp_string 644 FLOAT, intent(in) :: x(:, :) 645 character(len=1), intent(in) :: arraychar 646 integer :: i,m,n_atom,coord,string_length 647 character (LEN=100) :: v_string 648 649 string_length = len(inp_string) 650 do i = 1, string_length - 1 651 if(inp_string(i:i+1) == arraychar//"[") then 652 m = 0 653 if(inp_string(i+3:i+3) == ",") m = 1 654 if(inp_string(i+4:i+4) == ",") m = 2 655 if(m == 0) then 656 write(stderr, '(a)') "*** Fatal Error (description follows)" 657 write(stderr, '(a)') "Attempting to parse a string with array elements larger than 99" 658 call parse_fatal() 659 end if 660 read(inp_string(i+2:i+1+m),*) n_atom 661 read(inp_string(i+3+m:i+3+m),*) coord 662 write(v_string,*) x(n_atom, coord) 663 inp_string = inp_string(:i-1) // "(" // trim(v_string) // ")" // inp_string(i+5+m:) 664 end if 665 end do 666 667 end subroutine parse_array 668 669 ! ---------------------------------------------------------------------- 670 671 subroutine parse_check_varinfo(varname) 672 character(len=*), intent(in) :: varname 673 674 if(.not. varinfo_exists(varname)) then 675 write(stderr,'(a)') "*** Fatal Internal Error (description follows)" 676 write(stderr,'(a)') 'Attempting to parse undocumented variable '//trim(varname)//'.' 677 call parse_fatal() 678 end if 679 680 end subroutine parse_check_varinfo 681 682 683 ! this function returns the full name, possibly including the namespace 684 ! of the current parser 685 function parse_get_full_name(namespace, varname) result(full_name) 686 type(namespace_t), intent(in) :: namespace 687 character(len=*), intent(in) :: varname 688 character(len=:), allocatable :: full_name 689 690 ! try first the variable prefixed by namespace 691 full_name = trim(namespace%get()) // "." // trim(varname) 692 if (parse_isdef(full_name) == 0) then 693 full_name = varname 694 end if 695 end function parse_get_full_name 696 697 698 ! ---------------------------------------------------------------------- 699 subroutine parse_fatal() 700 701#ifdef HAVE_MPI 702 if(mpi_world%comm /= -1) call MPI_Abort(mpi_world%comm, 999, mpi_err) 703#endif 704 stop 705 706 end subroutine parse_fatal 707 708end module parser_oct_m 709 710!! Local Variables: 711!! mode: f90 712!! coding: utf-8 713!! End: 714