1!! Copyright (C) 2002-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 io_oct_m 22 use debug_oct_m 23 use global_oct_m 24 use loct_oct_m 25 use messages_oct_m 26 use mpi_oct_m 27 use namespace_oct_m 28 use parser_oct_m 29 30 implicit none 31 32 private 33 public :: & 34 io_workpath, & 35 io_open, & 36 io_mkdir, & 37 io_rm, & 38 io_init, & 39 io_end, & 40 io_status, & 41 io_dump_file, & 42 io_free, & 43 io_close, & 44 io_assign, & 45 io_get_extension, & 46 io_debug_on_the_fly, & 47 iopar_read, & 48 iopar_backspace, & 49 iopar_find_line, & 50 io_skip_header, & 51 io_file_exists, & 52 io_dir_exists, & 53 io_get_open_count, & 54 io_get_close_count, & 55 io_incr_open_count, & 56 io_incr_close_count, & 57 io_incr_counters 58 59 integer, parameter :: min_lun=10, max_lun=99 60 logical :: lun_is_free(min_lun:max_lun) 61 character(len=MAX_PATH_LEN) :: work_dir !< name of the output directory 62 integer(8), save :: io_open_count 63 integer(8), save :: io_close_count 64 65contains 66 67 ! --------------------------------------------------------- 68 !> If the argument defaults is present and set to true, then the routine 69 !! will not try to read anything from the inp file, but set everything 70 !! to the default values. 71 subroutine io_init(defaults) 72 logical, optional, intent(in) :: defaults 73 74 character(len=MAX_PATH_LEN) :: filename 75 character(len=256) :: node_hook 76 logical :: file_exists, mpi_debug_hook 77 integer :: sec, usec 78 79 io_open_count = 0 80 io_close_count = 0 81 82 ! cannot use push/pop before initializing io 83 84 if(present(defaults)) then 85 if(defaults) then 86 lun_is_free(min_lun:max_lun)=.true. 87 stdin = 5 88 stdout = 6 89 stderr = 0 90 work_dir = '.' 91 flush_messages = .false. 92 return 93 end if 94 end if 95 96 lun_is_free(min_lun:max_lun)=.true. 97 stdin = 5 98 99 !%Variable stdout 100 !%Type string 101 !%Default "-" 102 !%Section Execution::IO 103 !%Description 104 !% The standard output by default goes to, well, to standard output. This can 105 !% be changed by setting this variable: if you give it a name (other than "-") 106 !% the output stream is printed in that file instead. 107 !%End 108 call parse_variable(global_namespace, 'stdout', '-', filename) 109 stdout = 6 110 if(trim(filename) /= '-') then 111 close(stdout) 112 open(stdout, file=filename, status='unknown') 113 end if 114 115 !%Variable stderr 116 !%Type string 117 !%Default "-" 118 !%Section Execution::IO 119 !%Description 120 !% The standard error by default goes to, well, to standard error. This can 121 !% be changed by setting this variable: if you give it a name (other than "-") 122 !% the output stream is printed in that file instead. 123 !%End 124 call parse_variable(global_namespace, 'stderr', '-', filename) 125 stderr = 0 126 if(trim(filename) /= '-') then 127 close(stderr) 128 open(stderr, file=filename, status='unknown') 129 end if 130 131 !%Variable WorkDir 132 !%Type string 133 !%Default "." 134 !%Section Execution::IO 135 !%Description 136 !% By default, all files are written and read from the working directory, 137 !% <i>i.e.</i> the directory from which the executable was launched. This behavior can 138 !% be changed by setting this variable. If you set <tt>WorkDir</tt> to a name other than ".", 139 !% the following directories are written and read in that directory: 140 !%<ul> 141 !% <li>"casida/"</li> 142 !% <li>"em_resp_fd/"</li> 143 !% <li>"em_resp/"</li> 144 !% <li>"geom/"</li> 145 !% <li>"kdotp/"</li> 146 !% <li>"local.general"</li> 147 !% <li>"pcm/"</li> 148 !% <li>"profiling/"</li> 149 !% <li>"restart/"</li> 150 !% <li>"static/"</li> 151 !% <li>"td.general/"</li> 152 !% <li>"vdw/"</li> 153 !% <li>"vib_modes/"</li> 154 !%</ul> 155 !% Furthermore, some of the debug information (see <tt>Debug</tt>) is also written to <tt>WorkDir</tt> and 156 !% the non-absolute paths defined in <tt>OutputIterDir</tt> are relative to <tt>WorkDir</tt>. 157 !%End 158 call parse_variable(global_namespace, 'WorkDir', '.', work_dir) 159 ! ... and if necessary create workdir (will not harm if work_dir is already there) 160 if (work_dir /= '.') call loct_mkdir(trim(work_dir)) 161 162 !%Variable FlushMessages 163 !%Type logical 164 !%Default no 165 !%Section Execution::IO 166 !%Description 167 !% In addition to writing to stdout and stderr, the code messages may also be 168 !% flushed to <tt>messages.stdout</tt> and <tt>messages.stderr</tt>, if this variable is 169 !% set to yes. 170 !%End 171 call parse_variable(global_namespace, 'FlushMessages', .false., flush_messages) 172 173 ! delete files so that we start writing to empty ones 174 if(flush_messages) then 175 call loct_rm('messages.stdout') 176 call loct_rm('messages.stderr') 177 end if 178 179 if(debug%info) then 180 call io_mkdir('debug', global_namespace) 181 end if 182 183 if(debug%trace_file) then 184 !wipe out debug trace files from previous runs to start fresh rather than appending 185 call delete_debug_trace() 186 end if 187 188 if(debug%info) then 189 !%Variable MPIDebugHook 190 !%Type logical 191 !%Default no 192 !%Section Execution::Debug 193 !%Description 194 !% When debugging the code in parallel it is usually difficult to find the origin 195 !% of race conditions that appear in MPI communications. This variable introduces 196 !% a facility to control separate MPI processes. If set to yes, all nodes will 197 !% start up, but will get trapped in an endless loop. In every cycle of the loop 198 !% each node is sleeping for one second and is then checking if a file with the 199 !% name <tt>node_hook.xxx</tt> (where <tt>xxx</tt> denotes the node number) exists. A given node can 200 !% only be released from the loop if the corresponding file is created. This allows 201 !% to selectively run, <i>e.g.</i>, a compute node first followed by the master node. Or, by 202 !% reversing the file creation of the node hooks, to run the master first followed 203 !% by a compute node. 204 !%End 205 call parse_variable(global_namespace, 'MPIDebugHook', .false., mpi_debug_hook) 206 if (mpi_debug_hook) then 207 call loct_gettimeofday(sec, usec) 208 call epoch_time_diff(sec,usec) 209 write(message(1),'(a,i6,a,i6.6,20x,a)') '* I ',sec,'.',usec,' | MPI debug hook' 210 call messages_debug(1) 211 212 write(stdout,'(a,i3,a)') 'node:', mpi_world%rank, ' In debug hook' 213 write(node_hook,'(i3.3)') mpi_world%rank 214 file_exists = .false. 215 216 do while (.not.file_exists) 217 inquire(file='node_hook.'//node_hook, exist=file_exists) 218 call loct_nanosleep(1,0) 219 write(stdout,'(a,i3,a)') 'node:', mpi_world%rank, & 220 ' - still sleeping. To release me touch: node_hook.'//trim(node_hook) 221 end do 222 223 write(stdout,'(a,i3,a)') 'node:', mpi_world%rank, ' Leaving debug hook' 224 ! remove possible debug hooks 225 call loct_rm( 'node_hook.'//trim(node_hook) ) 226 227 call loct_gettimeofday(sec, usec) 228 call epoch_time_diff(sec,usec) 229 write(message(1),'(a,i6,a,i6.6,20x,a)') '* O ', sec, '.', usec,' | MPI debug hook' 230 call messages_debug(1) 231 end if 232 end if 233 234 end subroutine io_init 235 236 ! --------------------------------------------------------- 237 subroutine io_end() 238 239 ! no PUSH/POP, because the POP would write to stderr after it was closed. 240 241 if(stderr /= 0) call io_close(stderr) 242 if(stdin /= 5) call io_close(stdin) 243 if(stdout /= 6) call io_close(stdout) 244 245 end subroutine io_end 246 247 248 ! --------------------------------------------------------- 249 subroutine io_assign(got_lun) 250 integer, intent(out) :: got_lun 251 252 integer :: iostat, lun 253 logical :: used 254 255 PUSH_SUB(io_assign) 256 257 got_lun = -1 258 259 ! Looks for a free unit and assigns it to lun 260 do lun = min_lun, max_lun 261 if (lun_is_free(lun)) then 262 inquire(unit=lun, opened=used, iostat=iostat) 263 264 if (iostat /= 0) used = .true. 265 lun_is_free(lun) = .false. 266 if (.not. used) then 267 got_lun = lun 268 exit 269 end if 270 end if 271 end do 272 273 POP_SUB(io_assign) 274 end subroutine io_assign 275 276 277 ! --------------------------------------------------------- 278 subroutine io_free(lun) 279 integer, intent(in) :: lun 280 281 PUSH_SUB(io_free) 282 283 if (lun >= min_lun .and. lun <= max_lun) & 284 lun_is_free(lun) = .true. 285 286 POP_SUB(io_free) 287 end subroutine io_free 288 289 290 ! --------------------------------------------------------- 291 character(len=MAX_PATH_LEN) function io_workpath(path, namespace) result(wpath) 292 character(len=*), intent(in) :: path 293 type(namespace_t), optional, intent(in) :: namespace 294 295 logical :: absolute_path 296 integer :: total_len 297 298 PUSH_SUB(io_workpath) 299 300 ! use the logical to avoid problems with the string length 301 absolute_path = .false. 302 if (len_trim(path) > 0) then 303 absolute_path = path(1:1) == '/' 304 end if 305 306 ! check that the path is not longer than the maximum allowed 307 total_len = len_trim(path) 308 if (.not. absolute_path) then 309 total_len = total_len + len_trim(work_dir) + 1 310 if (present(namespace)) then 311 if (namespace%len() > 0) total_len = total_len + namespace%len() + 1 312 end if 313 end if 314 if (total_len > MAX_PATH_LEN) then 315 write(message(1),"(A,I5)") "Path is longer than the maximum path length of ", MAX_PATH_LEN 316 call messages_fatal(1, namespace=namespace) 317 end if 318 319 if (absolute_path) then 320 ! we do not change absolute path names 321 wpath = trim(path) 322 else 323 wpath = trim(work_dir) 324 if (present(namespace)) then 325 ! insert namespace into path 326 if (namespace%len() > 0) wpath = trim(wpath) + "/" + trim(namespace%get('/')) 327 end if 328 wpath = trim(wpath) + "/" + trim(path) 329 end if 330 331 POP_SUB(io_workpath) 332 end function io_workpath 333 334 335 ! --------------------------------------------------------- 336 subroutine io_mkdir(fname, namespace, parents) 337 character(len=*), intent(in) :: fname 338 type(namespace_t), optional, intent(in) :: namespace 339 logical, optional, intent(in) :: parents 340 341 logical :: parents_ 342 integer :: last_slash, pos, length 343 344 PUSH_SUB(io_mkdir) 345 346 parents_ = .false. 347 if (present(parents)) parents_ = parents 348 349 if (.not. parents_) then 350 call loct_mkdir(trim(io_workpath("", namespace=namespace))) 351 call loct_mkdir(trim(io_workpath(fname, namespace=namespace))) 352 else 353 last_slash = max(index(fname, "/", .true.), len_trim(fname)) 354 pos = 1 355 length = index(fname, '/') - 1 356 do while (pos < last_slash) 357 call loct_mkdir(trim(io_workpath(fname(1:pos+length-1), namespace=namespace))) 358 pos = pos + length + 1 359 length = index(fname(pos:), "/") - 1 360 if (length < 1) length = len_trim(fname(pos:)) 361 end do 362 363 end if 364 365 POP_SUB(io_mkdir) 366 end subroutine io_mkdir 367 368 369 ! --------------------------------------------------------- 370 subroutine io_rm(fname, namespace) 371 character(len=*), intent(in) :: fname 372 type(namespace_t), optional, intent(in) :: namespace 373 374 PUSH_SUB(io_rm) 375 376 call loct_rm(trim(io_workpath(fname, namespace=namespace))) 377 378 POP_SUB(io_rm) 379 end subroutine io_rm 380 381 382 ! --------------------------------------------------------- 383 integer function io_open(file, namespace, action, status, form, position, die, recl, grp) result(iunit) 384 character(len=*), intent(in) :: file, action 385 type(namespace_t),intent(in), optional :: namespace 386 character(len=*), intent(in), optional :: status, form, position 387 logical, intent(in), optional :: die 388 integer, intent(in), optional :: recl 389 type(mpi_grp_t), intent(in), optional :: grp 390 391 character(len=20) :: status_, form_, position_ 392 character(len=MAX_PATH_LEN) :: file_ 393 logical :: die_ 394 integer :: iostat 395 type(mpi_grp_t) :: grp_ 396 397 PUSH_SUB(io_open) 398 399 if(present(grp)) then 400 grp_%comm = grp%comm 401 grp_%rank = grp%rank 402 grp_%size = grp%size 403 else 404 call mpi_grp_init(grp_, -1) 405 end if 406 407 408 if(mpi_grp_is_root(grp_)) then 409 410 status_ = 'unknown' 411 if(present(status )) status_ = status 412 form_ = 'formatted' 413 if(present(form )) form_ = form 414 position_ = 'asis' 415 if(present(position)) position_ = position 416 die_ = .true. 417 if(present(die )) die_ = die 418 419 call io_assign(iunit) 420 if(iunit<0) then 421 if(die_) then 422 write(message(1), '(a)') '*** IO Error: Too many files open.' 423 call messages_fatal(1) 424 end if 425 POP_SUB(io_open) 426 return 427 end if 428 429 file_ = io_workpath(file, namespace=namespace) 430 431 if(present(recl)) then 432 open(unit=iunit, file=trim(file_), status=trim(status_), form=trim(form_), & 433 recl=recl, action=trim(action), position=trim(position_), iostat=iostat) 434 else 435 open(unit=iunit, file=trim(file_), status=trim(status_), form=trim(form_), & 436 action=trim(action), position=trim(position_), iostat=iostat) 437 end if 438 439 io_open_count = io_open_count + 1 440 441 if(iostat /= 0) then 442 call io_free(iunit) 443 iunit = -1 444 if(die_) then 445 write(message(1), '(5a,i6)') '*** IO Error: Could not open file "', trim(file_), & 446 '" for action="', trim(action), '". Error code = ', iostat 447 call messages_fatal(1) 448 end if 449 end if 450 451 end if 452 453#if defined(HAVE_MPI) 454 if(grp_%size > 1) then 455 call MPI_Bcast(iunit, 1, MPI_INTEGER, 0, grp_%comm, mpi_err) 456 end if 457#endif 458 459 POP_SUB(io_open) 460 end function io_open 461 462 463 ! --------------------------------------------------------- 464 subroutine io_close(iunit, grp) 465 integer, intent(inout) :: iunit 466 type(mpi_grp_t), intent(in), optional :: grp 467 468 type(mpi_grp_t) :: grp_ 469 470 PUSH_SUB(io_close) 471 472 if(present(grp)) then 473 grp_%comm = grp%comm 474 grp_%rank = grp%rank 475 grp_%size = grp%size 476 else 477 call mpi_grp_init(grp_, -1) 478 end if 479 480 if(mpi_grp_is_root(grp_)) then 481 close(iunit) 482 io_close_count = io_close_count + 1 483 call io_free(iunit) 484 iunit = -1 485 end if 486 487#if defined(HAVE_MPI) 488 if(grp_%size > 1) then 489 call MPI_Bcast(iunit, 1, MPI_INTEGER, 0, grp_%comm, mpi_err) 490 end if 491#endif 492 493 POP_SUB(io_close) 494 end subroutine io_close 495 496 497 ! --------------------------------------------------------- 498 !> Prints a list of the connected logical units and the names of 499 !! the associated files 500 ! --------------------------------------------------------- 501 subroutine io_status(iunit) 502 integer, intent(in) :: iunit 503 504 integer :: ii, iostat 505 logical :: opened, named 506 character(len=MAX_PATH_LEN) :: filename 507 character(len=11) :: form 508 509 PUSH_SUB(io_status) 510 511 write(iunit, '(a)') '******** io_status ********' 512 do ii = 0, max_lun 513 inquire(ii, opened=opened, named=named, name=filename, form=form, iostat=iostat) 514 if (iostat == 0) then 515 if (opened) then 516 if(.not. named) filename = 'No name available' 517 write(iunit, '(i4,5x,a,5x,a)') ii, form, filename 518 end if 519 else 520 write(iunit, '(i4,5x,a)') ii, 'Iostat error' 521 end if 522 end do 523 write(iunit,'(a)') '******** ********' 524 525 POP_SUB(io_status) 526 end subroutine io_status 527 528 529 ! --------------------------------------------------------- 530 subroutine io_dump_file(ounit, filename) 531 integer, intent(in) :: ounit 532 character(len=*), intent(in) :: filename 533 534 integer :: iunit, err 535 character(len=80) :: line 536 537 if(.not. mpi_grp_is_root(mpi_world)) return 538 539 PUSH_SUB(io_dump_file) 540 541 call io_assign(iunit) 542 open(unit=iunit, file=filename, iostat=err, action='read', status='old') 543 544 if(flush_messages) then 545 open(unit=iunit_out, file='messages.stdout', & 546 action='write', position='append') 547 end if 548 549 do while(err == 0) 550 read(iunit, fmt='(a80)', iostat=err) line 551 if(err==0) then 552 write(ounit, '(a)') trim(line) 553 if(flush_messages) then 554 write(iunit_out, '(a)') trim(line) 555 end if 556 end if 557 end do 558 559 if(flush_messages) then 560 close(iunit_out) 561 end if 562 563 call io_close(iunit) 564 565 POP_SUB(io_dump_file) 566 end subroutine io_dump_file 567 568 569 ! --------------------------------------------------------- 570 !> Given a path, it returns the extension (if it exists) of the file 571 !! (that is, the part of the name that comes after its last point). 572 !! If the filename does not have an extension, it returns the empty string. 573 character(len=8) function io_get_extension(path) result(ext) 574 character(len = * ), intent(in) :: path 575 integer :: i, j 576 577 PUSH_SUB(io_get_extension) 578 579 i = index(path, ".", back = .true.) 580 j = index(path(i+1:), "/") 581 if(i == 0 .or. j /= 0) then 582 ext = "" 583 else 584 ext = path(i+1:) 585 end if 586 587 POP_SUB(io_get_extension) 588 end function io_get_extension 589 590 591 ! --------------------------------------------------------- 592 !> check if debug mode or message flushing should be enabled or 593 !! disabled on the fly 594 subroutine io_debug_on_the_fly(namespace) 595 type(namespace_t), intent(in) :: namespace 596 597 PUSH_SUB(io_debug_on_the_fly) 598 599 ! only root node performs the check 600 if(mpi_grp_is_root(mpi_world)) then 601 if(io_file_exists('enable_debug_mode', msg='Enabling DebugMode')) then 602 call debug_enable(debug) 603 ! this call does not hurt if the directory is already there 604 ! but is otherwise required 605 call io_mkdir('debug', namespace) 606 ! we have been notified by the user, so we can cleanup the file 607 call loct_rm('enable_debug_mode') 608 ! artificially increase sub stack to avoid underflow 609 no_sub_stack = no_sub_stack + 8 610 end if 611 612 if(io_file_exists('enable_flush_messages', msg='Enabling flushing of messages')) then 613 flush_messages = .true. 614 ! we have been notified by the user, so we can cleanup the file 615 call loct_rm('enable_flush_messages') 616 end if 617 618 if(io_file_exists('disable_debug_mode', msg='Disabling DebugMode')) then 619 call debug_disable(debug) 620 ! we have been notified by the user, so we can cleanup the file 621 call loct_rm('disable_debug_mode') 622 end if 623 624 if(io_file_exists('disable_flush_messages', msg='Disabling flushing of messages')) then 625 flush_messages = .false. 626 ! we have been notified by the user, so we can cleanup the file 627 call loct_rm('disable_flush_messages') 628 end if 629 end if 630 631 POP_SUB(io_debug_on_the_fly) 632 end subroutine io_debug_on_the_fly 633 634 635 !> Returns true if a file with name 'filename' exists 636 !! and issues a reminder. 637 ! --------------------------------------------------------- 638 logical function io_file_exists(filename, msg) result(file_exists) 639 character(len=*), intent(in) :: filename 640 character(len=*), optional, intent(in) :: msg 641 642 PUSH_SUB(io_file_exists) 643 644 file_exists = .false. 645 inquire(file=trim(filename), exist=file_exists) 646 if(file_exists .and. present(msg)) then 647 message(1) = trim(msg) 648 call messages_warning(1) 649 end if 650 651 POP_SUB(io_file_exists) 652 end function io_file_exists 653 654 !> Returns true if a dir with name 'dir' exists 655 ! --------------------------------------------------------- 656 logical function io_dir_exists(dir, namespace) 657 character(len=*), intent(in) :: dir 658 type(namespace_t), intent(in) :: namespace 659 660 PUSH_SUB(io_dir_exists) 661 662 io_dir_exists = loct_dir_exists(trim(io_workpath(dir, namespace))) 663 664 POP_SUB(io_dir_exists) 665 end function io_dir_exists 666 667 ! --------------------------------------------------------- 668 subroutine iopar_read(grp, iunit, lines, n_lines, ierr) 669 type(mpi_grp_t), intent(in) :: grp 670 integer, intent(in) :: iunit 671 character(len=*), intent(out) :: lines(:) 672 integer, intent(in) :: n_lines 673 integer, intent(out) :: ierr 674 675 integer :: il 676 677 PUSH_SUB(iopar_read) 678 679 ASSERT(n_lines <= size(lines)) 680 681 if(mpi_grp_is_root(grp)) then 682 do il = 1, n_lines 683 read(iunit, '(a)', iostat=ierr) lines(il) 684 if (ierr /= 0) exit 685 end do 686 end if 687 688#if defined(HAVE_MPI) 689 if(grp%size > 1) then 690 call MPI_Bcast(ierr, 1, MPI_INTEGER, 0, grp%comm, mpi_err) 691 call MPI_Bcast(lines(1), len(lines(1))*n_lines, MPI_CHARACTER, 0, grp%comm, mpi_err) 692 ! MPI_Bcast is not a synchronization point, this can cause 693 ! problems when iopar_read is called several times (in a loop, 694 ! for example). So we add a barrier to make sure the calls are properly synchronized. 695 call MPI_Barrier(grp%comm, mpi_err) 696 end if 697#endif 698 699 POP_SUB(iopar_read) 700 end subroutine iopar_read 701 702 ! --------------------------------------------------------- 703 subroutine iopar_backspace(grp, iunit) 704 type(mpi_grp_t), intent(in) :: grp 705 integer, intent(in) :: iunit 706 707 PUSH_SUB(iopar_backspace) 708 709 if(mpi_grp_is_root(grp)) then 710 backspace(iunit) 711 end if 712 713 POP_SUB(iopar_backspace) 714 end subroutine iopar_backspace 715 716 717 ! --------------------------------------------------------- 718 subroutine iopar_find_line(grp, iunit, line, ierr) 719 type(mpi_grp_t), intent(in) :: grp 720 integer, intent(in) :: iunit 721 character(len=*), intent(in) :: line 722 integer, intent(out) :: ierr 723 724 character(len=80) :: read_line 725 726 PUSH_SUB(io_find_line) 727 728 if(mpi_grp_is_root(grp)) then 729 rewind(iunit) 730 do 731 read(iunit, '(a)', iostat=ierr) read_line 732 if (ierr /= 0 .or. trim(line) == trim(read_line)) exit 733 end do 734 end if 735 736#if defined(HAVE_MPI) 737 if(grp%size > 1) then 738 call MPI_Bcast(ierr, 1, MPI_INTEGER, 0, grp%comm, mpi_err) 739 ! MPI_Bcast is not a synchronization point, so we add a barrier 740 ! to make sure the calls are properly synchronized. 741 call MPI_Barrier(grp%comm, mpi_err) 742 end if 743#endif 744 745 POP_SUB(io_find_line) 746 end subroutine iopar_find_line 747 748 749 ! --------------------------------------------------------- 750 subroutine io_skip_header(iunit) 751 integer, intent(in) :: iunit 752 753 character(len=1) :: a 754 755 PUSH_SUB(io_skip_header) 756 757 rewind(iunit) 758 read(iunit,'(a)') a 759 do while(a=='#') 760 read(iunit,'(a)') a 761 end do 762 backspace(iunit) 763 764 POP_SUB(io_skip_header) 765 end subroutine io_skip_header 766 767 ! --------------------------------------------------------- 768 integer(8) pure function io_get_open_count() result(count) 769 770 count = io_open_count 771 772 end function io_get_open_count 773 774 ! --------------------------------------------------------- 775 integer(8) pure function io_get_close_count() result(count) 776 777 count = io_close_count 778 779 end function io_get_close_count 780 781 ! --------------------------------------------------------- 782 subroutine io_incr_open_count() 783 784 io_open_count = io_open_count + 1 785 786 end subroutine io_incr_open_count 787 788 ! --------------------------------------------------------- 789 subroutine io_incr_close_count() 790 791 io_close_count = io_close_count + 1 792 793 end subroutine io_incr_close_count 794 795 ! --------------------------------------------------------- 796 subroutine io_incr_counters(iio) 797 integer, intent(in) :: iio 798 799 integer :: open_count 800 801 open_count = int(iio/100) 802 io_open_count = io_open_count + open_count 803 io_close_count = io_close_count + iio - open_count * 100 804 805 end subroutine io_incr_counters 806 807end module io_oct_m 808 809!! Local Variables: 810!! mode: f90 811!! coding: utf-8 812!! End: 813