TABLE OF CONTENTS

ABINIT/m_io_tools [ Modules ]

[ Top ] [ Modules ]

NAME

  m_io_tools

FUNCTION

  This module contains basic tools to deal with Fortran IO

COPYRIGHT

 Copyright (C) 2008-2024 ABINIT group (MG)
 This file is distributed under the terms of the
 GNU General Public License, see ~abinit/COPYING
 or http://www.gnu.org/copyleft/gpl.txt .

SOURCE

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 defs_basis
25 
26  implicit none
27 
28  private
29 
30  public :: get_unit           ! Get a free unit if no argument is specified or report the unit associated to a file name
31  public :: file_exists        ! Return .TRUE. if file exists.
32  public :: delete_file        ! Delete a file if present.
33  public :: is_open            ! .TRUE. if file is open
34  public :: is_connected       ! .TRUE. if file is connected to a logical unit number
35  public :: prompt             ! Simple prompt
36  public :: read_string        ! Read string from unit ignoring blank lines and deleting comments beginning with ! or #
37  public :: flush_unit         ! Wrapper to the intrinsic flush routine, not implemented by every compiler
38  public :: pick_aname         ! Returns the name of a non-existent file to be used for temporary storage.
39  public :: isncfile           ! .TRUE. if we have a NETCDF file.
40  public :: iomode_from_fname  ! Automatic selection of the IO mode based on the file extension.
41  public :: iomode2str         ! Convert iomode to string
42  public :: enforce_fortran_io ! Set the value of enforce_fortran_io__
43  public :: mvrecord           ! Moves forward or backward in a Fortran binary file by nn records.
44  public :: open_file          ! Helper function to open a file in sequential mode with improved error handling.
45  public :: close_unit         ! Helper function to close a Fortran unit with improved error handling.
46  public :: write_lines        ! split a string in lines and output the text to the specified unit
47  public :: lock_and_write     ! Write a string to a file with locking mechanism.
48  public :: num_opened_units   ! Return the number of opened units.
49  public :: show_units         ! Print info on the logical units.
50  public :: write_units        ! Write `string` to a list of Fortran `units`.
51 
52  interface get_unit
53    module procedure get_free_unit
54    module procedure get_unit_from_fname
55  end interface
56 
57  interface is_open
58    module procedure is_open_unit
59    module procedure is_open_fname
60  end interface
61 
62  interface prompt
63    module procedure prompt_int0D
64    module procedure prompt_rdp0D
65    module procedure prompt_string
66    module procedure prompt_int1D
67    module procedure prompt_int2D
68    module procedure prompt_rdp1D
69    module procedure prompt_rdp2D
70  end interface
71 
72   integer,parameter :: MIN_UNIT_NUMBER=10  ! Fortran does not define the range for logical unit numbers (they not be negative)
73 #ifdef FC_NAG
74   integer,parameter :: MAX_UNIT_NUMBER=64    ! There's a serious problem in Nag6.0. In principle
75                                              ! Maximum unit number: 2147483647
76 #else
77   integer,parameter :: MAX_UNIT_NUMBER=1024  ! The following values should be safe
78 #endif
79   integer,parameter :: IO_MAX_LEN=500
80   character(len=1),parameter :: BLANK=' '
81 
82   ! For interactive sessions
83   integer,parameter :: IO_EOT=-1           ! End of transmission i.e CTRL+D
84   !character(len=4),parameter :: PS1='>>> '
85   ! Prepend prompt with `-` to bypass bug in intel18-19 so that flddiff.py will ignore the line
86   character(len=4),parameter :: PS1='->> '
87   character(len=4),parameter :: PS2='??? '
88 
89   integer,parameter :: IO_NO_AVAILABLE_UNIT  =-1   ! No units are available for Fortran I/O
90   integer,parameter :: IO_FILE_NOT_ASSOCIATED=-2   ! File is not associated with any unit
91 
92   ! Enforce IO_MODE_FORTRAN in iomode_from_fname
93   logical,save,protected :: enforce_fortran_io__ = .False.
94 
95 CONTAINS  !===========================================================

m_io_tools/close_unit [ Functions ]

[ Top ] [ m_io_tools ] [ Functions ]

NAME

 close_unit

FUNCTION

  close a Fortran unit
  The main differences wrt the intrinsic close:

    * Function statement that returns the value of iostat
    * Emulate iomsg (F2003)

  See Fortran intrinsic for a more detailed description of the variables

OUTPUT

  iostat=Exit status
  iomsg=Error message

SOURCE

1067 function close_unit(unit,iomsg,status) result(iostat)
1068 
1069 !Arguments ------------------------------------
1070 !scalars
1071  integer,intent(inout) :: unit
1072  character(len=*),optional,intent(in) :: status
1073  character(len=*),intent(out) :: iomsg
1074  integer :: iostat
1075 
1076 !Local variables-------------------------------
1077  character(len=500) :: msg
1078 
1079 ! *************************************************************************
1080 
1081  iomsg = "" ! iomsg is not changed if close succeeds
1082 
1083  if (.not.present(status)) then ! Use Fortran default e.g delete for scratch files.
1084 #ifdef HAVE_FC_IOMSG
1085    close(unit=unit,iostat=iostat,iomsg=iomsg)
1086 #else
1087    close(unit=unit,iostat=iostat)
1088 #endif
1089  else
1090 #ifdef HAVE_FC_IOMSG
1091    close(unit=unit,iostat=iostat,status=status,iomsg=iomsg)
1092 #else
1093    close(unit=unit,iostat=iostat,status=status)
1094 #endif
1095  end if
1096 
1097  ! TODO: Add more info for example the filename.
1098  if (iostat /= 0) then
1099    write(msg,'(2(a,i0),a)')"Fortran close returned iostat ",iostat," while closing unit: ",unit,ch10
1100    iomsg = trim(msg)//ch10//"IOMSG: "//trim(msg)
1101  end if
1102 
1103 end function close_unit

m_io_tools/delete_file [ Functions ]

[ Top ] [ m_io_tools ] [ Functions ]

NAME

  delete_file

FUNCTION

  Delete a file if present.

INPUTS

  fname=The name of the file.

OUTPUT

  ierr=Non-zero value indicates that a problem occured.
   111 = To signal that the file does not exist.
   112 = File exist, is open but no associated unit is found!
   Other values are system-dependent as the value is returned by a open or close
   instruction.

SIDE EFFECTS

  The specified file is deleted.

SOURCE

218 subroutine delete_file(fname, ierr)
219 
220  integer,intent(out) :: ierr
221  character(len=*),intent(in) :: fname
222 
223 !Local variables-------------------------------
224  integer :: tmp_unt
225  logical :: exists
226 ! *********************************************************************
227 
228  ierr = 0
229 
230  inquire(file=fname, exist=exists)
231 
232  if (.not.exists) then
233    ierr = 111
234    !write(std_out,*)" Asked to delete non existent file: ",TRIM(fname)
235    return
236  end if
237 
238  if (is_open_fname(fname)) then
239    tmp_unt = get_unit_from_fname(fname)
240    if (tmp_unt == IO_FILE_NOT_ASSOCIATED) then
241     !write(std_out,*) "File is opened but no associated unit found!"
242     ierr = 112; return
243    end if
244    close(tmp_unt)
245  else
246    tmp_unt = get_unit()
247  end if
248 
249  ! Now close the file.
250  open(unit=tmp_unt, file=trim(fname), status="OLD", iostat=ierr)
251  if (ierr==0) close(unit=tmp_unt, status="DELETE", iostat=ierr)
252 
253 end subroutine delete_file

m_io_tools/enforce_fortran_io [ Functions ]

[ Top ] [ m_io_tools ] [ Functions ]

NAME

 enforce_fortran_io

FUNCTION

  Set the value of the enforce_fortran__ global variable.

SOURCE

866 subroutine enforce_fortran_io(bool)
867 
868 !Arguments ------------------------------------
869 !scalars
870  logical,intent(in) :: bool
871 
872 ! *************************************************************************
873 
874  enforce_fortran_io__ = bool
875 
876 end subroutine enforce_fortran_io

m_io_tools/file_exists [ Functions ]

[ Top ] [ m_io_tools ] [ Functions ]

NAME

  file_exists

FUNCTION

  Return .TRUE. if file `filepath` exists (function version of inquire).

SOURCE

184 logical function file_exists(filepath)
185 
186  character(len=*),intent(in) :: filepath
187 ! *********************************************************************
188 
189  inquire(file=filepath, exist=file_exists)
190 
191 end function file_exists

m_io_tools/flush_unit [ Functions ]

[ Top ] [ m_io_tools ] [ Functions ]

NAME

 flush_unit

FUNCTION

 Wrapper for the standard flush_unit routine

INPUTS

  unit=Fortran logical Unit number

OUTPUT

NOTES

  Available only if the compiler implements this intrinsic procedure.

SOURCE

710 subroutine flush_unit(unit)
711 
712  integer,intent(in) :: unit
713 
714 !Local variables-------------------------------
715  logical :: isopen
716 
717 !************************************************************************
718 
719  if (unit == dev_null) return
720 
721  inquire(unit=unit,opened=isopen)
722 
723 !FLUSH on unconnected unit is illegal: F95 std., 9.3.5.
724 #if defined HAVE_FC_FLUSH
725  if (isopen) call flush(unit)
726 #elif defined HAVE_FC_FLUSH_
727  if (isopen) call flush_(unit)
728 #endif
729 
730 end subroutine flush_unit

m_io_tools/get_unit [ Functions ]

[ Top ] [ m_io_tools ] [ Functions ]

NAME

  get_unit

FUNCTION

  Obtain a logical Fortran unit.
  A free unit is reported if no argument is specified.
  If the file name is supplied, the function reports the unit number
  associated to the file
  Note that GET_UNIT assumes that units 0, 5, 6 (stderr, stdin, std_out)
  are special, and will never return those values.

TODO

   One should define an abinit-specific function with a list of reserved units!

OUTPUT

  The unit number (free unit or unit associated to the file)
  Raises:
   IO_NO_AVAILABLE_UNIT if no logical unit is free (!)
   IO_FILE_NOT_ASSOCIATED if the file is not linked to a logical unit

SOURCE

121 integer function get_free_unit()
122 
123 !Local variables-------------------------------
124  integer :: iunt
125  logical :: isopen
126 ! *********************************************************************
127 
128  do iunt=MAX_UNIT_NUMBER,MIN_UNIT_NUMBER,-1
129    if (any(iunt == [std_err, std_in, std_out])) cycle
130    inquire(unit=iunt, opened=isopen)
131    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

m_io_tools/get_unit_from_fname [ Functions ]

[ Top ] [ m_io_tools ] [ Functions ]

NAME

 get_unit_from_fname

FUNCTION

  Returns the unit number associated to an open file whose name is fname.
  If the file is not connected to an unit number, returns IO_FILE_NOT_ASSOCIATED

INPUTS

OUTPUT

SOURCE

156 integer function get_unit_from_fname(fname)
157 
158 !Arguments ------------------------------------
159  character(len=*),intent(in) :: fname
160 
161 !Local variables-------------------------------
162  integer :: unit
163 ! *********************************************************************
164 
165  inquire(file=fname,number=unit)
166 
167  get_unit_from_fname=unit
168  if (unit==-1) get_unit_from_fname=IO_FILE_NOT_ASSOCIATED
169 
170 end function get_unit_from_fname

m_io_tools/iomode2str [ Functions ]

[ Top ] [ m_io_tools ] [ Functions ]

NAME

 iomode2str

FUNCTION

  Convert iomode to string

SOURCE

890 pure function iomode2str(iomode)
891 
892 !Arguments ------------------------------------
893 !scalars
894  character(len=48) :: iomode2str
895  integer,intent(in) :: iomode
896 
897 ! *************************************************************************
898 
899  select case (iomode)
900  case (IO_MODE_FORTRAN_MASTER)
901    iomode2str = "IO_MODE_FORTRAN_MASTER"
902  case (IO_MODE_FORTRAN)
903    iomode2str = "IO_MODE_FORTRAN"
904  case (IO_MODE_MPI)
905    iomode2str = "IO_MODE_MPI"
906  case (IO_MODE_NETCDF)
907    iomode2str = "IO_MODE_NETCDF"
908  case (IO_MODE_ETSF)
909    iomode2str = "IO_MODE_ETSF"
910  case default
911    iomode2str = "Unknown!"
912  end select
913 
914 end function iomode2str

m_io_tools/iomode_from_fname [ Functions ]

[ Top ] [ m_io_tools ] [ Functions ]

NAME

 iomode_from_fname

FUNCTION

  Automatic selection of the IO mode based on the file extension.

INPUTS

  fname = Name of the file.

NOTES

  if fname has extension '.nc', IO_MODE_ETSF is used
  else:
    IO_MODE_MPI if available
    IO_MODE_FORTRAN if HAVE_MPI_IO is not defined.

SOURCE

832 pure integer function iomode_from_fname(fname) result(iomode)
833 
834 !Arguments ------------------------------------
835 !scalars
836  character(len=*),intent(in) :: fname
837 
838 ! *************************************************************************
839 
840  if (isncfile(fname)) then
841    iomode = IO_MODE_ETSF
842  else
843 #ifdef HAVE_MPI_IO
844    iomode = IO_MODE_MPI
845 #else
846    iomode = IO_MODE_FORTRAN
847 #endif
848 
849    if (enforce_fortran_io__) iomode = IO_MODE_FORTRAN
850  end if
851 
852 end function iomode_from_fname

m_io_tools/is_connected [ Functions ]

[ Top ] [ m_io_tools ] [ Functions ]

NAME

  is_connected

FUNCTION

  Returns .TRUE. if unit is connected to fname.

INPUTS

OUTPUT

SOURCE

271 logical function is_connected(unit, fname)
272 
273  integer,intent(in) :: unit
274  character(len=*),intent(in) :: fname
275 
276 !Local variables-------------------------------
277  integer :: unt_found
278  logical :: isopen
279 ! *********************************************************************
280 
281  inquire(file=fname, number=unt_found, opened=isopen)
282  is_connected=(isopen .and. (unt_found == unit))
283 
284 end function is_connected

m_io_tools/is_open [ Functions ]

[ Top ] [ m_io_tools ] [ Functions ]

NAME

  is_open

FUNCTION

  Returns .TRUE. if unit is associated to an open file.

INPUTS

OUTPUT

SOURCE

302 logical function is_open_unit(unit)
303 
304  integer,intent(in) :: unit
305 ! *********************************************************************
306 
307  inquire(unit=unit, opened=is_open_unit)
308 
309 end function is_open_unit

m_io_tools/is_open_fname [ Functions ]

[ Top ] [ m_io_tools ] [ Functions ]

NAME

  is_open_fname

FUNCTION

  Returns .TRUE. if the file name fname is open.

INPUTS

OUTPUT

SOURCE

327 logical function is_open_fname(fname)
328 
329  character(len=*),intent(in) :: fname
330 ! *********************************************************************
331 
332  inquire(file=fname,opened=is_open_fname)
333 
334 end function is_open_fname

m_io_tools/isncfile [ Functions ]

[ Top ] [ m_io_tools ] [ Functions ]

NAME

 isncfile

FUNCTION

  Return .TRUE. if fname is a NETCDF file.

INPUTS

  fname(len=*)=The name of the file to be tested.

NOTES

  The idea is extremely simple: a NETCDF file terminates with ".nc".
  Obviously this approach is not bulletproof but it will work
  provided that we continue to append the ".nc" string to any NETCDF
  file produced by abinit.

SOURCE

789 pure logical function isncfile(fname)
790 
791 !Arguments ------------------------------------
792 !scalars
793  character(len=*),intent(in) :: fname
794 
795 !Local variables-------------------------------
796 !scalars
797  integer :: ic,nch_trim
798 
799 ! *************************************************************************
800 
801  nch_trim=LEN_TRIM(fname)
802  ic = INDEX (TRIM(fname), ".", back=.TRUE.)
803 
804  isncfile=.FALSE.
805  if (ic >= 1 .and. ic <= nch_trim-1) then ! there is stuff after the .
806    isncfile = (fname(ic+1:nch_trim)=="nc")
807  end if
808 
809 end function isncfile

m_io_tools/lock_and_write [ Functions ]

[ Top ] [ m_io_tools ] [ Functions ]

NAME

  lock_and_write

FUNCTION

  Writes a string to filename with locking mechanism.

INPUTS

  filename: Name of the file.
  string: Input string.
  ierr: Exit status, 0 is string has been written to filename.

SOURCE

1201 subroutine lock_and_write(filename, string, ierr)
1202 
1203  integer,intent(out) :: ierr
1204  character(len=*),intent(in) :: filename,string
1205 
1206 !Local variables-------------------------------
1207  integer :: lock_unit,file_unit
1208  character(len=len(filename) + 5) :: lock
1209  !character(len=500) :: msg
1210 
1211 ! *********************************************************************
1212 
1213  ierr = 0
1214 
1215  ! Try to acquire the lock.
1216  lock = trim(filename)//".lock"
1217  lock_unit = get_unit()
1218  open(unit=lock_unit, file=trim(lock), status='new', err=99)
1219 
1220  file_unit = get_unit()
1221  open(unit=file_unit, file=trim(filename), form="formatted")
1222  call write_lines(file_unit, string, toflush=.true.)
1223  close(lock_unit, status="delete")
1224  close(file_unit)
1225  return
1226 
1227 99 ierr = 1
1228 
1229 end subroutine lock_and_write

m_io_tools/mvrecord [ Functions ]

[ Top ] [ m_io_tools ] [ Functions ]

NAME

 mvrecord

FUNCTION

 This subroutine moves forward or backward in a Fortran binary file by nn records.

INPUTS

 funt= Fortran file unit number
 nrec=number of records

OUTPUT

 ierr=error code

TODO

 One should treat the possible errors of backspace

SOURCE

938 subroutine mvrecord(funt,nrec,ierr)
939 
940 !Arguments ------------------------------------
941 !scalars
942  integer,intent(in) :: funt,nrec
943  integer,intent(out) :: ierr
944 
945 !Local variables-------------------------------
946 !scalars
947  integer :: irec
948 
949 ! *************************************************************************
950 
951  ierr = 0
952  if (nrec > 0) then ! Move forward nrec records
953    do irec=1,nrec
954      read(funt,iostat=ierr)
955      if (ierr /= 0) EXIT
956    end do
957  else if (nrec < 0) then ! Move backward nrec records
958    do irec=1,-nrec
959      backspace (unit=funt,iostat=ierr)
960      if (ierr /= 0) EXIT
961    end do
962  end if
963 
964 end subroutine mvrecord

m_io_tools/num_opened_units [ Functions ]

[ Top ] [ m_io_tools ] [ Functions ]

NAME

  num_opened_units

FUNCTION

  Return the number of opened units.
  Unit numbers listed in the optional argument `ignore` are not considered.

SOURCE

1244 integer function num_opened_units(ignore) result(nn)
1245 
1246 !Arguments ------------------------------------
1247 !scalars
1248  integer,optional,intent(in) :: ignore(:)
1249 
1250 !Local variables-------------------------------
1251  integer :: ii,iostat
1252  logical  :: opened
1253 
1254 ! *********************************************************************
1255 
1256  nn = 0
1257  do ii=0, max_unit_number
1258    if (present(ignore)) then
1259      if (any(ii == ignore)) cycle
1260    end if
1261    inquire(ii, opened=opened, iostat=iostat)
1262    if (iostat == 0 .and. opened) nn = nn + 1
1263  end do
1264 
1265 end function num_opened_units

m_io_tools/open_file [ Functions ]

[ Top ] [ m_io_tools ] [ Functions ]

NAME

 open_file

FUNCTION

  Open a file in sequential mode and associate it to the unit number number.
  The main differences wrt the intrinsic open:

    * Function statement that returns the value of iostat
    * Emulate iomsg (F2003)
    * Accepts either unit (user-specified unit number, input) or
      newunit (free unit not associated to any file, output).
      The two options are mutually exclusive.

  See Fortran intrinsic for a more detailed description of the variables

OUTPUT

  iostat=Exit status
  iomsg=Error message

SOURCE

 991 function open_file(file, iomsg, unit, newunit, access, form, status, action, recl) result(iostat)
 992 
 993 !Arguments ------------------------------------
 994 !scalars
 995  character(len=*),intent(in) :: file
 996  character(len=*),optional,intent(in) :: access,form,status,action
 997  character(len=*),intent(out) :: iomsg
 998  integer,optional,intent(in) :: recl,unit
 999  integer,optional,intent(out) :: newunit
1000  integer :: iostat
1001 
1002 !Local variables-------------------------------
1003 !scalars
1004  character(len=500) :: my_access,my_form,my_status,my_action,msg
1005 
1006 ! *************************************************************************
1007 
1008  my_access = "sequential"; if (present(access)) my_access = access
1009  my_form = "formatted"; if (present(form)) my_form = form
1010  my_status = "unknown"; if (present(status)) my_status = status
1011  my_action = "readwrite"; if (present(action)) my_action = action ! default is system dependent. Enforce RW mode
1012 
1013  iomsg = ""  ! iomsg is not changed if open succeeds
1014 
1015  if (present(unit)) then
1016    if (present(recl)) then
1017      open(file=trim(file),unit=unit,form=my_form,status=my_status,access=my_access,iostat=iostat,recl=recl, iomsg=iomsg)
1018    else
1019      open(file=trim(file),unit=unit,form=my_form,status=my_status,access=my_access,iostat=iostat, iomsg=iomsg)
1020    end if
1021    if (present(newunit)) iostat = -666 ! wrong call
1022 
1023  else if (present(newunit)) then
1024    ! Get free unit (emulate newunit of F2008)
1025    newunit = get_unit()
1026    if (present(recl)) then
1027      open(file=trim(file),unit=newunit,form=my_form,status=my_status,access=my_access,iostat=iostat,recl=recl, iomsg=iomsg)
1028    else
1029      open(file=trim(file),unit=newunit,form=my_form,status=my_status,access=my_access,iostat=iostat, iomsg=iomsg)
1030    end if
1031    if (present(unit)) iostat = -666  ! wrong call
1032 
1033  else
1034    iomsg = "Either unit or newunit must be specified"
1035    iostat = -1
1036  end if
1037 
1038  if (iostat /= 0) then
1039    write(msg, "(a,i0,2a)")"Fortran open returned iostat: ",iostat," while opening file: "//trim(file)
1040    iomsg = trim(msg)//ch10//"Runtime error message: "//trim(iomsg)
1041  end if
1042 
1043 end function open_file

m_io_tools/pick_aname [ Functions ]

[ Top ] [ m_io_tools ] [ Functions ]

NAME

  pick_aname

FUNCTION

  Returns the name of a non-existent file to be used for temporary storage.

SOURCE

744 function pick_aname() result(aname)
745 
746  character(len=fnlen) :: aname
747 
748 !Local variables-------------------------------
749  integer :: ii,spt,ept
750  real(dp) :: xrand(fnlen)
751 !************************************************************************
752 
753  aname="__TMP_FILE__"
754 
755  spt=LEN(aname); ept=spt
756 
757  do while (file_exists(aname))
758    call RANDOM_NUMBER(xrand(spt:ept))
759    xrand(spt:ept) = 64+xrand(spt:ept)*26
760    do ii=spt,ept
761      aname(ii:ii) = ACHAR(NINT(xrand(ii)))
762    end do
763    ept = MIN(ept+1,fnlen)
764  end do
765 
766 end function pick_aname

m_io_tools/prompt_exit [ Functions ]

[ Top ] [ m_io_tools ] [ Functions ]

NAME

  prompt_exit

FUNCTION

  A primitive prompt. Writes msg on std_out and reads the value entered by the user.

INPUTS

OUTPUT

SOURCE

630 subroutine prompt_exit()
631 
632  integer,parameter :: NASK=5
633  integer :: ios,iask
634  character(len=IO_MAX_LEN) :: ans
635 ! *********************************************************************
636 
637  write(std_out,*)
638  ios=-1 ; iask=0
639  do while (ios/=0.or.(ans/='y'.or.ans/='n'))
640    iask=iask+1
641    write(std_out,'(a)')' Do you really want to exit (y/n)? '
642    call flush_unit(std_out)
643    read(std_in,*,IOSTAT=ios)ans
644    if (ans=='y'.or.iask>NASK) STOP
645    if (ans=='n') RETURN
646  end do
647 
648 end subroutine prompt_exit

m_io_tools/prompt_int0D [ Functions ]

[ Top ] [ m_io_tools ] [ Functions ]

NAME

  prompt_int0D

FUNCTION

  A primitive prompt. Writes msg on std_out and reads the value entered by the user.

INPUTS

OUTPUT

SOURCE

352 subroutine prompt_int0D(msg,ivalue)
353 
354  character(len=*),intent(in) :: msg
355  integer,intent(out) :: ivalue
356 
357 !Local variables-------------------------------
358  integer :: ios
359  character(len=4) :: PS
360 ! *********************************************************************
361 
362  ios=-1 ; PS=PS1
363  do while (ios/=0)
364   write(std_out,'(a)',ADVANCE='NO')PS//TRIM(msg)//BLANK
365   call flush_unit(std_out)
366   read(std_in,*,IOSTAT=ios)ivalue
367   if (ios==IO_EOT) call prompt_exit()
368   PS=PS2
369  end do
370  write(std_out,*)
371 
372 end subroutine prompt_int0D

m_io_tools/prompt_int1D [ Functions ]

[ Top ] [ m_io_tools ] [ Functions ]

NAME

  prompt_int1D

FUNCTION

  A primitive prompt. Writes msg on std_out and reads the value entered by the user.

INPUTS

OUTPUT

SOURCE

477 subroutine prompt_int1D(msg,ivect)
478 
479 !Arguments ------------------------------------
480  character(len=*),intent(in) :: msg
481  integer,intent(out) :: ivect(:)
482 
483 !Local variables-------------------------------
484  integer :: ios
485  character(len=4) :: PS
486 ! *********************************************************************
487 
488  ios=-1 ; PS=PS1
489  do while (ios/=0)
490    write(std_out,'(a)',ADVANCE='NO')PS//TRIM(msg)//BLANK
491    call flush_unit(std_out)
492    read(std_in,*,IOSTAT=ios)ivect(:)
493    if (ios==IO_EOT) call prompt_exit()
494    PS=PS2
495  end do
496  write(std_out,*)
497 
498 end subroutine prompt_int1D

m_io_tools/prompt_int2D [ Functions ]

[ Top ] [ m_io_tools ] [ Functions ]

NAME

  prompt_int2d

FUNCTION

  A primitive prompt. Writes msg on std_out and reads the value entered by the user.

INPUTS

OUTPUT

SOURCE

516 subroutine prompt_int2D(msg,iarr)
517 
518  character(len=*),intent(in) :: msg
519  integer,intent(out) :: iarr(:,:)
520 
521 !Local variables-------------------------------
522  integer :: ios
523  character(len=4) :: PS
524 ! *********************************************************************
525 
526  ios=-1 ; PS=PS1
527  do while (ios/=0)
528    write(std_out,'(a)',ADVANCE='NO')PS//TRIM(msg)//BLANK
529    call flush_unit(std_out)
530    read(std_in,*,IOSTAT=ios)iarr(:,:)
531    if (ios==IO_EOT) call prompt_exit()
532    PS=PS2
533  end do
534  write(std_out,*)
535 
536 end subroutine prompt_int2D

m_io_tools/prompt_rdp0d [ Functions ]

[ Top ] [ m_io_tools ] [ Functions ]

NAME

  prompt_rdp0d

FUNCTION

  A primitive prompt. Writes msg on std_out and reads the value entered by the user.

INPUTS

OUTPUT

SOURCE

390 subroutine prompt_rdp0D(msg,rvalue)
391 
392  character(len=*),intent(in) :: msg
393  real(dp),intent(out) :: rvalue
394 
395 !Local variables-------------------------------
396  integer :: ios
397  character(len=4) :: PS
398 ! *********************************************************************
399 
400  ios=-1 ; PS=PS1
401  do while (ios/=0)
402   write(std_out,'(a)',ADVANCE='NO')PS//TRIM(msg)//BLANK
403   call flush_unit(std_out)
404   read(std_in,*,IOSTAT=ios)rvalue
405   if (ios==IO_EOT) call prompt_exit()
406   PS=PS2
407  end do
408  write(std_out,*)
409 
410 end subroutine prompt_rdp0D

m_io_tools/prompt_rdp1D [ Functions ]

[ Top ] [ m_io_tools ] [ Functions ]

NAME

  prompt_rdp1D

FUNCTION

  A primitive prompt. Writes msg on std_out and reads the value entered by the user.

INPUTS

OUTPUT

SOURCE

554 subroutine prompt_rdp1D(msg,rvect)
555 
556 !Arguments ------------------------------------
557  character(len=*),intent(in) :: msg
558  real(dp),intent(out) :: rvect(:)
559  character(len=4) :: PS
560 !Local variables-------------------------------
561  integer :: ios
562 ! *********************************************************************
563 
564  ios=-1 ; PS=PS1
565  do while (ios/=0)
566    write(std_out,'(a)',ADVANCE='NO')PS//TRIM(msg)//BLANK
567    call flush_unit(std_out)
568    read(std_in,*,IOSTAT=ios)rvect(:)
569    if (ios==IO_EOT) call prompt_exit()
570    PS=PS2
571  end do
572  write(std_out,*)
573 
574 end subroutine prompt_rdp1D

m_io_tools/prompt_rdp2D [ Functions ]

[ Top ] [ m_io_tools ] [ Functions ]

NAME

  prompt_rdp2D

FUNCTION

  A primitive prompt. Writes msg on std_out and reads the value entered by the user.

INPUTS

OUTPUT

SOURCE

592 subroutine prompt_rdp2D(msg,rarr)
593 
594  character(len=*),intent(in) :: msg
595  real(dp),intent(out) :: rarr(:,:)
596 
597 !Local variables-------------------------------
598  integer :: ios
599  character(len=4) :: PS
600 ! *********************************************************************
601 
602  ios=-1 ; PS=PS1
603  do while (ios/=0)
604    write(std_out,'(a)',ADVANCE='NO')PS//TRIM(msg)//BLANK
605    call flush_unit(std_out)
606    read(std_in,*,IOSTAT=ios)rarr(:,:)
607    if (ios==IO_EOT) call prompt_exit()
608    PS=PS2
609  end do
610  write(std_out,*)
611 
612 end subroutine prompt_rdp2D

m_io_tools/prompt_string [ Functions ]

[ Top ] [ m_io_tools ] [ Functions ]

NAME

  prompt_string

FUNCTION

  A primitive prompt. Writes msg on std_out and reads the value entered by the user.
  If strip_comment is True (default), all the characters after "#" or "!" are ignored.

INPUTS

OUTPUT

SOURCE

429 subroutine prompt_string(msg,string,strip_comment)
430 
431  character(len=*),intent(in) :: msg
432  logical,optional,intent(in) :: strip_comment
433  character(len=*),intent(out) :: string
434 
435 !Local variables-------------------------------
436  integer :: ios,ic
437  logical :: do_strip
438  character(len=4) :: PS
439  !character(len=len(string)) :: tmps
440 ! *********************************************************************
441 
442  do_strip = .True.; if (present(strip_comment)) do_strip = strip_comment
443 
444  ios=-1 ; PS=PS1
445  do while (ios/=0)
446    write(std_out,'(a)',ADVANCE='NO')PS//TRIM(msg)//BLANK
447    call flush_unit(std_out)
448    read(std_in,'(a)',IOSTAT=ios)string
449    if (ios==IO_EOT) call prompt_exit()
450    PS=PS2
451  end do
452  write(std_out,*)
453 
454  if (do_strip) then
455    ic = INDEX(string, "#"); if (ic /= 0) string(:) = string(:ic-1)
456    ic = INDEX(string, "!"); if (ic /= 0) string(:) = string(:ic-1)
457  end if
458 
459 end subroutine prompt_string

m_io_tools/read_string [ Functions ]

[ Top ] [ m_io_tools ] [ Functions ]

NAME

  read_string

FUNCTION

  Reads string from unit=std_in_ or unit if specified, ignoring blank lines
  and deleting comments beginning with `!`. Return exit code.

INPUTS

OUTPUT

SOURCE

667 integer function read_string(string, unit) result(ios)
668 
669  character(len=*),intent(out):: string
670  integer,optional,intent(in) :: unit
671 
672 !Local variables-------------------------------
673  integer :: ipos,unt
674 ! *********************************************************************
675 
676  unt=std_in; if (present(unit)) unt=unit
677 
678  read(unt,'(a)', iostat=ios) string  ! read input line
679  if (ios/=0) return
680  string = ADJUSTL(string)
681 
682  ! Ignore portion after comments
683  ipos = INDEX(string, "!")
684  if (ipos /= 0) string=string(:ipos-1)
685  ipos = INDEX(string, "#")
686  if (ipos /= 0) string=string(:ipos-1)
687 
688 end function read_string

m_io_tools/show_units [ Functions ]

[ Top ] [ m_io_tools ] [ Functions ]

NAME

  show_units

FUNCTION

  Print info on the logical units

SOURCE

1279 subroutine show_units(ount)
1280 
1281 !Arguments ------------------------------------
1282 !scalars
1283  integer,intent(in) :: ount
1284 
1285 !Local variables-------------------------------
1286  integer :: ii,iostat
1287  logical  :: named, opened
1288  character(len=fnlen) :: filename,form
1289 
1290 ! *********************************************************************
1291 
1292  write(ount,'(a)') '******** Fortran Logical Units ********'
1293 
1294  do ii=0,max_unit_number
1295    inquire(ii, opened=opened, named=named, name=filename, form=form, iostat=iostat)
1296    if (iostat == 0) then
1297       if (opened) then
1298          if (named) then
1299             write(ount,*)"unit: ", ii, "form: ", trim(form), ", filename: ", trim(filename)
1300          else
1301             write(ount,*)"unit: ", ii, "form: ",form, ', No name available'
1302          endif
1303       else
1304         !write(ount,*)"unit: ", ii, " is not opened"
1305       endif
1306    else
1307       write(ount,*)" unit: ", ii, ' Iostat error'
1308    endif
1309  end do
1310 
1311 end subroutine show_units

m_io_tools/write_lines [ Functions ]

[ Top ] [ m_io_tools ] [ Functions ]

NAME

  write_lines

FUNCTION

  This routine receives a string, split the message in lines according to the
  ch10 character and output the text to the specified unit

INPUTS

  unit=unit number for writing
  message=(character(len=*)) message to be written
  [toflush]=flag to activate immediate flush of the I/O buffer (default=FALSE)

OUTPUT

  Only writing.

SOURCE

1126 subroutine write_lines(unit,message,toflush)
1127 
1128 !Arguments ------------------------------------
1129 !scalars
1130  integer,intent(in) :: unit
1131  logical,intent(in),optional :: toflush
1132  character(len=*),intent(in) :: message
1133 
1134 !Local variables-------------------------------
1135 !scalars
1136  integer :: msg_size,ii,jj,rtnpos
1137  logical :: toflush_
1138 
1139 !******************************************************************
1140 
1141  msg_size = len_trim(message)
1142  toflush_=.false.;if (present(toflush)) toflush_=toflush
1143 
1144  if (msg_size == 0) then
1145    write(unit,*)
1146    return
1147  end if
1148 
1149  ! Here, split the message, according to the char(10) characters (carriage return).
1150  ! This technique is portable accross different OS.
1151  rtnpos = index(message,ch10)
1152 
1153  if (rtnpos == 0) then
1154    write(unit,"(a)")message(1:msg_size)
1155    if (toflush_) call flush_unit(unit)
1156    return
1157  end if
1158 
1159  ii = 1; jj = rtnpos
1160  do
1161    if (ii == jj) then
1162      write(unit,*)
1163      if (toflush_) call flush_unit(unit)
1164    else
1165      write(unit, '(a)' ) message(ii:jj-1)
1166      if (toflush_) call flush_unit(unit)
1167    end if
1168    ii = jj + 1
1169    if (ii > msg_size) exit
1170    jj = index(message(ii:msg_size),ch10)
1171    if (jj == 0) then
1172      ! Will write the last line at the next iteration and exit .
1173      jj = msg_size + 1
1174    else
1175      jj = jj + ii - 1
1176    end if
1177    !write(*,*)"ii, jj, msg_size",ii, jj, msg_size
1178  end do
1179 
1180  ! This is needed to preserve the od behaviour: a ch10 at the
1181  ! end of the string was causing an extra newline!
1182  if (message(msg_size:msg_size) == ch10) write(unit,*)
1183 
1184 end subroutine write_lines

m_io_tools/write_units [ Functions ]

[ Top ] [ m_io_tools ] [ Functions ]

NAME

  write_units

FUNCTION

  Write `string` to a list of Fortran `units`.
  This function is supposed to be faster than wrtout as there's no check on the MPI rank.
  This also means that this procedure should be called by a single MPI proc.

INPUTS

  [newlines]: Number of newlines added after string. Default 0
  [pre_newlines]: Number of newlines added before string. Default 0

SOURCE

1329 subroutine write_units(units, string, newlines, pre_newlines)
1330 
1331 !Arguments ------------------------------------
1332  character(len=*),intent(in) :: string
1333  integer,intent(in) :: units(:)
1334  integer,optional,intent(in) :: newlines, pre_newlines
1335 
1336 !Local variables-------------------------------
1337  integer :: ii, unt
1338 ! *************************************************************************
1339 
1340  do unt=1,size(units)
1341    if (present(pre_newlines)) then
1342      do ii=1,pre_newlines
1343        write(units(unt), "(a)") " "
1344      end do
1345    end if
1346    write(units(unt), "(a)") trim(string)
1347    if (present(newlines)) then
1348      do ii=1,newlines
1349        write(units(unt), "(a)") " "
1350      end do
1351    end if
1352  end do
1353 
1354 end subroutine write_units