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-2018 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 .

PARENTS

CHILDREN

SOURCE

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

PARENTS

SOURCE

1337 function close_unit(unit,iomsg,status) result(iostat)
1338 
1339 
1340 !This section has been created automatically by the script Abilint (TD).
1341 !Do not modify the following lines by hand.
1342 #undef ABI_FUNC
1343 #define ABI_FUNC 'close_unit'
1344 !End of the abilint section
1345 
1346  implicit none
1347 
1348 !Arguments ------------------------------------
1349 !scalars
1350  integer,intent(inout) :: unit
1351  character(len=*),optional,intent(in) :: status
1352  character(len=*),intent(out) :: iomsg
1353  integer :: iostat
1354 
1355 !Local variables-------------------------------
1356  character(len=500) :: msg
1357 
1358 ! *************************************************************************
1359 
1360  iomsg = "" ! iomsg is not changed if close succeeds
1361 
1362  if (.not.present(status)) then ! Use Fortran default e.g delete for scratch files.
1363 #ifdef HAVE_FC_IOMSG
1364    close(unit=unit,iostat=iostat,iomsg=iomsg)
1365 #else
1366    close(unit=unit,iostat=iostat)
1367 #endif
1368  else
1369 #ifdef HAVE_FC_IOMSG
1370    close(unit=unit,iostat=iostat,status=status,iomsg=iomsg)
1371 #else
1372    close(unit=unit,iostat=iostat,status=status)
1373 #endif
1374  end if
1375 
1376  ! TODO: Add more info for example the filename.
1377  if (iostat /= 0) then
1378    write(msg,'(2(a,i0),a)')"Fortran close returned iostat ",iostat," while closing unit: ",unit,ch10
1379    iomsg = trim(msg)//ch10//"IOMSG: "//trim(msg)
1380  end if
1381 
1382 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.

PARENTS

      abinit,ioprof,m_io_redirect,m_nctk,m_wfk,mlwfovlp

CHILDREN

SOURCE

272 subroutine delete_file(fname,ierr)
273 
274 
275 !This section has been created automatically by the script Abilint (TD).
276 !Do not modify the following lines by hand.
277 #undef ABI_FUNC
278 #define ABI_FUNC 'delete_file'
279 !End of the abilint section
280 
281  integer,intent(out) :: ierr
282  character(len=*),intent(in) :: fname
283 
284 !Local variables-------------------------------
285  integer :: tmp_unt
286  logical :: exists
287 ! *********************************************************************
288 
289  ierr=0
290 
291  inquire(file=fname,exist=exists)
292 
293  if (.not.exists) then
294    ierr=111
295    write(std_out,*)" Asked to delete not existent file: ",TRIM(fname)
296    RETURN
297  end if
298 
299  if (is_open_fname(fname)) then
300    tmp_unt = get_unit_from_fname(fname)
301    if ( tmp_unt == IO_FILE_NOT_ASSOCIATED ) then
302     write(std_out,*) "File is opened but no associated unit found!"
303     ierr=112
304     RETURN
305    end if
306    close(tmp_unt)
307  else
308    tmp_unt = get_unit()
309  end if
310 
311  ! Now close the file.
312  open(unit=tmp_unt,file=trim(fname),status="OLD",iostat=ierr)
313  if (ierr==0) close(unit=tmp_unt,status="DELETE",iostat=ierr)
314 
315 end subroutine delete_file

m_io_tools/file_exists [ Functions ]

[ Top ] [ m_io_tools ] [ Functions ]

NAME

  file_exists

FUNCTION

  Return .TRUE. if file existent (function version of inquire).

INPUTS

  fname=The name of the file.

PARENTS

SOURCE

225 logical function file_exists(fname)
226 
227 
228 !This section has been created automatically by the script Abilint (TD).
229 !Do not modify the following lines by hand.
230 #undef ABI_FUNC
231 #define ABI_FUNC 'file_exists'
232 !End of the abilint section
233 
234  character(len=*),intent(in) :: fname
235 
236 ! *********************************************************************
237 
238  inquire(file=fname,exist=file_exists)
239 
240 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.

PARENTS

      abinit,anaddb,bsepostproc,cchi0,cchi0q0,cut3d,fftprof,impurity_solve
      m_errors,m_hdr,m_io_redirect,m_io_tools,m_matlu,m_shirley,m_xc_vdw
      mrggkk,mrgscr,multibinit,optic,pawmkaewf,prep_calc_ucrpa,qmc_prep_ctqmc
      scprqt,vdw_kernelgen,vtorho,wrtout

CHILDREN

SOURCE

924 subroutine flush_unit(unit)
925 
926 
927 !This section has been created automatically by the script Abilint (TD).
928 !Do not modify the following lines by hand.
929 #undef ABI_FUNC
930 #define ABI_FUNC 'flush_unit'
931 !End of the abilint section
932 
933  integer,intent(in) :: unit
934 
935 !Local variables-------------------------------
936  logical :: isopen
937 
938 !************************************************************************
939 
940  if (unit == dev_null) return
941 
942  inquire(unit=unit,opened=isopen)
943 
944 !FLUSH on unconnected unit is illegal: F95 std., 9.3.5.
945 #if defined HAVE_FC_FLUSH
946  if (isopen) then
947    call flush(unit)
948  endif
949 #elif defined HAVE_FC_FLUSH_
950  if (isopen) then
951    call flush_(unit)
952   end if
953 #endif
954 
955 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

PARENTS

SOURCE

125 integer function get_free_unit()
126 
127 
128 !This section has been created automatically by the script Abilint (TD).
129 !Do not modify the following lines by hand.
130 #undef ABI_FUNC
131 #define ABI_FUNC 'get_free_unit'
132 !End of the abilint section
133 
134  implicit none
135 
136 !This section has been created automatically by the script Abilint (TD).
137 !Do not modify the following lines by hand.
138 #undef ABI_FUNC
139 #define ABI_FUNC 'get_free_unit'
140 !End of the abilint section
141 
142 !Local variables-------------------------------
143  integer :: iunt
144  logical :: isopen
145 ! *********************************************************************
146 
147  do iunt=MAX_UNIT_NUMBER,MIN_UNIT_NUMBER,-1
148    if (any(iunt == [std_err, std_in, std_out])) cycle
149    inquire(unit=iunt, opened=isopen)
150    if (.not.isopen) then
151       get_free_unit = iunt; return
152    end if
153  end do
154  get_free_unit = IO_NO_AVAILABLE_UNIT
155 
156 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

PARENTS

SOURCE

177 integer function get_unit_from_fname(fname)
178 
179 
180 !This section has been created automatically by the script Abilint (TD).
181 !Do not modify the following lines by hand.
182 #undef ABI_FUNC
183 #define ABI_FUNC 'get_unit_from_fname'
184 !End of the abilint section
185 
186  implicit none
187 
188 !This section has been created automatically by the script Abilint (TD).
189 !Do not modify the following lines by hand.
190 #undef ABI_FUNC
191 #define ABI_FUNC 'get_unit_from_fname'
192 !End of the abilint section
193 
194 !Arguments ------------------------------------
195  character(len=*),intent(in) :: fname
196 
197 !Local variables-------------------------------
198  integer :: unit
199 ! *********************************************************************
200 
201  inquire(file=fname,number=unit)
202 
203  get_unit_from_fname=unit
204  if (unit==-1) get_unit_from_fname=IO_FILE_NOT_ASSOCIATED
205 
206 end function get_unit_from_fname

m_io_tools/iomode2str [ Functions ]

[ Top ] [ m_io_tools ] [ Functions ]

NAME

 iomode2str

FUNCTION

  Convert iomode to string 

PARENTS

SOURCE

1124 pure function iomode2str(iomode) 
1125 
1126 
1127 !This section has been created automatically by the script Abilint (TD).
1128 !Do not modify the following lines by hand.
1129 #undef ABI_FUNC
1130 #define ABI_FUNC 'iomode2str'
1131 !End of the abilint section
1132 
1133  implicit none
1134 
1135 !Arguments ------------------------------------
1136 !scalars
1137  character(len=48) :: iomode2str
1138  integer,intent(in) :: iomode
1139 
1140 ! *************************************************************************
1141 
1142  select case (iomode)
1143  case (IO_MODE_FORTRAN_MASTER)
1144    iomode2str = "IO_MODE_FORTRAN_MASTER"
1145  case (IO_MODE_FORTRAN)
1146    iomode2str = "IO_MODE_FORTRAN"
1147  case (IO_MODE_MPI)
1148    iomode2str = "IO_MODE_MPI"
1149  case (IO_MODE_NETCDF)
1150    iomode2str = "IO_MODE_NETCDF"
1151  case (IO_MODE_ETSF)
1152    iomode2str = "IO_MODE_ETSF"
1153  case default
1154    iomode2str = "Unknown!"
1155  end select
1156 
1157 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.

PARENTS

SOURCE

1079 pure function iomode_from_fname(fname) result(iomode)
1080 
1081 
1082 !This section has been created automatically by the script Abilint (TD).
1083 !Do not modify the following lines by hand.
1084 #undef ABI_FUNC
1085 #define ABI_FUNC 'iomode_from_fname'
1086 !End of the abilint section
1087 
1088  implicit none
1089 
1090 !Arguments ------------------------------------
1091 !scalars
1092  character(len=*),intent(in) :: fname
1093  integer :: iomode
1094 
1095 ! *************************************************************************
1096 
1097  if (isncfile(fname)) then
1098    iomode = IO_MODE_ETSF
1099  else
1100 #ifdef HAVE_MPI_IO
1101    iomode = IO_MODE_MPI  
1102 #else
1103    iomode = IO_MODE_FORTRAN
1104 #endif
1105    !if (IO_MODE_DEFAULT /= -1) iomode = IO_MODE_DEFAULT
1106  end if
1107 
1108 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

PARENTS

SOURCE

335 logical function is_connected(unit,fname)
336 
337 
338 !This section has been created automatically by the script Abilint (TD).
339 !Do not modify the following lines by hand.
340 #undef ABI_FUNC
341 #define ABI_FUNC 'is_connected'
342 !End of the abilint section
343 
344  integer,intent(in) :: unit
345  character(len=*),intent(in) :: fname
346 
347 !Local variables-------------------------------
348  integer :: unt_found
349  logical :: isopen
350 ! *********************************************************************
351 
352  inquire(file=fname,number=unt_found,opened=isopen)
353  is_connected=(isopen.and.(unt_found==unit))
354 
355 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

PARENTS

SOURCE

375 logical function is_open_unit(unit)
376 
377 
378 !This section has been created automatically by the script Abilint (TD).
379 !Do not modify the following lines by hand.
380 #undef ABI_FUNC
381 #define ABI_FUNC 'is_open_unit'
382 !End of the abilint section
383 
384  integer,intent(in) :: unit
385 ! *********************************************************************
386 
387  inquire(unit=unit,opened=is_open_unit)
388 
389 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

PARENTS

SOURCE

409 logical function is_open_fname(fname)
410 
411 
412 !This section has been created automatically by the script Abilint (TD).
413 !Do not modify the following lines by hand.
414 #undef ABI_FUNC
415 #define ABI_FUNC 'is_open_fname'
416 !End of the abilint section
417 
418  character(len=*),intent(in) :: fname
419 ! *********************************************************************
420 
421  inquire(file=fname,opened=is_open_fname)
422 
423 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.

PARENTS

SOURCE

1025 pure logical function isncfile(fname)
1026 
1027 
1028 !This section has been created automatically by the script Abilint (TD).
1029 !Do not modify the following lines by hand.
1030 #undef ABI_FUNC
1031 #define ABI_FUNC 'isncfile'
1032 !End of the abilint section
1033 
1034  implicit none
1035 
1036 !Arguments ------------------------------------
1037 !scalars
1038  character(len=*),intent(in) :: fname
1039 
1040 !Local variables-------------------------------
1041 !scalars
1042  integer :: ic,nch_trim
1043 
1044 ! *************************************************************************
1045 
1046  nch_trim=LEN_TRIM(fname)
1047  ic = INDEX (TRIM(fname), ".", back=.TRUE.)
1048 
1049  isncfile=.FALSE.
1050  if (ic >= 1 .and. ic <= nch_trim-1) then ! there is stuff after the .
1051    isncfile = (fname(ic+1:nch_trim)=="nc")
1052  end if
1053 
1054 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.

PARENTS

      m_errors

CHILDREN

SOURCE

1492 subroutine lock_and_write(filename, string, ierr)
1493 
1494 
1495 !This section has been created automatically by the script Abilint (TD).
1496 !Do not modify the following lines by hand.
1497 #undef ABI_FUNC
1498 #define ABI_FUNC 'lock_and_write'
1499 !End of the abilint section
1500 
1501  integer,intent(out) :: ierr
1502  character(len=*),intent(in) :: filename,string
1503 
1504 !Local variables-------------------------------
1505  integer :: lock_unit,file_unit
1506  character(len=len(filename) + 5) :: lock
1507  !character(len=500) :: msg
1508 
1509 ! *********************************************************************
1510 
1511  ierr = 0
1512 
1513  ! Try to acquire the lock.
1514  lock = trim(filename)//".lock"
1515  lock_unit = get_unit()
1516  open(unit=lock_unit, file=trim(lock), status='new', err=99)
1517 
1518  file_unit = get_unit()
1519  open(unit=file_unit, file=trim(filename), form="formatted")
1520  call write_lines(file_unit, string)
1521  close(lock_unit, status="delete")
1522  close(file_unit)
1523  return 
1524 
1525 99 ierr = 1
1526 
1527 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

PARENTS

      m_wffile,m_wfk

CHILDREN

SOURCE

1186 subroutine mvrecord(funt,nrec,ierr)
1187 
1188 
1189 !This section has been created automatically by the script Abilint (TD).
1190 !Do not modify the following lines by hand.
1191 #undef ABI_FUNC
1192 #define ABI_FUNC 'mvrecord'
1193 !End of the abilint section
1194 
1195  implicit none
1196 
1197 !Arguments ------------------------------------
1198 !scalars
1199  integer,intent(in) :: funt,nrec
1200  integer,intent(out) :: ierr
1201 
1202 !Local variables-------------------------------
1203 !scalars
1204  integer :: irec
1205 
1206 ! *************************************************************************
1207 
1208  ierr = 0
1209  if (nrec > 0) then ! Move forward nrec records
1210    do irec=1,nrec
1211      read(funt,iostat=ierr)
1212      if (ierr /= 0) EXIT
1213    end do
1214  else if (nrec < 0) then ! Move backward nrec records
1215    do irec=1,-nrec
1216      backspace (unit=funt,iostat=ierr)
1217      if (ierr /= 0) EXIT
1218    end do
1219  end if
1220 
1221 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.

PARENTS

CHILDREN

SOURCE

1546 integer function num_opened_units(ignore) result(nn)
1547 
1548 
1549 !This section has been created automatically by the script Abilint (TD).
1550 !Do not modify the following lines by hand.
1551 #undef ABI_FUNC
1552 #define ABI_FUNC 'num_opened_units'
1553 !End of the abilint section
1554 
1555  implicit none
1556 
1557 !This section has been created automatically by the script Abilint (TD).
1558 !Do not modify the following lines by hand.
1559 #undef ABI_FUNC
1560 #define ABI_FUNC 'show_units'
1561 !End of the abilint section
1562 
1563 !Arguments ------------------------------------
1564 !scalars
1565  integer,optional,intent(in) :: ignore(:)
1566 
1567 !Local variables-------------------------------
1568  integer :: ii,iostat
1569  logical  :: opened
1570 
1571 ! *********************************************************************
1572 
1573  nn = 0
1574  do ii=0, max_unit_number
1575    if (present(ignore)) then
1576      if (any(ii == ignore)) cycle
1577    end if
1578    inquire(ii, opened=opened, iostat=iostat)
1579    if (iostat == 0 .and. opened) nn = nn + 1
1580  end do
1581 
1582 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

PARENTS

SOURCE

1250 function open_file(file,iomsg,unit,newunit,access,form,status,action,recl) result(iostat)
1251 
1252 
1253 !This section has been created automatically by the script Abilint (TD).
1254 !Do not modify the following lines by hand.
1255 #undef ABI_FUNC
1256 #define ABI_FUNC 'open_file'
1257 !End of the abilint section
1258 
1259  implicit none
1260 
1261 !Arguments ------------------------------------
1262 !scalars
1263  character(len=*),intent(in) :: file
1264  character(len=*),optional,intent(in) :: access,form,status,action
1265  character(len=*),intent(out) :: iomsg
1266  integer,optional,intent(in) :: recl,unit
1267  integer,optional,intent(out) :: newunit
1268  integer :: iostat
1269 
1270 !Local variables-------------------------------
1271 !scalars
1272  character(len=500) :: my_access,my_form,my_status,my_action,msg
1273 
1274 ! *************************************************************************
1275 
1276  my_access = "sequential"; if (present(access)) my_access = access
1277  my_form = "formatted"; if (present(form)) my_form = form
1278  my_status = "unknown"; if (present(status)) my_status = status
1279  my_action = "readwrite"; if (present(action)) my_action = action ! default is system dependent. Enforce RW mode
1280 
1281  iomsg = ""  ! iomsg is not changed if open succeeds
1282 
1283  if (present(unit)) then
1284    if (present(recl)) then
1285      open(file=trim(file),unit=unit,form=my_form,status=my_status,access=my_access,iostat=iostat,recl=recl, iomsg=iomsg)
1286    else
1287      open(file=trim(file),unit=unit,form=my_form,status=my_status,access=my_access,iostat=iostat, iomsg=iomsg)
1288    end if
1289    if (present(newunit)) iostat = -666 ! wrong call
1290 
1291  else if (present(newunit)) then
1292    ! Get free unit (emulate newunit of F2008)
1293    newunit = get_unit()
1294    if (present(recl)) then
1295      open(file=trim(file),unit=newunit,form=my_form,status=my_status,access=my_access,iostat=iostat,recl=recl, iomsg=iomsg)
1296    else
1297      open(file=trim(file),unit=newunit,form=my_form,status=my_status,access=my_access,iostat=iostat, iomsg=iomsg)
1298    end if
1299    if (present(unit)) iostat = -666  ! wrong call
1300 
1301  else 
1302    iomsg = "Either unit or newunit must be specified"
1303    iostat = -1
1304  end if
1305 
1306  if (iostat /= 0) then
1307    write(msg, "(a,i0,2a)")"Fortran open returned iostat ",iostat," while opening: "//trim(file)
1308    iomsg = trim(msg)//ch10//"IOMSG: "//trim(iomsg)
1309  end if
1310 
1311 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.

PARENTS

SOURCE

 971 function pick_aname() result(aname)
 972 
 973 
 974 !This section has been created automatically by the script Abilint (TD).
 975 !Do not modify the following lines by hand.
 976 #undef ABI_FUNC
 977 #define ABI_FUNC 'pick_aname'
 978 !End of the abilint section
 979 
 980  character(len=fnlen) :: aname
 981 
 982 !Local variables-------------------------------
 983  integer :: ii,spt,ept
 984  real(dp) :: xrand(fnlen)
 985 !************************************************************************
 986 
 987  aname="__TMP_FILE__"
 988 
 989  spt=LEN(aname); ept=spt
 990 
 991  do while (file_exists(aname))
 992    call RANDOM_NUMBER(xrand(spt:ept))
 993    xrand(spt:ept) = 64+xrand(spt:ept)*26
 994    do ii=spt,ept
 995      aname(ii:ii) = ACHAR(NINT(xrand(ii)))
 996    end do
 997    ept = MIN(ept+1,fnlen)
 998  end do
 999 
1000 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 STDOUT and reads the value entered by the user.

INPUTS

OUTPUT

PARENTS

      m_io_tools

CHILDREN

SOURCE

818 subroutine prompt_exit()
819 
820 
821 !This section has been created automatically by the script Abilint (TD).
822 !Do not modify the following lines by hand.
823 #undef ABI_FUNC
824 #define ABI_FUNC 'prompt_exit'
825 !End of the abilint section
826 
827  integer,parameter :: NASK=5
828  integer :: ios,iask
829  character(len=IO_MAX_LEN) :: ans
830 ! *********************************************************************
831 
832  write(STDOUT,*)
833  ios=-1 ; iask=0
834  do while (ios/=0.or.(ans/='y'.or.ans/='n'))
835    iask=iask+1
836    write(STDOUT,'(a)')' Do you really want to exit (y/n)? '
837    call flush_unit(STDOUT)
838    read(STDIN,*,IOSTAT=ios)ans
839    if (ans=='y'.or.iask>NASK) STOP
840    if (ans=='n') RETURN
841  end do
842 
843 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 STDOUT and reads the value entered by the user.

INPUTS

OUTPUT

PARENTS

CHILDREN

SOURCE

445 subroutine prompt_int0D(msg,ivalue)
446 
447 
448 !This section has been created automatically by the script Abilint (TD).
449 !Do not modify the following lines by hand.
450 #undef ABI_FUNC
451 #define ABI_FUNC 'prompt_int0D'
452 !End of the abilint section
453 
454  character(len=*),intent(in) :: msg
455  integer,intent(out) :: ivalue
456 
457 !Local variables-------------------------------
458  integer :: ios
459  character(len=4) :: PS
460 ! *********************************************************************
461 
462  ios=-1 ; PS=PS1
463  do while (ios/=0)
464   write(STDOUT,'(a)',ADVANCE='NO')PS//TRIM(msg)//BLANK
465   call flush_unit(STDOUT)
466   read(STDIN,*,IOSTAT=ios)ivalue
467   if (ios==IO_EOT) then
468     call prompt_exit()
469   endif
470   PS=PS2
471  end do
472  write(STDOUT,*)
473 
474 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 STDOUT and reads the value entered by the user.

INPUTS

OUTPUT

PARENTS

CHILDREN

SOURCE

609 subroutine prompt_int1D(msg,ivect)
610 
611 !Arguments ------------------------------------
612 
613 !This section has been created automatically by the script Abilint (TD).
614 !Do not modify the following lines by hand.
615 #undef ABI_FUNC
616 #define ABI_FUNC 'prompt_int1D'
617 !End of the abilint section
618 
619  character(len=*),intent(in) :: msg
620  integer,intent(out) :: ivect(:)
621 
622 !Local variables-------------------------------
623  integer :: ios
624  character(len=4) :: PS
625 ! *********************************************************************
626 
627  ios=-1 ; PS=PS1
628  do while (ios/=0)
629    write(STDOUT,'(a)',ADVANCE='NO')PS//TRIM(msg)//BLANK
630    call flush_unit(STDOUT)
631    read(STDIN,*,IOSTAT=ios)ivect(:)
632    if (ios==IO_EOT) then
633      call prompt_exit()
634    endif
635 
636    PS=PS2
637  end do
638  write(STDOUT,*)
639 
640 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 STDOUT and reads the value entered by the user.

INPUTS

OUTPUT

PARENTS

CHILDREN

SOURCE

662 subroutine prompt_int2D(msg,iarr)
663 
664 
665 !This section has been created automatically by the script Abilint (TD).
666 !Do not modify the following lines by hand.
667 #undef ABI_FUNC
668 #define ABI_FUNC 'prompt_int2D'
669 !End of the abilint section
670 
671  character(len=*),intent(in) :: msg
672  integer,intent(out) :: iarr(:,:)
673 
674 !Local variables-------------------------------
675  integer :: ios
676  character(len=4) :: PS
677 ! *********************************************************************
678 
679  ios=-1 ; PS=PS1
680  do while (ios/=0)
681    write(STDOUT,'(a)',ADVANCE='NO')PS//TRIM(msg)//BLANK
682    call flush_unit(STDOUT)
683    read(STDIN,*,IOSTAT=ios)iarr(:,:)
684    if (ios==IO_EOT) then
685      call prompt_exit()
686    endif
687 
688    PS=PS2
689  end do
690  write(STDOUT,*)
691 
692 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 STDOUT and reads the value entered by the user.

INPUTS

OUTPUT

PARENTS

CHILDREN

SOURCE

496 subroutine prompt_rdp0D(msg,rvalue)
497 
498 
499 !This section has been created automatically by the script Abilint (TD).
500 !Do not modify the following lines by hand.
501 #undef ABI_FUNC
502 #define ABI_FUNC 'prompt_rdp0D'
503 !End of the abilint section
504 
505  character(len=*),intent(in) :: msg
506  real(dp),intent(out) :: rvalue
507 
508 !Local variables-------------------------------
509  integer :: ios
510  character(len=4) :: PS
511 ! *********************************************************************
512 
513  ios=-1 ; PS=PS1
514  do while (ios/=0)
515   write(STDOUT,'(a)',ADVANCE='NO')PS//TRIM(msg)//BLANK
516   call flush_unit(STDOUT)
517   read(STDIN,*,IOSTAT=ios)rvalue
518   if (ios==IO_EOT) then
519     call prompt_exit()
520   endif
521 
522   PS=PS2
523  end do
524  write(STDOUT,*)
525 
526 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 STDOUT and reads the value entered by the user.

INPUTS

OUTPUT

PARENTS

CHILDREN

SOURCE

714 subroutine prompt_rdp1D(msg,rvect)
715 
716 !Arguments ------------------------------------
717 
718 !This section has been created automatically by the script Abilint (TD).
719 !Do not modify the following lines by hand.
720 #undef ABI_FUNC
721 #define ABI_FUNC 'prompt_rdp1D'
722 !End of the abilint section
723 
724  character(len=*),intent(in) :: msg
725  real(dp),intent(out) :: rvect(:)
726  character(len=4) :: PS
727 !Local variables-------------------------------
728  integer :: ios
729 ! *********************************************************************
730 
731  ios=-1 ; PS=PS1
732  do while (ios/=0)
733    write(STDOUT,'(a)',ADVANCE='NO')PS//TRIM(msg)//BLANK
734    call flush_unit(STDOUT)
735    read(STDIN,*,IOSTAT=ios)rvect(:)
736    if (ios==IO_EOT) then
737      call prompt_exit()
738    endif
739 
740    PS=PS2
741  end do
742  write(STDOUT,*)
743 
744 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 STDOUT and reads the value entered by the user.

INPUTS

OUTPUT

PARENTS

CHILDREN

SOURCE

766 subroutine prompt_rdp2D(msg,rarr)
767 
768 
769 !This section has been created automatically by the script Abilint (TD).
770 !Do not modify the following lines by hand.
771 #undef ABI_FUNC
772 #define ABI_FUNC 'prompt_rdp2D'
773 !End of the abilint section
774 
775  character(len=*),intent(in) :: msg
776  real(dp),intent(out) :: rarr(:,:)
777 
778 !Local variables-------------------------------
779  integer :: ios
780  character(len=4) :: PS
781 ! *********************************************************************
782 
783  ios=-1 ; PS=PS1
784  do while (ios/=0)
785    write(STDOUT,'(a)',ADVANCE='NO')PS//TRIM(msg)//BLANK
786    call flush_unit(STDOUT)
787    read(STDIN,*,IOSTAT=ios)rarr(:,:)
788    if (ios==IO_EOT) then
789      call prompt_exit()
790    endif
791    PS=PS2
792  end do
793  write(STDOUT,*)
794 
795 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 STDOUT and reads the value entered by the user.
  If strip_comment is True (default), all the characters after "#" or "!" are ignored.

INPUTS

OUTPUT

PARENTS

CHILDREN

SOURCE

549 subroutine prompt_string(msg,string,strip_comment)
550 
551 
552 !This section has been created automatically by the script Abilint (TD).
553 !Do not modify the following lines by hand.
554 #undef ABI_FUNC
555 #define ABI_FUNC 'prompt_string'
556 !End of the abilint section
557 
558  character(len=*),intent(in) :: msg
559  logical,optional,intent(in) :: strip_comment
560  character(len=*),intent(out) :: string
561 
562 !Local variables-------------------------------
563  integer :: ios,ic
564  logical :: do_strip
565  character(len=4) :: PS
566  !character(len=len(string)) :: tmps
567 ! *********************************************************************
568 
569  do_strip = .True.; if (present(strip_comment)) do_strip = strip_comment
570 
571  ios=-1 ; PS=PS1
572  do while (ios/=0)
573    write(STDOUT,'(a)',ADVANCE='NO')PS//TRIM(msg)//BLANK
574    call flush_unit(STDOUT)
575    read(STDIN,'(a)',IOSTAT=ios)string
576    if (ios==IO_EOT) call prompt_exit()
577 
578    PS=PS2
579  end do
580  write(STDOUT,*)
581 
582  if (do_strip) then
583    ic = INDEX(string, "#"); if (ic /= 0) string(:) = string(:ic-1)
584    ic = INDEX(string, "!"); if (ic /= 0) string(:) = string(:ic-1)
585  end if
586 
587 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

PARENTS

CHILDREN

SOURCE

866 integer function read_string(string, unit) result(ios)
867 
868 
869 !This section has been created automatically by the script Abilint (TD).
870 !Do not modify the following lines by hand.
871 #undef ABI_FUNC
872 #define ABI_FUNC 'read_string'
873 !End of the abilint section
874 
875  character(len=*),intent(out):: string
876  integer,optional,intent(in) :: unit
877 
878 !Local variables-------------------------------
879  integer :: ipos,unt
880 ! *********************************************************************
881 
882  unt=STDIN; if (present(unit)) unt=unit
883 
884  read(unt,'(a)', iostat=ios) string  ! read input line
885  if (ios/=0) return
886  string = ADJUSTL(string)
887 
888  ! Ignore portion after comments
889  ipos = INDEX(string, "!")
890  if (ipos /= 0) string=string(:ipos-1)
891  ipos = INDEX(string, "#")
892  if (ipos /= 0) string=string(:ipos-1)
893 
894 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

PARENTS

      m_errors

CHILDREN

SOURCE

1601 subroutine show_units(ount)
1602 
1603 
1604 !This section has been created automatically by the script Abilint (TD).
1605 !Do not modify the following lines by hand.
1606 #undef ABI_FUNC
1607 #define ABI_FUNC 'show_units'
1608 !End of the abilint section
1609 
1610  implicit none
1611 
1612 !This section has been created automatically by the script Abilint (TD).
1613 !Do not modify the following lines by hand.
1614 #undef ABI_FUNC
1615 #define ABI_FUNC 'show_units'
1616 !End of the abilint section
1617 
1618 !Arguments ------------------------------------
1619 !scalars
1620  integer,intent(in) :: ount
1621 
1622 !Local variables-------------------------------
1623  integer :: ii,iostat
1624  logical  :: named, opened
1625  character(len=fnlen) :: filename,form
1626 
1627 ! *********************************************************************
1628 
1629  write(ount,'(a)') '******** Fortran Logical Units ********'
1630 
1631  do ii=0,max_unit_number
1632    inquire(ii, opened=opened, named=named, name=filename, form=form, iostat=iostat)
1633    if (iostat == 0) then
1634       if (opened) then
1635          if (named) then
1636             write(ount,*)"unit: ", ii, "form: ", trim(form), ", filename: ", trim(filename)
1637          else
1638             write(ount,*)"unit: ", ii, "form: ",form, ', No name available'
1639          endif
1640       else 
1641         !write(ount,*)"unit: ", ii, " is not opened"
1642       endif
1643    else
1644       write(ount,*)" unit: ", ii, ' Iostat error'
1645    endif
1646  end do
1647 
1648 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

OUTPUT

  Only writing.

PARENTS

      m_io_tools,wrtout

CHILDREN

SOURCE

1409 subroutine write_lines(unit,message)
1410 
1411 
1412 !This section has been created automatically by the script Abilint (TD).
1413 !Do not modify the following lines by hand.
1414 #undef ABI_FUNC
1415 #define ABI_FUNC 'write_lines'
1416 !End of the abilint section
1417 
1418  implicit none
1419 
1420 !Arguments ------------------------------------
1421 !scalars
1422  integer,intent(in) :: unit
1423  character(len=*),intent(in) :: message
1424 
1425 !Local variables-------------------------------
1426 !scalars
1427  integer :: msg_size,ii,jj,rtnpos
1428 
1429 !******************************************************************
1430 
1431  msg_size = len_trim(message)
1432 
1433  if (msg_size == 0) then
1434    write(unit,*)
1435    return 
1436  end if
1437 
1438  ! Here, split the message, according to the char(10) characters (carriage return). 
1439  ! This technique is portable accross different OS.
1440  rtnpos = index(message,ch10)
1441 
1442  if (rtnpos == 0) then
1443    write(unit,"(a)")message(1:msg_size)
1444    return
1445  end if 
1446 
1447  ii = 1; jj = rtnpos
1448  do 
1449    if (ii == jj) then
1450      write(unit,*)
1451    else
1452      write(unit, '(a)' ) message(ii:jj-1)
1453    end if
1454    ii = jj + 1
1455    if (ii > msg_size) exit
1456    jj = index(message(ii:msg_size),ch10) 
1457    if (jj == 0) then 
1458      ! Will write the last line at the next iteration and exit .
1459      jj = msg_size + 1
1460    else
1461      jj = jj + ii - 1
1462    end if
1463    !write(*,*)"ii, jj, msg_size",ii, jj, msg_size
1464  end do
1465 
1466  ! This is needed to preserve the od behaviour: a ch10 at the 
1467  ! end of the string was causing an extra newline!
1468  if (message(msg_size:msg_size) == ch10) write(unit,*)
1469 
1470 end subroutine write_lines