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