TABLE OF CONTENTS
- ABINIT/m_io_tools
- m_io_tools/close_unit
- m_io_tools/delete_file
- m_io_tools/enforce_fortran_io
- m_io_tools/file_exists
- m_io_tools/flush_unit
- m_io_tools/get_unit
- m_io_tools/get_unit_from_fname
- m_io_tools/iomode2str
- m_io_tools/iomode_from_fname
- m_io_tools/is_connected
- m_io_tools/is_open
- m_io_tools/is_open_fname
- m_io_tools/isncfile
- m_io_tools/lock_and_write
- m_io_tools/mvrecord
- m_io_tools/num_opened_units
- m_io_tools/open_file
- m_io_tools/pick_aname
- m_io_tools/prompt_exit
- m_io_tools/prompt_int0D
- m_io_tools/prompt_int1D
- m_io_tools/prompt_int2D
- m_io_tools/prompt_rdp0d
- m_io_tools/prompt_rdp1D
- m_io_tools/prompt_rdp2D
- m_io_tools/prompt_string
- m_io_tools/read_string
- m_io_tools/show_units
- m_io_tools/write_lines
- m_io_tools/write_units
ABINIT/m_io_tools [ 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