1!! Copyright (C) 2009 X. Andrade
2!!
3!! This program is free software; you can redistribute it and/or modify
4!! it under the terms of the GNU General Public License as published by
5!! the Free Software Foundation; either version 2, or (at your option)
6!! any later version.
7!!
8!! This program is distributed in the hope that it will be useful,
9!! but WITHOUT ANY WARRANTY; without even the implied warranty of
10!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
11!! GNU General Public License for more details.
12!!
13!! You should have received a copy of the GNU General Public License
14!! along with this program; if not, write to the Free Software
15!! Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
16!! 02110-1301, USA.
17!!
18
19#include "global.h"
20#include "io_binary.h"
21
22module io_binary_oct_m
23  use global_oct_m
24  use io_oct_m
25  use iso_c_binding
26  use messages_oct_m
27  use mpi_oct_m
28  use string_oct_m
29  use profiling_oct_m
30
31  implicit none
32
33  private
34
35  public ::                   &
36    io_binary_write,          &
37    io_binary_write_parallel, &
38    io_binary_read,           &
39    io_binary_read_parallel,  &
40    io_binary_get_info,       &
41    dwrite_header,            &
42    zwrite_header,            &
43    iwrite_header
44
45  interface io_binary_write
46    module procedure dwrite_binary, zwrite_binary, iwrite_binary
47    module procedure iwrite_binary2, dwrite_binary2, zwrite_binary2
48    module procedure zwrite_binary3, dwrite_binary3, iwrite_binary3
49    module procedure zwrite_binary4, dwrite_binary4, iwrite_binary4
50    module procedure zwrite_binary5, dwrite_binary5, iwrite_binary5
51  end interface io_binary_write
52
53  interface io_binary_write_parallel
54    module procedure dwrite_parallel, zwrite_parallel, iwrite_parallel
55  end interface io_binary_write_parallel
56
57  interface io_binary_read
58    module procedure dread_binary, zread_binary, iread_binary
59    module procedure iread_binary2, zread_binary2, dread_binary2
60    module procedure zread_binary3, iread_binary3, dread_binary3
61    module procedure zread_binary4, iread_binary4, dread_binary4
62    module procedure zread_binary5, iread_binary5, dread_binary5
63  end interface io_binary_read
64
65  interface io_binary_read_parallel
66    module procedure dread_parallel, zread_parallel, iread_parallel
67  end interface io_binary_read_parallel
68
69  interface
70    subroutine get_info_binary(np, type, file_size, ierr, iio, fname) bind(c)
71      use iso_c_binding
72      integer(c_int),         intent(out)   :: np        !< Number of points of the mesh, written in the header
73      integer(c_int),         intent(out)   :: type      !< Type of number
74      integer(c_int),         intent(out)   :: file_size !< The actual size of the file
75      integer(c_int),         intent(out)   :: ierr
76      integer(c_int),         intent(inout) :: iio
77      character(kind=c_char), intent(in)    :: fname(*)
78    end subroutine get_info_binary
79
80    subroutine write_header(np, type, ierr, iio, fname) bind(c, name="io_write_header")
81      use iso_c_binding
82      integer(c_int),         intent(in)    :: np
83      integer(c_int),         intent(in)    :: type
84      integer(c_int),         intent(out)   :: ierr
85      integer(c_int),         intent(inout) :: iio
86      character(kind=c_char), intent(in)    :: fname(*)
87    end subroutine write_header
88
89    subroutine write_binary(np, ff, type, ierr, iio, nhd, flpe, fname) bind(c, name="write_binary")
90      use iso_c_binding
91      integer(c_int),         intent(in)    :: np
92      type(c_ptr),            value         :: ff
93      integer(c_int),         intent(in)    :: type
94      integer(c_int),         intent(out)   :: ierr
95      integer(c_int),         intent(inout) :: iio
96      integer(c_int),         intent(in)    :: nhd
97      integer(c_int),         intent(in)    :: flpe
98      character(kind=c_char), intent(in)    :: fname(*)
99    end subroutine write_binary
100
101    subroutine read_binary(np, offset, ff, output_type, ierr, iio, fname) bind(c, name="read_binary")
102      use iso_c_binding
103      integer(c_int),         intent(in)    :: np
104      integer(c_int),         intent(in)    :: offset
105      type(c_ptr),            value         :: ff
106      integer(c_int),         intent(in)    :: output_type
107      integer(c_int),         intent(in)    :: ierr
108      integer(c_int),         intent(inout) :: iio
109      character(kind=c_char), intent(in)    :: fname(*)
110    end subroutine read_binary
111
112  end interface
113
114contains
115
116  ! ------------------------------------------------------
117
118  subroutine io_binary_parallel_start(fname, file_handle, comm, xlocal, np, sizeof_ff, is_write, ierr)
119    character(len=*),    intent(in)    :: fname
120    integer,             intent(out)   :: file_handle
121    integer,             intent(in)    :: comm
122    integer,             intent(in)    :: xlocal
123    integer,             intent(in)    :: np
124    integer,             intent(in)    :: sizeof_ff
125    logical,             intent(in)    :: is_write !< if false, is read.
126    integer,             intent(out)   :: ierr
127
128#ifdef HAVE_MPI2
129    integer(MPI_OFFSET_KIND) :: offset
130    integer :: amode
131#endif
132
133    PUSH_SUB(io_binary_parallel_start)
134
135    ASSERT(np > 0)
136
137#ifdef HAVE_MPI2
138    offset = (xlocal-1)*sizeof_ff+64
139
140    if(is_write) then
141      amode = IOR(MPI_MODE_WRONLY,MPI_MODE_APPEND)
142    else
143      amode = MPI_MODE_RDONLY
144    end if
145    call MPI_File_open(comm, fname, amode, MPI_INFO_NULL, file_handle, mpi_err)
146    call io_incr_open_count()
147
148    if(mpi_err == 0) then
149      call MPI_File_set_atomicity(file_handle, .true., mpi_err)
150      call MPI_File_seek(file_handle, offset, MPI_SEEK_SET, mpi_err)
151    end if
152    ierr = mpi_err
153#else
154    ierr = -1
155    file_handle = -1
156    message(1) = "Internal error: cannot call io_binary parallel routines without MPI2."
157    call messages_fatal(1)
158#endif
159
160    POP_SUB(io_binary_parallel_start)
161  end subroutine io_binary_parallel_start
162
163  ! ------------------------------------------------------
164
165  subroutine io_binary_parallel_end(file_handle)
166    integer, intent(inout) :: file_handle
167
168    PUSH_SUB(io_binary_parallel_end)
169
170#ifdef HAVE_MPI2
171    call MPI_File_close(file_handle, mpi_err)
172    call io_incr_close_count()
173#else
174    message(1) = "Internal error: cannot call io_binary parallel routines without MPI2."
175    call messages_fatal(1)
176#endif
177
178    POP_SUB(io_binary_parallel_end)
179  end subroutine io_binary_parallel_end
180
181
182  ! ------------------------------------------------------
183
184  subroutine try_dread_binary(fname, np, ff, ierr, offset)
185    character(len=*),    intent(in)  :: fname
186    integer,             intent(in)  :: np
187    complex(8),          intent(out) :: ff(:)
188    integer,             intent(out) :: ierr
189    integer, optional,   intent(in)  :: offset
190
191    integer :: read_np, number_type, file_size, iio
192    real(8), allocatable :: read_ff(:)
193
194    PUSH_SUB(try_dread_binary)
195
196    iio = 0
197    call get_info_binary(read_np, number_type, file_size, ierr, iio, string_f_to_c(fname))
198    call io_incr_counters(iio)
199
200    ! if the type of the file is real, then read real numbers and convert to complex
201    if (number_type /= TYPE_DOUBLE_COMPLEX) then
202      if (debug%info) then
203        write(message(1),'(a,i2,a,i2)') "Debug: Found type = ", number_type, " instead of ", TYPE_DOUBLE_COMPLEX
204        call messages_info(1)
205      end if
206
207      SAFE_ALLOCATE(read_ff(1:np))
208      call dread_binary(fname, np, read_ff, ierr, offset)
209      ff = read_ff
210      SAFE_DEALLOCATE_A(read_ff)
211    else
212      ierr = -1
213    end if
214    ! ierr will be 0 if dread_binary succeeded
215
216    POP_SUB(try_dread_binary)
217  end subroutine try_dread_binary
218
219  !------------------------------------------------------
220
221  subroutine try_dread_parallel(fname, comm, xlocal, np, ff, ierr)
222    character(len=*),    intent(in)    :: fname
223    integer,             intent(in)    :: comm
224    integer,             intent(in)    :: xlocal
225    integer,             intent(in)    :: np
226    complex(8),          intent(inout) :: ff(:)
227    integer,             intent(out)   :: ierr
228
229    integer :: read_np, number_type, file_size, iio
230    real(8), allocatable :: read_ff(:)
231
232    PUSH_SUB(try_dread_parallel)
233
234    iio = 0
235    call get_info_binary(read_np, number_type, file_size, ierr, iio, string_f_to_c(fname))
236    call io_incr_counters(iio)
237    ! if the type of the file is real, then read real numbers and convert to complex
238    if (number_type /= TYPE_DOUBLE_COMPLEX) then
239      if (debug%info) then
240        write(message(1),'(a,i2,a,i2)') "Debug: Found type = ", number_type, " instead of ", TYPE_DOUBLE_COMPLEX
241        call messages_info(1)
242      end if
243      SAFE_ALLOCATE(read_ff(1:np))
244      call dread_parallel(fname, comm, xlocal, np, read_ff, ierr)
245      ff = read_ff
246      SAFE_DEALLOCATE_A(read_ff)
247    else
248      ierr = -1
249    end if
250    ! ierr will be 0 if dread_parallel succeeded
251
252    POP_SUB(try_dread_parallel)
253  end subroutine try_dread_parallel
254
255  !------------------------------------------------------
256
257  subroutine io_binary_get_info(fname, np, file_size, ierr)
258    character(len=*),    intent(in)    :: fname
259    integer,             intent(out)   :: np
260    integer,             intent(out)   :: file_size
261    integer,             intent(out)   :: ierr
262
263    integer :: type, iio
264
265    PUSH_SUB(io_binary_get_info)
266
267    iio = 0
268    call get_info_binary(np, type, file_size, ierr, iio, string_f_to_c(fname))
269    call io_incr_counters(iio)
270
271    POP_SUB(io_binary_get_info)
272  end subroutine io_binary_get_info
273
274  ! ------------------------------------------------------
275  integer pure function logical_to_integer(flag) result(iflag)
276    logical, intent(in) :: flag
277    iflag = 0
278    if(flag) iflag = 1
279  end function logical_to_integer
280
281#include "complex.F90"
282#include "io_binary_f_inc.F90"
283
284#include "undef.F90"
285
286#include "real.F90"
287#include "io_binary_f_inc.F90"
288
289#include "undef.F90"
290
291#include "integer.F90"
292#include "io_binary_f_inc.F90"
293
294end module io_binary_oct_m
295
296!! Local Variables:
297!! mode: f90
298!! coding: utf-8
299!! End:
300