Line data Source code
1 : !!****m* ABINIT/m_io_tools
2 : !! NAME
3 : !! m_io_tools
4 : !!
5 : !! FUNCTION
6 : !! This module provides basic tools to deal with Fortran IO.
7 : !!
8 : !! COPYRIGHT
9 : !! Copyright (C) 2008-2026 ABINIT group (MG)
10 : !! This file is distributed under the terms of the
11 : !! GNU General Public License, see ~abinit/COPYING
12 : !! or http://www.gnu.org/copyleft/gpl.txt .
13 : !!
14 : !! SOURCE
15 :
16 : #if defined HAVE_CONFIG_H
17 : #include "config.h"
18 : #endif
19 :
20 : #include "abi_common.h"
21 :
22 : module m_io_tools
23 :
24 : use, intrinsic :: iso_c_binding
25 : use defs_basis
26 : use m_clib
27 :
28 : implicit none
29 :
30 : private
31 :
32 : public :: get_unit ! Get a free unit if no argument is specified or report the unit associated to a file name
33 : public :: file_exists ! Return .TRUE. if file exists.
34 : public :: delete_file ! Delete a file if present.
35 : public :: is_open ! .TRUE. if file is open
36 : public :: is_connected ! .TRUE. if file is connected to a logical unit number
37 : public :: prompt ! Simple prompt
38 : public :: read_string ! Read string from unit ignoring blank lines and deleting comments beginning with ! or #
39 : public :: flush_unit ! Wrapper to the intrinsic flush routine, not implemented by every compiler
40 : public :: pick_aname ! Returns the name of a non-existent file to be used for temporary storage.
41 : public :: isncfile ! .TRUE. if we have a NETCDF file.
42 : public :: iomode_from_fname ! Automatic selection of the IO mode based on the file extension.
43 : public :: iomode2str ! Convert iomode to string
44 : public :: enforce_fortran_io ! Set the value of enforce_fortran_io__
45 : public :: mvrecord ! Moves forward or backward in a Fortran binary file by nn records.
46 : public :: open_file ! Helper function to open a file in sequential mode with improved error handling.
47 : public :: close_unit ! Helper function to close a Fortran unit with improved error handling.
48 : public :: write_lines ! split a string in lines and output the text to the specified unit
49 : public :: lock_and_write ! Write a string to a file with locking mechanism.
50 : public :: num_opened_units ! Return the number of opened units.
51 : public :: show_units ! Print info on the logical units.
52 : public :: write_units ! Write `string` to a list of Fortran `units`.
53 :
54 : interface get_unit
55 : module procedure get_free_unit
56 : module procedure get_unit_from_fname
57 : end interface
58 :
59 : interface is_open
60 : module procedure is_open_unit
61 : module procedure is_open_fname
62 : end interface
63 :
64 : interface prompt
65 : module procedure prompt_int0D
66 : module procedure prompt_rdp0D
67 : module procedure prompt_string
68 : module procedure prompt_int1D
69 : module procedure prompt_int2D
70 : module procedure prompt_rdp1D
71 : module procedure prompt_rdp2D
72 : end interface
73 :
74 : integer,parameter :: MIN_UNIT_NUMBER=10 ! Fortran does not define the range for logical unit numbers (they not be negative)
75 :
76 : #ifdef FC_NAG
77 : integer,parameter :: MAX_UNIT_NUMBER=64 ! There's a serious problem in Nag6.0.
78 : ! In principle, Maximum unit number: 2147483647
79 : #else
80 : integer,parameter :: MAX_UNIT_NUMBER=1024 ! The following values should be safe
81 : #endif
82 :
83 : integer,parameter :: IO_MAX_LEN=500
84 : character(len=1),parameter :: BLANK=' '
85 :
86 : ! For interactive sessions
87 : integer,parameter :: IO_EOT=-1 ! End of transmission i.e CTRL+D
88 : character(len=4),parameter :: PS1 = '->> '
89 : character(len=4),parameter :: PS2 = '??? '
90 :
91 : integer,parameter :: IO_NO_AVAILABLE_UNIT =-1 ! No units available for Fortran I/O
92 : integer,parameter :: IO_FILE_NOT_ASSOCIATED=-2 ! File is not associated with any unit.
93 :
94 : ! Enforce IO_MODE_FORTRAN in iomode_from_fname
95 : logical,save,protected :: enforce_fortran_io__ = .False.
96 :
97 : contains !===========================================================
98 : !!***
99 :
100 : !!****f* m_io_tools/get_unit
101 : !! NAME
102 : !! get_unit
103 : !!
104 : !! FUNCTION
105 : !! Obtain a logical Fortran unit. A free unit is reported if no argument is specified.
106 : !! If the file name is supplied, the function reports the unit number associated to the file
107 : !! Note that GET_UNIT assumes that units 0, 5, 6 (stderr, stdin, std_out)
108 : !! are special, and will never return those values.
109 : !!
110 : !! TODO
111 : !! One should define an abinit-specific function with a list of reserved units!
112 : !!
113 : !! OUTPUT
114 : !! The unit number (free unit or unit associated to the file)
115 : !! Raises:
116 : !! IO_NO_AVAILABLE_UNIT if no logical unit is free (!)
117 : !! IO_FILE_NOT_ASSOCIATED if the file is not linked to a logical unit
118 : !!
119 : !! SOURCE
120 :
121 37595 : integer function get_free_unit()
122 :
123 : !Local variables-------------------------------
124 : integer :: iunt
125 : logical :: isopen
126 : ! *********************************************************************
127 :
128 40265 : do iunt=MAX_UNIT_NUMBER,MIN_UNIT_NUMBER,-1
129 40265 : if (any(iunt == [std_err, std_in, std_out])) cycle
130 40237 : inquire(unit=iunt, opened=isopen)
131 40237 : if (.not.isopen) then
132 : get_free_unit = iunt; return
133 : end if
134 : end do
135 : get_free_unit = IO_NO_AVAILABLE_UNIT
136 :
137 : end function get_free_unit
138 : !!***
139 :
140 : !----------------------------------------------------------------------
141 :
142 : !!****f* m_io_tools/get_unit_from_fname
143 : !! NAME
144 : !! get_unit_from_fname
145 : !!
146 : !! FUNCTION
147 : !! Returns the unit number associated to an open file whose name is fname.
148 : !! If the file is not connected to an unit number, returns IO_FILE_NOT_ASSOCIATED
149 : !!
150 : !! SOURCE
151 :
152 0 : integer function get_unit_from_fname(fname)
153 :
154 : !Arguments ------------------------------------
155 : character(len=*),intent(in) :: fname
156 :
157 : !Local variables-------------------------------
158 : integer :: unit
159 : ! *********************************************************************
160 :
161 0 : inquire(file=fname,number=unit)
162 :
163 0 : get_unit_from_fname=unit
164 0 : if (unit==-1) get_unit_from_fname=IO_FILE_NOT_ASSOCIATED
165 :
166 0 : end function get_unit_from_fname
167 : !!***
168 :
169 : !----------------------------------------------------------------------
170 :
171 : !!****f* m_io_tools/file_exists
172 : !! NAME
173 : !! file_exists
174 : !!
175 : !! FUNCTION
176 : !! Return .TRUE. if file `filepath` exists (function version of inquire).
177 : !!
178 : !! SOURCE
179 :
180 80303 : logical function file_exists(filepath)
181 :
182 : character(len=*),intent(in) :: filepath
183 : ! *********************************************************************
184 :
185 80303 : inquire(file=filepath, exist=file_exists)
186 :
187 80303 : end function file_exists
188 : !!***
189 :
190 : !----------------------------------------------------------------------
191 :
192 : !!****f* m_io_tools/delete_file
193 : !! NAME
194 : !! delete_file
195 : !!
196 : !! FUNCTION
197 : !! Delete a file if present.
198 : !!
199 : !! INPUTS
200 : !! fname=The name of the file.
201 : !!
202 : !! OUTPUT
203 : !! ierr=Non-zero value indicates that a problem occured.
204 : !! 111 = To signal that the file does not exist.
205 : !! 112 = File exist, is open but no associated unit is found!
206 : !! Other values are system-dependent as the value is returned by a open or close instruction.
207 : !!
208 : !! SOURCE
209 :
210 2594 : subroutine delete_file(fname, ierr)
211 :
212 : integer,intent(out) :: ierr
213 : character(len=*),intent(in) :: fname
214 :
215 : !Local variables-------------------------------
216 : integer :: tmp_unt
217 : logical :: exists
218 : ! *********************************************************************
219 :
220 2594 : ierr = 0
221 :
222 2594 : inquire(file=fname, exist=exists)
223 :
224 2594 : if (.not.exists) then
225 1415 : ierr = 111
226 : !write(std_out,*)" Asked to delete non existent file: ",TRIM(fname)
227 1415 : return
228 : end if
229 :
230 1179 : if (is_open_fname(fname)) then
231 0 : tmp_unt = get_unit_from_fname(fname)
232 0 : if (tmp_unt == IO_FILE_NOT_ASSOCIATED) then
233 : !write(std_out,*) "File is opened but no associated unit found!"
234 0 : ierr = 112; return
235 : end if
236 0 : close(tmp_unt)
237 : else
238 1179 : tmp_unt = get_unit()
239 : end if
240 :
241 : ! Now close the file.
242 1179 : open(unit=tmp_unt, file=trim(fname), status="OLD", iostat=ierr)
243 1179 : if (ierr==0) close(unit=tmp_unt, status="DELETE", iostat=ierr)
244 :
245 : end subroutine delete_file
246 : !!***
247 :
248 : !----------------------------------------------------------------------
249 :
250 : !!****f* m_io_tools/is_connected
251 : !! NAME
252 : !! is_connected
253 : !!
254 : !! FUNCTION
255 : !! Returns .TRUE. if unit is connected to fname.
256 : !!
257 : !! SOURCE
258 :
259 0 : logical function is_connected(unit, fname)
260 :
261 : integer,intent(in) :: unit
262 : character(len=*),intent(in) :: fname
263 :
264 : !Local variables-------------------------------
265 : integer :: unt_found
266 : logical :: isopen
267 : ! *********************************************************************
268 :
269 0 : inquire(file=fname, number=unt_found, opened=isopen)
270 0 : is_connected=(isopen .and. (unt_found == unit))
271 :
272 0 : end function is_connected
273 : !!***
274 :
275 : !----------------------------------------------------------------------
276 :
277 : !!****f* m_io_tools/is_open
278 : !! NAME
279 : !! is_open
280 : !!
281 : !! FUNCTION
282 : !! Returns .TRUE. if unit is associated to an open file.
283 : !!
284 : !! SOURCE
285 :
286 27016 : logical function is_open_unit(unit)
287 :
288 : integer,intent(in) :: unit
289 : ! *********************************************************************
290 :
291 27016 : inquire(unit=unit, opened=is_open_unit)
292 :
293 27016 : end function is_open_unit
294 : !!***
295 :
296 : !----------------------------------------------------------------------
297 :
298 : !!****f* m_io_tools/is_open_fname
299 : !! NAME
300 : !! is_open_fname
301 : !!
302 : !! FUNCTION
303 : !! Returns .TRUE. if the file name fname is open.
304 : !!
305 : !! SOURCE
306 :
307 1179 : logical function is_open_fname(fname)
308 :
309 : character(len=*),intent(in) :: fname
310 : ! *********************************************************************
311 :
312 1179 : inquire(file=fname,opened=is_open_fname)
313 :
314 1179 : end function is_open_fname
315 : !!***
316 :
317 : !----------------------------------------------------------------------
318 :
319 : !!****f* m_io_tools/prompt_int0D
320 : !! NAME
321 : !! prompt_int0D
322 : !!
323 : !! FUNCTION
324 : !! A primitive prompt. Writes msg on std_out and reads the value entered by the user.
325 : !!
326 : !! SOURCE
327 :
328 26 : subroutine prompt_int0D(msg,ivalue)
329 :
330 : character(len=*),intent(in) :: msg
331 : integer,intent(out) :: ivalue
332 :
333 : !Local variables-------------------------------
334 : integer :: ios
335 : character(len=4) :: PS
336 : ! *********************************************************************
337 :
338 26 : ios=-1 ; PS=PS1
339 52 : do while (ios/=0)
340 26 : write(std_out,'(a)',ADVANCE='NO')PS//TRIM(msg)//BLANK
341 26 : call flush_unit(std_out)
342 26 : read(std_in,*,IOSTAT=ios)ivalue
343 26 : if (ios==IO_EOT) call prompt_exit()
344 26 : PS=PS2
345 : end do
346 26 : write(std_out,*)
347 :
348 26 : end subroutine prompt_int0D
349 : !!***
350 :
351 : !----------------------------------------------------------------------
352 :
353 : !!****f* m_io_tools/prompt_rdp0d
354 : !! NAME
355 : !! prompt_rdp0d
356 : !!
357 : !! FUNCTION
358 : !! A primitive prompt. Writes msg on std_out and reads the value entered by the user.
359 : !!
360 : !! SOURCE
361 :
362 0 : subroutine prompt_rdp0D(msg,rvalue)
363 :
364 : character(len=*),intent(in) :: msg
365 : real(dp),intent(out) :: rvalue
366 :
367 : !Local variables-------------------------------
368 : integer :: ios
369 : character(len=4) :: PS
370 : ! *********************************************************************
371 :
372 0 : ios=-1 ; PS=PS1
373 0 : do while (ios/=0)
374 0 : write(std_out,'(a)',ADVANCE='NO')PS//TRIM(msg)//BLANK
375 0 : call flush_unit(std_out)
376 0 : read(std_in,*,IOSTAT=ios)rvalue
377 0 : if (ios==IO_EOT) call prompt_exit()
378 0 : PS=PS2
379 : end do
380 0 : write(std_out,*)
381 :
382 0 : end subroutine prompt_rdp0D
383 : !!***
384 :
385 : !----------------------------------------------------------------------
386 :
387 : !!****f* m_io_tools/prompt_string
388 : !! NAME
389 : !! prompt_string
390 : !!
391 : !! FUNCTION
392 : !! A primitive prompt. Writes msg on std_out and reads the value entered by the user.
393 : !! If strip_comment is True (default), all the characters after "#" or "!" are ignored.
394 : !!
395 : !! SOURCE
396 :
397 321 : subroutine prompt_string(msg,string,strip_comment)
398 :
399 : character(len=*),intent(in) :: msg
400 : logical,optional,intent(in) :: strip_comment
401 : character(len=*),intent(out) :: string
402 :
403 : !Local variables-------------------------------
404 : integer :: ios,ic
405 : logical :: do_strip
406 : character(len=4) :: PS
407 : !character(len=len(string)) :: tmps
408 : ! *********************************************************************
409 :
410 321 : do_strip = .True.; if (present(strip_comment)) do_strip = strip_comment
411 :
412 321 : ios=-1 ; PS=PS1
413 642 : do while (ios/=0)
414 321 : write(std_out,'(a)',ADVANCE='NO')PS//TRIM(msg)//BLANK
415 321 : call flush_unit(std_out)
416 321 : read(std_in,'(a)',IOSTAT=ios)string
417 321 : if (ios==IO_EOT) call prompt_exit()
418 321 : PS=PS2
419 : end do
420 321 : write(std_out,*)
421 :
422 321 : if (do_strip) then
423 321 : ic = INDEX(string, "#"); if (ic /= 0) string(:) = string(:ic-1)
424 321 : ic = INDEX(string, "!"); if (ic /= 0) string(:) = string(:ic-1)
425 : end if
426 :
427 321 : end subroutine prompt_string
428 : !!***
429 :
430 : !----------------------------------------------------------------------
431 :
432 : !!****f* m_io_tools/prompt_int1D
433 : !! NAME
434 : !! prompt_int1D
435 : !!
436 : !! FUNCTION
437 : !! A primitive prompt. Writes msg on std_out and reads the value entered by the user.
438 : !!
439 : !! SOURCE
440 :
441 1 : subroutine prompt_int1D(msg,ivect)
442 :
443 : !Arguments ------------------------------------
444 : character(len=*),intent(in) :: msg
445 : integer,intent(out) :: ivect(:)
446 :
447 : !Local variables-------------------------------
448 : integer :: ios
449 : character(len=4) :: PS
450 : ! *********************************************************************
451 :
452 1 : ios=-1 ; PS=PS1
453 2 : do while (ios/=0)
454 1 : write(std_out,'(a)',ADVANCE='NO')PS//TRIM(msg)//BLANK
455 1 : call flush_unit(std_out)
456 1 : read(std_in,*,IOSTAT=ios)ivect(:)
457 1 : if (ios==IO_EOT) call prompt_exit()
458 1 : PS=PS2
459 : end do
460 1 : write(std_out,*)
461 :
462 1 : end subroutine prompt_int1D
463 : !!***
464 :
465 : !----------------------------------------------------------------------
466 :
467 : !!****f* m_io_tools/prompt_int2D
468 : !! NAME
469 : !! prompt_int2d
470 : !!
471 : !! FUNCTION
472 : !! A primitive prompt. Writes msg on std_out and reads the value entered by the user.
473 : !!
474 : !! SOURCE
475 :
476 0 : subroutine prompt_int2D(msg,iarr)
477 :
478 : character(len=*),intent(in) :: msg
479 : integer,intent(out) :: iarr(:,:)
480 :
481 : !Local variables-------------------------------
482 : integer :: ios
483 : character(len=4) :: PS
484 : ! *********************************************************************
485 :
486 0 : ios=-1 ; PS=PS1
487 0 : do while (ios/=0)
488 0 : write(std_out,'(a)',ADVANCE='NO')PS//TRIM(msg)//BLANK
489 0 : call flush_unit(std_out)
490 0 : read(std_in,*,IOSTAT=ios)iarr(:,:)
491 0 : if (ios==IO_EOT) call prompt_exit()
492 0 : PS=PS2
493 : end do
494 0 : write(std_out,*)
495 :
496 0 : end subroutine prompt_int2D
497 : !!***
498 :
499 : !----------------------------------------------------------------------
500 :
501 : !!****f* m_io_tools/prompt_rdp1D
502 : !! NAME
503 : !! prompt_rdp1D
504 : !!
505 : !! FUNCTION
506 : !! A primitive prompt. Writes msg on std_out and reads the value entered by the user.
507 : !!
508 : !! SOURCE
509 :
510 0 : subroutine prompt_rdp1D(msg,rvect)
511 :
512 : !Arguments ------------------------------------
513 : character(len=*),intent(in) :: msg
514 : real(dp),intent(out) :: rvect(:)
515 : character(len=4) :: PS
516 : !Local variables-------------------------------
517 : integer :: ios
518 : ! *********************************************************************
519 :
520 0 : ios=-1 ; PS=PS1
521 0 : do while (ios/=0)
522 0 : write(std_out,'(a)',ADVANCE='NO')PS//TRIM(msg)//BLANK
523 0 : call flush_unit(std_out)
524 0 : read(std_in,*,IOSTAT=ios)rvect(:)
525 0 : if (ios==IO_EOT) call prompt_exit()
526 0 : PS=PS2
527 : end do
528 0 : write(std_out,*)
529 :
530 0 : end subroutine prompt_rdp1D
531 : !!***
532 :
533 : !----------------------------------------------------------------------
534 :
535 : !!****f* m_io_tools/prompt_rdp2D
536 : !! NAME
537 : !! prompt_rdp2D
538 : !!
539 : !! FUNCTION
540 : !! A primitive prompt. Writes msg on std_out and reads the value entered by the user.
541 : !!
542 : !! SOURCE
543 :
544 0 : subroutine prompt_rdp2D(msg,rarr)
545 :
546 : character(len=*),intent(in) :: msg
547 : real(dp),intent(out) :: rarr(:,:)
548 :
549 : !Local variables-------------------------------
550 : integer :: ios
551 : character(len=4) :: PS
552 : ! *********************************************************************
553 :
554 0 : ios=-1 ; PS=PS1
555 0 : do while (ios/=0)
556 0 : write(std_out,'(a)',ADVANCE='NO')PS//TRIM(msg)//BLANK
557 0 : call flush_unit(std_out)
558 0 : read(std_in,*,IOSTAT=ios)rarr(:,:)
559 0 : if (ios==IO_EOT) call prompt_exit()
560 0 : PS=PS2
561 : end do
562 0 : write(std_out,*)
563 :
564 0 : end subroutine prompt_rdp2D
565 : !!***
566 :
567 : !----------------------------------------------------------------------
568 :
569 : !!****f* m_io_tools/prompt_exit
570 : !! NAME
571 : !! prompt_exit
572 : !!
573 : !! FUNCTION
574 : !! A primitive prompt. Writes msg on std_out and reads the value entered by the user.
575 : !!
576 : !! SOURCE
577 :
578 0 : subroutine prompt_exit()
579 :
580 : integer,parameter :: NASK=5
581 : integer :: ios,iask
582 : character(len=IO_MAX_LEN) :: ans
583 : ! *********************************************************************
584 :
585 0 : write(std_out,*)
586 0 : ios=-1 ; iask=0
587 0 : do while (ios/=0.or.(ans/='y'.or.ans/='n'))
588 0 : iask=iask+1
589 0 : write(std_out,'(a)')' Do you really want to exit (y/n)? '
590 0 : call flush_unit(std_out)
591 0 : read(std_in,*,IOSTAT=ios)ans
592 0 : if (ans=='y'.or.iask>NASK) STOP
593 0 : if (ans=='n') RETURN
594 : end do
595 :
596 : end subroutine prompt_exit
597 : !!***
598 :
599 : !----------------------------------------------------------------------
600 :
601 : !!****f* m_io_tools/read_string
602 : !! NAME
603 : !! read_string
604 : !!
605 : !! FUNCTION
606 : !! Reads string from unit=std_in_ or unit if specified, ignoring blank lines
607 : !! and deleting comments beginning with `!`. Return exit code.
608 : !!
609 : !! SOURCE
610 :
611 37 : integer function read_string(string, unit) result(ios)
612 :
613 : character(len=*),intent(out):: string
614 : integer,optional,intent(in) :: unit
615 :
616 : !Local variables-------------------------------
617 : integer :: ipos,unt
618 : ! *********************************************************************
619 :
620 37 : unt=std_in; if (present(unit)) unt=unit
621 :
622 37 : read(unt,'(a)', iostat=ios) string ! read input line
623 37 : if (ios/=0) return
624 37 : string = ADJUSTL(string)
625 :
626 : ! Ignore portion after comments
627 37 : ipos = INDEX(string, "!")
628 37 : if (ipos /= 0) string=string(:ipos-1)
629 37 : ipos = INDEX(string, "#")
630 37 : if (ipos /= 0) string=string(:ipos-1)
631 :
632 74 : end function read_string
633 : !!***
634 :
635 : !----------------------------------------------------------------------
636 :
637 : !!****f* m_io_tools/flush_unit
638 : !! NAME
639 : !! flush_unit
640 : !!
641 : !! FUNCTION
642 : !! Wrapper for the standard flush_unit routine
643 : !!
644 : !! INPUTS
645 : !! unit=Fortran logical Unit number
646 : !!
647 : !! NOTES
648 : !! Available only if the compiler implements this intrinsic procedure.
649 : !!
650 : !! SOURCE
651 :
652 242555 : subroutine flush_unit(unit)
653 :
654 : integer,intent(in) :: unit
655 :
656 : !Local variables-------------------------------
657 : logical :: isopen
658 : !************************************************************************
659 :
660 242555 : if (unit == dev_null) return
661 :
662 242531 : inquire(unit=unit,opened=isopen)
663 :
664 : !FLUSH on unconnected unit is illegal: F95 std., 9.3.5.
665 : #if defined HAVE_FC_FLUSH
666 242531 : if (isopen) call flush(unit)
667 : #elif defined HAVE_FC_FLUSH_
668 : if (isopen) call flush_(unit)
669 : #endif
670 :
671 : end subroutine flush_unit
672 : !!***
673 :
674 : !----------------------------------------------------------------------
675 :
676 : !!****f* m_io_tools/pick_aname
677 : !! NAME
678 : !! pick_aname
679 : !!
680 : !! FUNCTION
681 : !! Returns the name of a non-existent file to be used for temporary storage.
682 : !!
683 : !! SOURCE
684 :
685 1169 : function pick_aname() result(aname)
686 :
687 : character(len=fnlen) :: aname
688 :
689 : !Local variables-------------------------------
690 : integer :: ii,spt,ept
691 : real(dp) :: xrand(fnlen)
692 : !************************************************************************
693 :
694 1169 : aname="__TMP_FILE__"
695 :
696 1169 : spt=LEN(aname); ept=spt
697 :
698 1169 : do while (file_exists(aname))
699 0 : call RANDOM_NUMBER(xrand(spt:ept))
700 0 : xrand(spt:ept) = 64+xrand(spt:ept)*26
701 0 : do ii=spt,ept
702 0 : aname(ii:ii) = ACHAR(NINT(xrand(ii)))
703 : end do
704 1169 : ept = MIN(ept+1,fnlen)
705 : end do
706 :
707 1169 : end function pick_aname
708 : !!***
709 :
710 : !----------------------------------------------------------------------
711 :
712 : !!****f* m_io_tools/isncfile
713 : !! NAME
714 : !! isncfile
715 : !!
716 : !! FUNCTION
717 : !! Return .TRUE. if fname is a NETCDF file.
718 : !!
719 : !! INPUTS
720 : !! fname(len=*)=The name of the file to be tested.
721 : !!
722 : !! NOTES
723 : !! The idea is extremely simple: a NETCDF file terminates with ".nc".
724 : !! Obviously this approach is not bulletproof but it will work
725 : !! provided that we continue to append the ".nc" string to any NETCDF
726 : !! file produced by abinit.
727 : !!
728 : !! SOURCE
729 :
730 16441 : pure logical function isncfile(fname)
731 :
732 : !Arguments ------------------------------------
733 : !scalars
734 : character(len=*),intent(in) :: fname
735 :
736 : !Local variables-------------------------------
737 : integer :: ic,nch_trim
738 : ! *************************************************************************
739 :
740 16441 : nch_trim=LEN_TRIM(fname)
741 16441 : ic = INDEX (TRIM(fname), ".", back=.TRUE.)
742 :
743 16441 : isncfile=.FALSE.
744 16441 : if (ic >= 1 .and. ic <= nch_trim-1) then ! there is stuff after the .
745 16023 : isncfile = (fname(ic+1:nch_trim)=="nc")
746 : end if
747 :
748 16441 : end function isncfile
749 : !!***
750 :
751 : !----------------------------------------------------------------------
752 :
753 : !!****f* m_io_tools/iomode_from_fname
754 : !! NAME
755 : !! iomode_from_fname
756 : !!
757 : !! FUNCTION
758 : !! Automatic selection of the IO mode based on the file extension.
759 : !!
760 : !! INPUTS
761 : !! fname = Name of the file.
762 : !!
763 : !! NOTES
764 : !! if fname has extension '.nc', IO_MODE_ETSF is used
765 : !! else:
766 : !! IO_MODE_MPI if available
767 : !! IO_MODE_FORTRAN if HAVE_MPI_IO is not defined.
768 : !!
769 : !! SOURCE
770 :
771 7239 : pure integer function iomode_from_fname(fname) result(iomode)
772 :
773 : !Arguments ------------------------------------
774 : character(len=*),intent(in) :: fname
775 : ! *************************************************************************
776 :
777 7239 : if (isncfile(fname)) then
778 : iomode = IO_MODE_ETSF
779 : else
780 : #ifdef HAVE_MPI_IO
781 319 : iomode = IO_MODE_MPI
782 : #else
783 : iomode = IO_MODE_FORTRAN
784 : #endif
785 :
786 319 : if (enforce_fortran_io__) iomode = IO_MODE_FORTRAN
787 : end if
788 :
789 7239 : end function iomode_from_fname
790 : !!***
791 :
792 : !----------------------------------------------------------------------
793 :
794 : !!****f* m_io_tools/enforce_fortran_io
795 : !! NAME
796 : !! enforce_fortran_io
797 : !!
798 : !! FUNCTION
799 : !! Set the value of the enforce_fortran__ global variable.
800 : !!
801 : !! SOURCE
802 :
803 0 : subroutine enforce_fortran_io(bool)
804 :
805 : !Arguments ------------------------------------
806 : !scalars
807 : logical,intent(in) :: bool
808 : ! *************************************************************************
809 :
810 0 : enforce_fortran_io__ = bool
811 :
812 0 : end subroutine enforce_fortran_io
813 : !!***
814 :
815 : !----------------------------------------------------------------------
816 :
817 : !!****f* m_io_tools/iomode2str
818 : !! NAME
819 : !! iomode2str
820 : !!
821 : !! FUNCTION
822 : !! Convert iomode to string
823 : !!
824 : !! SOURCE
825 :
826 12046 : pure function iomode2str(iomode)
827 :
828 : !Arguments ------------------------------------
829 : character(len=48) :: iomode2str
830 : integer,intent(in) :: iomode
831 : ! *************************************************************************
832 :
833 12178 : select case (iomode)
834 : case (IO_MODE_FORTRAN_MASTER)
835 132 : iomode2str = "IO_MODE_FORTRAN_MASTER"
836 : case (IO_MODE_FORTRAN)
837 28 : iomode2str = "IO_MODE_FORTRAN"
838 : case (IO_MODE_MPI)
839 167 : iomode2str = "IO_MODE_MPI"
840 : case (IO_MODE_NETCDF)
841 0 : iomode2str = "IO_MODE_NETCDF"
842 : case (IO_MODE_ETSF)
843 11719 : iomode2str = "IO_MODE_ETSF"
844 : case default
845 12046 : iomode2str = "Unknown!"
846 : end select
847 :
848 12046 : end function iomode2str
849 : !!***
850 :
851 : !----------------------------------------------------------------------
852 :
853 : !!****f* m_io_tools/mvrecord
854 : !! NAME
855 : !! mvrecord
856 : !!
857 : !! FUNCTION
858 : !! This subroutine moves forward or backward in a Fortran binary file by nn records.
859 : !!
860 : !! INPUTS
861 : !! funt= Fortran file unit number
862 : !! nrec=number of records
863 : !!
864 : !! OUTPUT
865 : !! ierr=error code
866 : !!
867 : !! TODO
868 : !! One should treat the possible errors of backspace
869 : !!
870 : !! SOURCE
871 :
872 0 : subroutine mvrecord(funt,nrec,ierr)
873 :
874 : !Arguments ------------------------------------
875 : !scalars
876 : integer,intent(in) :: funt,nrec
877 : integer,intent(out) :: ierr
878 :
879 : !Local variables-------------------------------
880 : integer :: irec
881 : ! *************************************************************************
882 :
883 0 : ierr = 0
884 0 : if (nrec > 0) then ! Move forward nrec records
885 0 : do irec=1,nrec
886 0 : read(funt,iostat=ierr)
887 0 : if (ierr /= 0) EXIT
888 : end do
889 0 : else if (nrec < 0) then ! Move backward nrec records
890 0 : do irec=1,-nrec
891 0 : backspace (unit=funt,iostat=ierr)
892 0 : if (ierr /= 0) EXIT
893 : end do
894 : end if
895 :
896 0 : end subroutine mvrecord
897 : !!***
898 :
899 : !----------------------------------------------------------------------
900 :
901 : !!****f* m_io_tools/open_file
902 : !! NAME
903 : !! open_file
904 : !!
905 : !! FUNCTION
906 : !! Open a file in sequential mode and associate it to the unit number number.
907 : !! The main differences wrt the intrinsic open:
908 : !!
909 : !! * Function statement that returns the value of iostat
910 : !! * Emulate iomsg (F2003)
911 : !! * Accepts either unit (user-specified unit number, input) or
912 : !! newunit (free unit not associated to any file, output).
913 : !! The two options are mutually exclusive.
914 : !!
915 : !! See Fortran intrinsic for a more detailed description of the variables
916 : !!
917 : !! OUTPUT
918 : !! iostat=Exit status
919 : !! iomsg=Error message
920 : !!
921 : !! SOURCE
922 :
923 32403 : function open_file(file, iomsg, unit, newunit, access, form, status, action, recl) result(iostat)
924 :
925 : !Arguments ------------------------------------
926 : !scalars
927 : character(len=*),intent(in) :: file
928 : character(len=*),optional,intent(in) :: access,form,status,action
929 : character(len=*),intent(out) :: iomsg
930 : integer,optional,intent(in) :: recl,unit
931 : integer,optional,intent(out) :: newunit
932 : integer :: iostat
933 :
934 : !Local variables-------------------------------
935 : character(len=500) :: my_access,my_form,my_status,my_action,msg
936 : ! *************************************************************************
937 :
938 40 : my_access = "sequential"; if (present(access)) my_access = access
939 32403 : my_form = "formatted"; if (present(form)) my_form = form
940 32403 : my_status = "unknown"; if (present(status)) my_status = status
941 32403 : my_action = "readwrite"; if (present(action)) my_action = action ! default is system dependent. Enforce RW mode
942 :
943 32403 : iomsg = "" ! iomsg is not changed if open succeeds
944 :
945 32403 : if (present(unit)) then
946 6200 : if (present(recl)) then
947 0 : open(file=trim(file),unit=unit,form=my_form,status=my_status,access=my_access,iostat=iostat,recl=recl, iomsg=iomsg)
948 : else
949 6200 : open(file=trim(file),unit=unit,form=my_form,status=my_status,access=my_access,iostat=iostat, iomsg=iomsg)
950 : end if
951 6200 : if (present(newunit)) iostat = -666 ! wrong call
952 :
953 26203 : else if (present(newunit)) then
954 : ! Get free unit (emulate newunit of F2008)
955 26203 : newunit = get_unit()
956 26203 : if (present(recl)) then
957 4 : open(file=trim(file),unit=newunit,form=my_form,status=my_status,access=my_access,iostat=iostat,recl=recl, iomsg=iomsg)
958 : else
959 26199 : open(file=trim(file),unit=newunit,form=my_form,status=my_status,access=my_access,iostat=iostat, iomsg=iomsg)
960 : end if
961 : if (present(unit)) iostat = -666 ! wrong call
962 :
963 : else
964 0 : iomsg = "Either unit or newunit must be specified"
965 0 : iostat = -1
966 : end if
967 :
968 32403 : if (iostat /= 0) then
969 8 : write(msg, "(a,i0,2a)")"Fortran open returned iostat: ",iostat," while opening file: "//trim(file)
970 8 : iomsg = trim(msg)//ch10//"Runtime error message: "//trim(iomsg)
971 : end if
972 :
973 32403 : end function open_file
974 : !!***
975 :
976 : !----------------------------------------------------------------------
977 :
978 : !!****f* m_io_tools/close_unit
979 : !! NAME
980 : !! close_unit
981 : !!
982 : !! FUNCTION
983 : !! close a Fortran unit
984 : !! The main differences wrt the intrinsic close:
985 : !!
986 : !! * Function statement that returns the value of iostat
987 : !! * Emulate iomsg (F2003)
988 : !!
989 : !! See Fortran intrinsic for a more detailed description of the variables
990 : !!
991 : !! OUTPUT
992 : !! iostat=Exit status
993 : !! iomsg=Error message
994 : !!
995 : !! SOURCE
996 :
997 59 : function close_unit(unit,iomsg,status) result(iostat)
998 :
999 : !Arguments ------------------------------------
1000 : !scalars
1001 : integer,intent(inout) :: unit
1002 : character(len=*),optional,intent(in) :: status
1003 : character(len=*),intent(out) :: iomsg
1004 : integer :: iostat
1005 :
1006 : !Local variables-------------------------------
1007 : character(len=500) :: msg
1008 : ! *************************************************************************
1009 :
1010 59 : iomsg = "" ! iomsg is not changed if close succeeds
1011 :
1012 59 : if (.not.present(status)) then ! Use Fortran default e.g delete for scratch files.
1013 : #ifdef HAVE_FC_IOMSG
1014 59 : close(unit=unit,iostat=iostat,iomsg=iomsg)
1015 : #else
1016 : close(unit=unit,iostat=iostat)
1017 : #endif
1018 : else
1019 : #ifdef HAVE_FC_IOMSG
1020 0 : close(unit=unit,iostat=iostat,status=status,iomsg=iomsg)
1021 : #else
1022 : close(unit=unit,iostat=iostat,status=status)
1023 : #endif
1024 : end if
1025 :
1026 : ! TODO: Add more info for example the filename.
1027 59 : if (iostat /= 0) then
1028 0 : write(msg,'(2(a,i0),a)')"Fortran close returned iostat ",iostat," while closing unit: ",unit,ch10
1029 0 : iomsg = trim(msg)//ch10//"IOMSG: "//trim(msg)
1030 : end if
1031 :
1032 59 : end function close_unit
1033 : !!***
1034 :
1035 : !----------------------------------------------------------------------
1036 :
1037 : !!****f* m_io_tools/write_lines
1038 : !! NAME
1039 : !! write_lines
1040 : !!
1041 : !! FUNCTION
1042 : !! This routine receives a string, split the message in lines according to the
1043 : !! ch10 character and output the text to the specified unit
1044 : !!
1045 : !! INPUTS
1046 : !! unit=unit number for writing
1047 : !! message=(character(len=*)) message to be written
1048 : !! [toflush]=flag to activate immediate flush of the I/O buffer (default=FALSE)
1049 : !!
1050 : !! OUTPUT
1051 : !! Only writing.
1052 : !!
1053 : !! SOURCE
1054 :
1055 7244472 : subroutine write_lines(unit,message,toflush)
1056 :
1057 : !Arguments ------------------------------------
1058 : !scalars
1059 : integer,intent(in) :: unit
1060 : logical,intent(in),optional :: toflush
1061 : character(len=*),intent(in) :: message
1062 :
1063 : !Local variables-------------------------------
1064 : !scalars
1065 : integer :: msg_size,ii,jj,rtnpos
1066 : logical :: toflush_
1067 : !******************************************************************
1068 :
1069 7244472 : msg_size = len_trim(message)
1070 7244472 : toflush_=.false.;if (present(toflush)) toflush_=toflush
1071 :
1072 7244472 : if (msg_size == 0) then
1073 83562 : write(unit,*)
1074 83562 : return
1075 : end if
1076 :
1077 : ! Here, split the message, according to the char(10) characters (carriage return).
1078 : ! This technique is portable accross different OS.
1079 7160910 : rtnpos = index(message,ch10)
1080 :
1081 7160910 : if (rtnpos == 0) then
1082 6118304 : write(unit,"(a)")message(1:msg_size)
1083 6118304 : if (toflush_) call flush_unit(unit)
1084 6118304 : return
1085 : end if
1086 :
1087 : ii = 1; jj = rtnpos
1088 : do
1089 3628336 : if (ii == jj) then
1090 746888 : write(unit,*)
1091 746888 : if (toflush_) call flush_unit(unit)
1092 : else
1093 2881448 : write(unit, '(a)' ) message(ii:jj-1)
1094 2881448 : if (toflush_) call flush_unit(unit)
1095 : end if
1096 3628336 : ii = jj + 1
1097 3628336 : if (ii > msg_size) exit
1098 2585730 : jj = index(message(ii:msg_size),ch10)
1099 3628336 : if (jj == 0) then
1100 : ! Will write the last line at the next iteration and exit .
1101 633268 : jj = msg_size + 1
1102 : else
1103 1952462 : jj = jj + ii - 1
1104 : end if
1105 : !write(*,*)"ii, jj, msg_size",ii, jj, msg_size
1106 : end do
1107 :
1108 : ! This is needed to preserve the od behaviour: a ch10 at the
1109 : ! end of the string was causing an extra newline!
1110 1042606 : if (message(msg_size:msg_size) == ch10) write(unit,*)
1111 :
1112 : end subroutine write_lines
1113 : !!***
1114 :
1115 : !!****f* m_io_tools/lock_and_write
1116 : !! NAME
1117 : !! lock_and_write
1118 : !!
1119 : !! FUNCTION
1120 : !! Writes a string to filename with locking mechanism.
1121 : !!
1122 : !! INPUTS
1123 : !! filename: Name of the file.
1124 : !! string: Input string.
1125 : !! ierr: Exit status, 0 is string has been written to filename.
1126 : !!
1127 : !! SOURCE
1128 :
1129 0 : subroutine lock_and_write(filename, string, ierr)
1130 :
1131 : integer,intent(out) :: ierr
1132 : character(len=*),intent(in) :: filename,string
1133 :
1134 : !Local variables-------------------------------
1135 : integer :: file_unit, fd
1136 : integer(c_int) :: sleep_time
1137 0 : character(len=len(filename) + 5) :: lock_name
1138 : ! *********************************************************************
1139 :
1140 : ! Try to write string to std_out and ab_out.
1141 : ! NB: There's no gurantee that string will be written because
1142 : ! the first MPI proc that gets here may not be connected to ab_out
1143 : ! or std_out may have been redirected to /dev/null.
1144 : ! This is the reason why we try write to __ABI_MPIABORTFILE__ as well.
1145 0 : if (is_open_unit(std_out)) call write_lines(std_out, string, toflush=.true.)
1146 :
1147 0 : if (is_open_unit(ab_out)) then
1148 0 : call write_lines(ab_out, string, toflush=.true.)
1149 : else
1150 : ! This proc is not the master one. Let's make it sleep a bit hoping that
1151 : ! the master proc calls this routine as well...
1152 0 : sleep_time = 1
1153 0 : call clib_sleep(sleep_time)
1154 : end if
1155 :
1156 : ! Try to acquire the lock.
1157 0 : ierr = 0; lock_name = trim(filename)//".lock"
1158 :
1159 0 : call clib_lock_file_by_name(trim(lock_name)//c_null_char, fd, ierr)
1160 0 : if (ierr == 0) then
1161 : ! I got the lock --> write string to __ABI_MPIABORTFILE__
1162 0 : file_unit = get_unit()
1163 0 : open(unit=file_unit, file=trim(filename), form="formatted")
1164 0 : call write_lines(file_unit, string, toflush=.true.)
1165 0 : call clib_close_fd(fd)
1166 0 : call delete_file(lock_name, ierr)
1167 : end if
1168 :
1169 0 : end subroutine lock_and_write
1170 : !!***
1171 :
1172 : !----------------------------------------------------------------------
1173 :
1174 : !!****f* m_io_tools/num_opened_units
1175 : !! NAME
1176 : !! num_opened_units
1177 : !!
1178 : !! FUNCTION
1179 : !! Return the number of opened units.
1180 : !! Unit numbers listed in the optional argument `ignore` are not considered.
1181 : !!
1182 : !! SOURCE
1183 :
1184 0 : integer function num_opened_units(ignore) result(nn)
1185 :
1186 : !Arguments ------------------------------------
1187 : !scalars
1188 : integer,optional,intent(in) :: ignore(:)
1189 :
1190 : !Local variables-------------------------------
1191 : integer :: ii,iostat
1192 : logical :: opened
1193 : ! *********************************************************************
1194 :
1195 0 : nn = 0
1196 0 : do ii=0, max_unit_number
1197 0 : if (present(ignore)) then
1198 0 : if (any(ii == ignore)) cycle
1199 : end if
1200 0 : inquire(ii, opened=opened, iostat=iostat)
1201 0 : if (iostat == 0 .and. opened) nn = nn + 1
1202 : end do
1203 :
1204 0 : end function num_opened_units
1205 : !!***
1206 :
1207 : !----------------------------------------------------------------------
1208 :
1209 : !!****f* m_io_tools/show_units
1210 : !! NAME
1211 : !! show_units
1212 : !!
1213 : !! FUNCTION
1214 : !! Print info on the logical units
1215 : !!
1216 : !! SOURCE
1217 :
1218 0 : subroutine show_units(ount)
1219 :
1220 : !Arguments ------------------------------------
1221 : !scalars
1222 : integer,intent(in) :: ount
1223 :
1224 : !Local variables-------------------------------
1225 : integer :: ii,iostat
1226 : logical :: named, opened
1227 : character(len=fnlen) :: filename,form
1228 : ! *********************************************************************
1229 :
1230 0 : write(ount,'(a)') '******** Fortran Logical Units ********'
1231 :
1232 0 : do ii=0,max_unit_number
1233 0 : inquire(ii, opened=opened, named=named, name=filename, form=form, iostat=iostat)
1234 0 : if (iostat == 0) then
1235 0 : if (opened) then
1236 0 : if (named) then
1237 0 : write(ount,*)"unit: ", ii, "form: ", trim(form), ", filename: ", trim(filename)
1238 : else
1239 0 : write(ount,*)"unit: ", ii, "form: ",form, ', No name available'
1240 : endif
1241 : else
1242 : !write(ount,*)"unit: ", ii, " is not opened"
1243 : endif
1244 : else
1245 0 : write(ount,*)" unit: ", ii, ' Iostat error'
1246 : endif
1247 : end do
1248 :
1249 0 : end subroutine show_units
1250 : !!***
1251 :
1252 : !!****f* m_io_tools/write_units
1253 : !! NAME
1254 : !! write_units
1255 : !!
1256 : !! FUNCTION
1257 : !! Write `string` to a list of Fortran `units`.
1258 : !! This function is supposed to be faster than wrtout as there's no check on the MPI rank.
1259 : !! This also means that this procedure should be called by a single MPI proc.
1260 : !!
1261 : !! INPUTS
1262 : !! [newlines]: Number of newlines added after string. Default 0
1263 : !! [pre_newlines]: Number of newlines added before string. Default 0
1264 : !!
1265 : !! SOURCE
1266 :
1267 0 : subroutine write_units(units, string, newlines, pre_newlines)
1268 :
1269 : !Arguments ------------------------------------
1270 : character(len=*),intent(in) :: string
1271 : integer,intent(in) :: units(:)
1272 : integer,optional,intent(in) :: newlines, pre_newlines
1273 :
1274 : !Local variables-------------------------------
1275 : integer :: ii, unt
1276 : ! *************************************************************************
1277 :
1278 0 : do unt=1,size(units)
1279 0 : if (present(pre_newlines)) then
1280 0 : do ii=1,pre_newlines
1281 0 : write(units(unt), "(a)") " "
1282 : end do
1283 : end if
1284 0 : write(units(unt), "(a)") trim(string)
1285 0 : if (present(newlines)) then
1286 0 : do ii=1,newlines
1287 0 : write(units(unt), "(a)") " "
1288 : end do
1289 : end if
1290 : end do
1291 :
1292 0 : end subroutine write_units
1293 : !!***
1294 :
1295 : !----------------------------------------------------------------------
1296 :
1297 : end module m_io_tools
1298 : !!***
|
