trunk/libf/in_out.f90

module in_out

  implicit none

  private prep_file, go_column, s_pr_mat, d_pr_mat
  interface pr_matrix
     module procedure s_pr_mat, d_pr_mat
  end interface

contains

  !***********************************************************

  integer function new_unit()

    logical opened, exist

    !------------------------------------------------------

    new_unit = 0
    do
       inquire(unit=new_unit, opened=opened, exist=exist)
       if (exist .and. .not. opened) exit
       new_unit = new_unit + 1
    end do

  end function new_unit

  !***********************************************************

  function csvread(file, first_r, first_c, last_r, last_c)

    ! Reads comma-separated numeric values in a file. The
    ! last column and/or last row parameters may be 0. This is
    ! interpreted as "last in the file".

    real, pointer:: csvread(:,:)

    character(len=*), intent(in):: file
    integer, intent(in), optional:: first_r ! (first row to read)
    integer, intent(in), optional:: first_c ! (first column to read)
    integer, intent(in), optional:: last_r ! (last row to read)
    integer, intent(in), optional:: last_c ! (last column to read)

    ! Variables local to the subprogram:
    integer i, unit
    integer f_r_loc ! (first row to read, local variable)
    integer f_c_loc ! (first column to read, local variable)
    integer l_r_loc ! (last row to read, local variable)
    integer l_c_loc ! (last column to read, local variable)

    !------------------------------------------------------

    print *, 'Reading data from file "' // file // '"'
    unit = new_unit()
    open(unit, file=file, status='old', action='read', position='rewind')

    call prep_file(unit, first_r, first_c, last_r, last_c, f_r_loc, &
         f_c_loc, l_r_loc, l_c_loc)

    allocate(csvread(l_r_loc - f_r_loc + 1, l_c_loc - f_c_loc + 1))

    do i = 1, l_r_loc - f_r_loc + 1
       call go_column(unit, f_c_loc)
       read(unit, fmt=*) csvread(i, :)
    end do
    ! (no implicit loop in read to allow partial reading of a line)

    close(unit)

  end function csvread

  !***********************************************************

  function csvread_dp(file, first_r, first_c, last_r, last_c)

    ! Reads comma-separated numeric values from a file, into a
    ! double precision array. The last column and/or last row parameters may be
    ! 0. This is interpreted as "last in the file".

    double precision, pointer:: csvread_dp(:,:)

    character(len=*), intent(in):: file
    integer, intent(in), optional:: first_r ! (first row to read)
    integer, intent(in), optional:: first_c ! (first column to read)
    integer, intent(in), optional:: last_r ! (last row to read)
    integer, intent(in), optional:: last_c ! (last column to read)

    ! Variables local to the subprogram:
    integer i, unit
    integer f_r_loc ! (first row to read, local variable)
    integer f_c_loc ! (first column to read, local variable)
    integer l_r_loc ! (last row to read, local variable)
    integer l_c_loc ! (last column to read, local variable)

    !------------------------------------------------------

    print *, 'Reading data from file "' // file // '"'
    unit = new_unit()
    open(unit, file=file, status='old', action='read', position='rewind')

    call prep_file(unit, first_r, first_c, last_r, last_c, f_r_loc, &
         f_c_loc, l_r_loc, l_c_loc)

    allocate(csvread_dp(l_r_loc - f_r_loc + 1, l_c_loc - f_c_loc + 1))

    do i = 1, l_r_loc - f_r_loc + 1
       call go_column(unit, f_c_loc)
       read(unit, fmt=*) csvread_dp(i, :)
    end do
    ! (no implicit loop in read to allow partial reading of a line)

    close(unit)

  end function csvread_dp

  !***********************************************************

  subroutine go_column(unit, column)

    ! This subroutine is used by the various versions of "csvread". On
    ! the current line of file, it advances to the input column. Columns are
    ! assumend to be separated by commas.

    integer, intent(in):: unit ! logical unit for input file
    integer, intent(in):: column

    ! Variables local to the subprogram:
    integer j
    character c

    !------------------------------------------------------

    ! Skip columns before "column" :
    j = 1 ! column index
    do while (j <= column - 1)
       read(unit, fmt='(a)', advance='no') c
       if (c == ',') j = j + 1
    end do

  end subroutine go_column

  !***********************************************************

  subroutine prep_file(unit, first_r, first_c, last_r, last_c, f_r_not_opt, &
       f_c_not_opt, l_r_not_opt, l_c_not_opt)

    ! This subroutine is used by the various versions of "csvread". It
    ! fills non-optional arguments: first and last row, first and last
    ! column which will actually be read, taking information from the
    ! file itself if necessary. It also positions the input file on the
    ! first row to read.

    integer, intent(in):: unit ! logical unit for input file
    integer, intent(in), optional:: first_r ! (first row to read)
    integer, intent(in), optional:: first_c ! (first column to read)
    integer, intent(in), optional:: last_r ! (last row to read)
    integer, intent(in), optional:: last_c ! (last column to read)
    integer, intent(out):: f_r_not_opt ! (first row to read, not optional)
    integer, intent(out):: f_c_not_opt ! (first column to read, not optional)
    integer, intent(out):: l_r_not_opt ! (last row to read, not optional)
    integer, intent(out):: l_c_not_opt ! (last column to read, not optional)

    ! Variables local to the subprogram:
    integer iostat, i
    character c

    !------------------------------------------------------

    f_r_not_opt = opt_merge(first_r, 1)
    f_c_not_opt = opt_merge(first_c, 1)
    l_r_not_opt = opt_merge(last_r, 0)
    l_c_not_opt = opt_merge(last_c, 0)

    if (l_r_not_opt == 0) then
       ! Count the number of lines in the file:
       i = 0
       do
          read(unit, fmt=*, iostat=iostat)
          if (iostat /= 0) exit
          i = i + 1
       end do
       l_r_not_opt = i
       if (l_r_not_opt == 0) stop 'Empty file.'

       rewind(unit)
    end if

    ! Go to first row to read:
    do i = 1, f_r_not_opt - 1
       read(unit, fmt=*)
    end do

    if (l_c_not_opt == 0) then
       ! Count the number of values per line:
       i = 0
       do
          read(unit, fmt='(a)', advance='no', iostat=iostat) c
          if (iostat /= 0) exit
          if (c == ',') i = i + 1
       end do
       l_c_not_opt = i + 1

       backspace(unit)
    end if

    print *, 'Reading column(s) ', f_c_not_opt, ':', l_c_not_opt, &
         ', row(s) ', f_r_not_opt, ':', l_r_not_opt

  end subroutine prep_file

  !***********************************************************
  
  integer function opt_merge(param, default)

    ! Analogous to the intrinsic procedure "merge" : merges an
    ! optional parameter and a default value depending on the
    ! presence of the optional parameter.

    integer, intent(in), optional:: param
    integer, intent(in):: default

    !--------------

    if (present(param)) then
       opt_merge = param
    else
       opt_merge = default
    end if

  end function opt_merge

  !***********************************************************

  subroutine s_pr_mat(name, a)

    ! This subroutine prints a rank 2 real matrix.

    character(len=*), intent(in):: name
    real, intent(in):: a(:,:)

    character(len=20) fmt
    integer n_lines, n_col, i

    !-----------------

    n_lines = size(a, 1)
    n_col = size(a, 2)
    if (n_lines <= 10 .and. n_col <= 5) then
       print *, name, ":"
       write(unit=fmt, fmt='("(1p, ", i0, "(g10.3: 1X))")') n_col
       do i = 1, n_lines
          print fmt, a(i, :)
       end do
    else
       print *, '"', name, '" is too big to print.'
    end if

  end subroutine s_pr_mat

  !***********************************************************

  subroutine d_pr_mat(name, a)

    ! This subroutine prints a rank 2 double precision matrix.

    character(len=*), intent(in):: name
    double precision, intent(in):: a(:,:)

    character(len=20) fmt
    integer n_lines, n_col, i

    !-----------------

    n_lines = size(a, 1)
    n_col = size(a, 2)
    if (n_lines <= 10 .and. n_col <= 5) then
       print *, name, ":"
       write(unit=fmt, fmt='("(1p, ", i0, "(g8.1: 1X))")') n_col
       do i = 1, n_lines
          print fmt, a(i, :)
       end do
    else
       print *, '"', name, '" is too big to print.'
    end if

  end subroutine d_pr_mat

end module in_out
1	guez	3	module in_out
2
3			implicit none
4
5			private prep_file, go_column, s_pr_mat, d_pr_mat
6			interface pr_matrix
7			module procedure s_pr_mat, d_pr_mat
8			end interface
9
10			contains
11
12			!***********************************************************
13
14			integer function new_unit()
15
16			logical opened, exist
17
18			!------------------------------------------------------
19
20			new_unit = 0
21			do
22			inquire(unit=new_unit, opened=opened, exist=exist)
23			if (exist .and. .not. opened) exit
24			new_unit = new_unit + 1
25			end do
26
27			end function new_unit
28
29			!***********************************************************
30
31			function csvread(file, first_r, first_c, last_r, last_c)
32
33			! Reads comma-separated numeric values in a file. The
34			! last column and/or last row parameters may be 0. This is
35			! interpreted as "last in the file".
36
37			real, pointer:: csvread(:,:)
38
39			character(len=*), intent(in):: file
40			integer, intent(in), optional:: first_r ! (first row to read)
41			integer, intent(in), optional:: first_c ! (first column to read)
42			integer, intent(in), optional:: last_r ! (last row to read)
43			integer, intent(in), optional:: last_c ! (last column to read)
44
45			! Variables local to the subprogram:
46			integer i, unit
47			integer f_r_loc ! (first row to read, local variable)
48			integer f_c_loc ! (first column to read, local variable)
49			integer l_r_loc ! (last row to read, local variable)
50			integer l_c_loc ! (last column to read, local variable)
51
52			!------------------------------------------------------
53
54			print *, 'Reading data from file "' // file // '"'
55			unit = new_unit()
56			open(unit, file=file, status='old', action='read', position='rewind')
57
58			call prep_file(unit, first_r, first_c, last_r, last_c, f_r_loc, &
59			f_c_loc, l_r_loc, l_c_loc)
60
61			allocate(csvread(l_r_loc - f_r_loc + 1, l_c_loc - f_c_loc + 1))
62
63			do i = 1, l_r_loc - f_r_loc + 1
64			call go_column(unit, f_c_loc)
65			read(unit, fmt=*) csvread(i, :)
66			end do
67			! (no implicit loop in read to allow partial reading of a line)
68
69			close(unit)
70
71			end function csvread
72
73			!***********************************************************
74
75			function csvread_dp(file, first_r, first_c, last_r, last_c)
76
77			! Reads comma-separated numeric values from a file, into a
78			! double precision array. The last column and/or last row parameters may be
79			! 0. This is interpreted as "last in the file".
80
81			double precision, pointer:: csvread_dp(:,:)
82
83			character(len=*), intent(in):: file
84			integer, intent(in), optional:: first_r ! (first row to read)
85			integer, intent(in), optional:: first_c ! (first column to read)
86			integer, intent(in), optional:: last_r ! (last row to read)
87			integer, intent(in), optional:: last_c ! (last column to read)
88
89			! Variables local to the subprogram:
90			integer i, unit
91			integer f_r_loc ! (first row to read, local variable)
92			integer f_c_loc ! (first column to read, local variable)
93			integer l_r_loc ! (last row to read, local variable)
94			integer l_c_loc ! (last column to read, local variable)
95
96			!------------------------------------------------------
97
98			print *, 'Reading data from file "' // file // '"'
99			unit = new_unit()
100			open(unit, file=file, status='old', action='read', position='rewind')
101
102			call prep_file(unit, first_r, first_c, last_r, last_c, f_r_loc, &
103			f_c_loc, l_r_loc, l_c_loc)
104
105			allocate(csvread_dp(l_r_loc - f_r_loc + 1, l_c_loc - f_c_loc + 1))
106
107			do i = 1, l_r_loc - f_r_loc + 1
108			call go_column(unit, f_c_loc)
109			read(unit, fmt=*) csvread_dp(i, :)
110			end do
111			! (no implicit loop in read to allow partial reading of a line)
112
113			close(unit)
114
115			end function csvread_dp
116
117			!***********************************************************
118
119			subroutine go_column(unit, column)
120
121			! This subroutine is used by the various versions of "csvread". On
122			! the current line of file, it advances to the input column. Columns are
123			! assumend to be separated by commas.
124
125			integer, intent(in):: unit ! logical unit for input file
126			integer, intent(in):: column
127
128			! Variables local to the subprogram:
129			integer j
130			character c
131
132			!------------------------------------------------------
133
134			! Skip columns before "column" :
135			j = 1 ! column index
136			do while (j <= column - 1)
137			read(unit, fmt='(a)', advance='no') c
138			if (c == ',') j = j + 1
139			end do
140
141			end subroutine go_column
142
143			!***********************************************************
144
145			subroutine prep_file(unit, first_r, first_c, last_r, last_c, f_r_not_opt, &
146			f_c_not_opt, l_r_not_opt, l_c_not_opt)
147
148			! This subroutine is used by the various versions of "csvread". It
149			! fills non-optional arguments: first and last row, first and last
150			! column which will actually be read, taking information from the
151			! file itself if necessary. It also positions the input file on the
152			! first row to read.
153
154			integer, intent(in):: unit ! logical unit for input file
155			integer, intent(in), optional:: first_r ! (first row to read)
156			integer, intent(in), optional:: first_c ! (first column to read)
157			integer, intent(in), optional:: last_r ! (last row to read)
158			integer, intent(in), optional:: last_c ! (last column to read)
159			integer, intent(out):: f_r_not_opt ! (first row to read, not optional)
160			integer, intent(out):: f_c_not_opt ! (first column to read, not optional)
161			integer, intent(out):: l_r_not_opt ! (last row to read, not optional)
162			integer, intent(out):: l_c_not_opt ! (last column to read, not optional)
163
164			! Variables local to the subprogram:
165			integer iostat, i
166			character c
167
168			!------------------------------------------------------
169
170			f_r_not_opt = opt_merge(first_r, 1)
171			f_c_not_opt = opt_merge(first_c, 1)
172			l_r_not_opt = opt_merge(last_r, 0)
173			l_c_not_opt = opt_merge(last_c, 0)
174
175			if (l_r_not_opt == 0) then
176			! Count the number of lines in the file:
177			i = 0
178			do
179			read(unit, fmt=*, iostat=iostat)
180			if (iostat /= 0) exit
181			i = i + 1
182			end do
183			l_r_not_opt = i
184			if (l_r_not_opt == 0) stop 'Empty file.'
185
186			rewind(unit)
187			end if
188
189			! Go to first row to read:
190			do i = 1, f_r_not_opt - 1
191			read(unit, fmt=*)
192			end do
193
194			if (l_c_not_opt == 0) then
195			! Count the number of values per line:
196			i = 0
197			do
198			read(unit, fmt='(a)', advance='no', iostat=iostat) c
199			if (iostat /= 0) exit
200			if (c == ',') i = i + 1
201			end do
202			l_c_not_opt = i + 1
203
204			backspace(unit)
205			end if
206
207			print *, 'Reading column(s) ', f_c_not_opt, ':', l_c_not_opt, &
208			', row(s) ', f_r_not_opt, ':', l_r_not_opt
209
210			end subroutine prep_file
211
212			!***********************************************************
213
214			integer function opt_merge(param, default)
215
216			! Analogous to the intrinsic procedure "merge" : merges an
217			! optional parameter and a default value depending on the
218			! presence of the optional parameter.
219
220			integer, intent(in), optional:: param
221			integer, intent(in):: default
222
223			!--------------
224
225			if (present(param)) then
226			opt_merge = param
227			else
228			opt_merge = default
229			end if
230
231			end function opt_merge
232
233			!***********************************************************
234
235			subroutine s_pr_mat(name, a)
236
237			! This subroutine prints a rank 2 real matrix.
238
239			character(len=*), intent(in):: name
240			real, intent(in):: a(:,:)
241
242			character(len=20) fmt
243			integer n_lines, n_col, i
244
245			!-----------------
246
247			n_lines = size(a, 1)
248			n_col = size(a, 2)
249			if (n_lines <= 10 .and. n_col <= 5) then
250			print *, name, ":"
251			write(unit=fmt, fmt='("(1p, ", i0, "(g10.3: 1X))")') n_col
252			do i = 1, n_lines
253			print fmt, a(i, :)
254			end do
255			else
256			print *, '"', name, '" is too big to print.'
257			end if
258
259			end subroutine s_pr_mat
260
261			!***********************************************************
262
263			subroutine d_pr_mat(name, a)
264
265			! This subroutine prints a rank 2 double precision matrix.
266
267			character(len=*), intent(in):: name
268			double precision, intent(in):: a(:,:)
269
270			character(len=20) fmt
271			integer n_lines, n_col, i
272
273			!-----------------
274
275			n_lines = size(a, 1)
276			n_col = size(a, 2)
277			if (n_lines <= 10 .and. n_col <= 5) then
278			print *, name, ":"
279			write(unit=fmt, fmt='("(1p, ", i0, "(g8.1: 1X))")') n_col
280			do i = 1, n_lines
281			print fmt, a(i, :)
282			end do
283			else
284			print *, '"', name, '" is too big to print.'
285			end if
286
287			end subroutine d_pr_mat
288
289			end module in_out