Branch data 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 : 38069 : integer function get_free_unit()
122 : :
123 : : !Local variables-------------------------------
124 : : integer :: iunt
125 : : logical :: isopen
126 : : ! *********************************************************************
127 : :
128 [ + - ]: 40741 : do iunt=MAX_UNIT_NUMBER,MIN_UNIT_NUMBER,-1
129 [ + + ]: 40741 : if (any(iunt == [std_err, std_in, std_out])) cycle
130 : 40713 : inquire(unit=iunt, opened=isopen)
131 [ + + ]: 40713 : 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 : 80704 : logical function file_exists(filepath)
181 : :
182 : : character(len=*),intent(in) :: filepath
183 : : ! *********************************************************************
184 : :
185 : 80704 : inquire(file=filepath, exist=file_exists)
186 : :
187 : 80704 : 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 : 2606 : 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 : 2606 : ierr = 0
221 : :
222 : 2606 : inquire(file=fname, exist=exists)
223 : :
224 [ + + ]: 2606 : 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 [ - + ]: 1191 : 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 : 1191 : tmp_unt = get_unit()
239 : : end if
240 : :
241 : : ! Now close the file.
242 : 1191 : open(unit=tmp_unt, file=trim(fname), status="OLD", iostat=ierr)
243 [ + - ]: 1191 : 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 : 27247 : logical function is_open_unit(unit)
287 : :
288 : : integer,intent(in) :: unit
289 : : ! *********************************************************************
290 : :
291 : 27247 : inquire(unit=unit, opened=is_open_unit)
292 : :
293 : 27247 : 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 : 1191 : logical function is_open_fname(fname)
308 : :
309 : : character(len=*),intent(in) :: fname
310 : : ! *********************************************************************
311 : :
312 : 1191 : inquire(file=fname,opened=is_open_fname)
313 : :
314 : 1191 : 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 : 152333 : subroutine flush_unit(unit)
653 : :
654 : : integer,intent(in) :: unit
655 : :
656 : : !Local variables-------------------------------
657 : : logical :: isopen
658 : : !************************************************************************
659 : :
660 [ + + ]: 152333 : if (unit == dev_null) return
661 : :
662 : 152309 : 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 [ + + ]: 152309 : 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 : 1181 : 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 : 1181 : aname="__TMP_FILE__"
695 : :
696 : 1181 : spt=LEN(aname); ept=spt
697 : :
698 [ - + ]: 1181 : 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 : 1181 : ept = MIN(ept+1,fnlen)
705 : : end do
706 : :
707 : 1181 : 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 : 16551 : 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 : 16551 : nch_trim=LEN_TRIM(fname)
741 : 16551 : ic = INDEX (TRIM(fname), ".", back=.TRUE.)
742 : :
743 : 16551 : isncfile=.FALSE.
744 [ + + ]: 16551 : if (ic >= 1 .and. ic <= nch_trim-1) then ! there is stuff after the .
745 : 16132 : isncfile = (fname(ic+1:nch_trim)=="nc")
746 : : end if
747 : :
748 : 16551 : 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 : 7296 : pure integer function iomode_from_fname(fname) result(iomode)
772 : :
773 : : !Arguments ------------------------------------
774 : : character(len=*),intent(in) :: fname
775 : : ! *************************************************************************
776 : :
777 [ + + ]: 7296 : if (isncfile(fname)) then
778 : : iomode = IO_MODE_ETSF
779 : : else
780 : : #ifdef HAVE_MPI_IO
781 : 320 : iomode = IO_MODE_MPI
782 : : #else
783 : : iomode = IO_MODE_FORTRAN
784 : : #endif
785 : :
786 [ - + ]: 320 : if (enforce_fortran_io__) iomode = IO_MODE_FORTRAN
787 : : end if
788 : :
789 : 7296 : 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 : 12115 : pure function iomode2str(iomode)
827 : :
828 : : !Arguments ------------------------------------
829 : : character(len=48) :: iomode2str
830 : : integer,intent(in) :: iomode
831 : : ! *************************************************************************
832 : :
833 : 12247 : 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 : 11788 : iomode2str = "IO_MODE_ETSF"
844 : : case default
845 [ + + + - : 12115 : iomode2str = "Unknown!"
+ - ]
846 : : end select
847 : :
848 : 12115 : 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 : 32647 : 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 [ + + + - ]: 32647 : my_form = "formatted"; if (present(form)) my_form = form
940 [ + + + - ]: 32647 : my_status = "unknown"; if (present(status)) my_status = status
941 [ + + + - ]: 32647 : my_action = "readwrite"; if (present(action)) my_action = action ! default is system dependent. Enforce RW mode
942 : :
943 [ + - ]: 32647 : iomsg = "" ! iomsg is not changed if open succeeds
944 : :
945 [ + + ]: 32647 : if (present(unit)) then
946 [ - + ]: 6245 : 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 : 6245 : open(file=trim(file),unit=unit,form=my_form,status=my_status,access=my_access,iostat=iostat, iomsg=iomsg)
950 : : end if
951 [ - + ]: 6245 : if (present(newunit)) iostat = -666 ! wrong call
952 : :
953 [ + - ]: 26402 : else if (present(newunit)) then
954 : : ! Get free unit (emulate newunit of F2008)
955 : 26402 : newunit = get_unit()
956 [ + + ]: 26402 : 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 : 26398 : 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 [ + + ]: 32647 : 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 [ + + ]: 32647 : 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 : 7339239 : 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 : 7339239 : msg_size = len_trim(message)
1070 [ - + ]: 7339239 : toflush_=.false.;if (present(toflush)) toflush_=toflush
1071 : :
1072 [ + + ]: 7339239 : if (msg_size == 0) then
1073 : 84545 : write(unit,*)
1074 : 84545 : 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 : 7254694 : rtnpos = index(message,ch10)
1080 : :
1081 [ + + ]: 7254694 : if (rtnpos == 0) then
1082 : 6204372 : write(unit,"(a)")message(1:msg_size)
1083 [ - + ]: 6204372 : if (toflush_) call flush_unit(unit)
1084 : 6204372 : return
1085 : : end if
1086 : :
1087 : : ii = 1; jj = rtnpos
1088 : : do
1089 [ + + ]: 3651396 : if (ii == jj) then
1090 : 752463 : write(unit,*)
1091 [ - + ]: 752463 : if (toflush_) call flush_unit(unit)
1092 : : else
1093 : 2898933 : write(unit, '(a)' ) message(ii:jj-1)
1094 [ - + ]: 2898933 : if (toflush_) call flush_unit(unit)
1095 : : end if
1096 : 3651396 : ii = jj + 1
1097 [ + + ]: 3651396 : if (ii > msg_size) exit
1098 : 2601074 : jj = index(message(ii:msg_size),ch10)
1099 [ + + ]: 3651396 : if (jj == 0) then
1100 : : ! Will write the last line at the next iteration and exit .
1101 : 639263 : jj = msg_size + 1
1102 : : else
1103 : 1961811 : 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 [ + + ]: 1050322 : 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 : : !!***
|
