Afivo  0.3
m_npy.f90
1 module m_npy
2  use iso_fortran_env
3 
4  implicit none
5  private
6 
7  ! Suffix for temporary .npy files
8  character(len=*), parameter :: npy_suffix = '.npy'
9 
10  interface save_npy
11  module procedure write_int64_vec, write_int64_mtx, &
12  write_int32_vec, write_int32_mtx, write_int32_3d, &
13  write_int16_vec, write_int16_mtx, &
14  write_int8_vec, write_int8_mtx, write_int8_3d, &
15  write_dbl_vec, write_dbl_mtx, &
16  write_sng_vec, write_sng_mtx, &
17  write_cmplx_sgn_vec, write_cmplx_sgn_mtx, &
18  write_cmplx_dbl_vec, write_cmplx_dbl_mtx, &
19  write_sng_3dt, write_dbl_3dt, &
20  write_sng_4dt, write_dbl_4dt, &
21  write_dbl_5dt, &
22  write_cmplx_dbl_3dt, &
23  write_cmplx_dbl_4dt, &
24  write_cmplx_dbl_5dt, &
25  write_cmplx_dbl_6dt
26  end interface save_npy
27 
28  public :: save_npy
29  public :: remove_file
30  public :: add_to_zip
31 
32 contains
33 
34  subroutine run_sys(cmd, stat)
35  character(len=*), intent(in) :: cmd
36  integer(int32), intent(out) :: stat
37 
38  call execute_command_line(cmd, wait=.true., exitstat=stat)
39  end subroutine run_sys
40 
41  ! Add npy file to a zip file and remove it
42  subroutine add_to_zip(zipfile, filename, keep_file, custom_name)
43  character(len=*), intent(in) :: zipfile ! Name of zip file
44  character(len=*), intent(in) :: filename ! Name of file to add
45  logical, intent(in) :: keep_file ! Whether to keep 'filename'
46  character(len=*), intent(in), optional :: custom_name ! Custom name
47  integer(int32) :: stat
48 
49  ! Be quiet while zipping
50  character(len=*), parameter :: zip_command = "zip -q0"
51 
52  call run_sys(zip_command//" "//trim(zipfile)//" "//&
53  trim(filename), stat)
54  if (stat /= 0) then
55  print *, zip_command//" "//trim(zipfile)//" "// trim(filename)
56  error stop "add_to_zip: Can't execute zip command"
57  endif
58 
59  if (present(custom_name)) then
60  call run_sys('printf "@ '//trim(filename)//'\n@='//&
61  trim(custom_name)//'\n" | zipnote -w '//trim(zipfile), stat)
62  if (stat /= 0) then
63  error stop "add_to_zip: Failed to rename to custom_name"
64  endif
65  end if
66 
67  if (.not. keep_file) then
68  call remove_file(filename)
69  end if
70  end subroutine add_to_zip
71 
72  subroutine remove_file(filename)
73  character(len=*), intent(in) :: filename
74  integer :: p_un, stat
75 
76  open(newunit=p_un, iostat=stat, file=filename, status='old')
77  if (stat == 0) close(p_un, status='delete')
78  end subroutine remove_file
79 
80  function dict_str(var_type, var_shape) result(str)
81  character(len=*), intent(in) :: var_type
82  integer(int32), intent(in) :: var_shape(:)
83  character(len=:), allocatable :: str
84  character(len=1024) :: buffer
85  integer(int32) :: total_size, my_size
86 
87  ! https://numpy.org/devdocs/reference/generated/numpy.lib.format.html
88 
89  ! The first 6 bytes are a magic string: exactly \x93NUMPY.
90 
91  ! The next 1 byte is an unsigned byte: the major version number of the file
92  ! format, e.g. \x01.
93 
94  ! The next 1 byte is an unsigned byte: the minor version number of the file
95  ! format, e.g. \x00. Note: the version of the file format is not tied to the
96  ! version of the numpy package.
97 
98  ! The next 2 bytes form a little-endian unsigned short int: the length of
99  ! the header data HEADER_LEN.
100 
101  ! The next HEADER_LEN bytes form the header data describing the array’s
102  ! format. It is an ASCII string which contains a Python literal expression
103  ! of a dictionary. It is terminated by a newline (\n) and padded with spaces
104  ! (\x20) to make the total of len(magic string) + 2 + len(length) +
105  ! HEADER_LEN be evenly divisible by 64 for alignment purposes.
106 
107  buffer = "{'descr': '"//var_type// &
108  "', 'fortran_order': True, 'shape': ("// &
109  shape_str(var_shape)//"), }"
110 
111  ! len(magic string) + 2 + len(length) + ending newline =
112  ! 6 + 2 + 4 + 1 = 13 bytes
113  total_size = len_trim(buffer) + 13
114 
115  ! ensure total_size is divisible by 16 bytes
116  total_size = ((total_size + 15)/16) * 16
117 
118  ! Size of dict_str includes the ending newline (so -12 instead of -13)
119  my_size = total_size - 12
120 
121  ! End with newline
122  buffer(my_size:my_size) = achar(10)
123  str = buffer(1:my_size)
124  end function dict_str
125 
126  function shape_str(var_shape) result(fin_str)
127  integer(int32), intent(in) :: var_shape(:)
128  character(len=:), allocatable :: str, small_str, fin_str
129  integer(int32) :: i, length, start, halt
130 
131  length = 14*size(var_shape)
132  allocate (character(length) :: str)
133  allocate (character(14) :: small_str)
134  str = " "
135 
136  do i = 1, size(var_shape)
137  start = (i - 1)*length + 1
138  halt = i*length + 1
139  write (small_str, "(I13,A)") var_shape(i), ","
140  str = trim(str)//adjustl(small_str)
141  enddo
142 
143  fin_str = trim(str)
144  end function shape_str
145 
146  subroutine write_header(p_un, var_type, var_shape)
147  integer(int32), intent(in) :: p_un
148  character(len=*), intent(in) :: var_type
149  integer(int32), intent(in) :: var_shape(:)
150  integer(int32) :: header_len
151 
152  ! Magic number hex x93 is 147 (unsigned), signed this is -109
153  integer(int8), parameter :: magic_num = int(-109, int8)
154  character(len=*), parameter :: magic_str = "NUMPY"
155  integer(int8), parameter :: major = 2_int8 ! major *.npy version
156  integer(int8), parameter :: minor = 0_int8 ! minor *.npy version
157 
158  header_len = len(dict_str(var_type, var_shape))
159  write (p_un) magic_num, magic_str, major, minor
160  write (p_un) header_len
161  write (p_un) dict_str(var_type, var_shape)
162  end subroutine write_header
163 
164  subroutine write_cmplx_sgn_mtx(filename, mtx)
165  character(len=*), intent(in) :: filename
166  complex(4), intent(in) :: mtx(:, :)
167  character(len=*), parameter :: var_type = "<c8"
168  integer(int32) :: p_un
169  open (newunit=p_un, file=filename, form="unformatted", access="stream")
170  call write_header(p_un, var_type, shape(mtx))
171  write (p_un) mtx
172  close (unit=p_un)
173  end subroutine write_cmplx_sgn_mtx
174 
175  subroutine write_cmplx_sgn_vec(filename, vec)
176  character(len=*), intent(in) :: filename
177  complex(4), intent(in) :: vec(:)
178  character(len=*), parameter :: var_type = "<c8"
179  integer(int32) :: p_un
180  open (newunit=p_un, file=filename, form="unformatted", access="stream")
181  call write_header(p_un, var_type, shape(vec))
182  write (p_un) vec
183  close (unit=p_un)
184  end subroutine write_cmplx_sgn_vec
185 
186  subroutine write_cmplx_dbl_6dt(filename, tensor)
187  character(len=*), intent(in) :: filename
188  complex(8), intent(in) :: tensor(:, :, :, :, :, :)
189  character(len=*), parameter :: var_type = "<c16"
190  integer(int32) :: p_un
191  open (newunit=p_un, file=filename, form="unformatted", access="stream")
192  call write_header(p_un, var_type, shape(tensor))
193  write (p_un) tensor
194  close (unit=p_un)
195  end subroutine write_cmplx_dbl_6dt
196 
197  subroutine write_cmplx_dbl_5dt(filename, tensor)
198  character(len=*), intent(in) :: filename
199  complex(8), intent(in) :: tensor(:, :, :, :, :)
200  character(len=*), parameter :: var_type = "<c16"
201  integer(int32) :: p_un
202  open (newunit=p_un, file=filename, form="unformatted", access="stream")
203  call write_header(p_un, var_type, shape(tensor))
204  write (p_un) tensor
205  close (unit=p_un)
206  end subroutine write_cmplx_dbl_5dt
207 
208  subroutine write_cmplx_dbl_4dt(filename, tensor)
209  character(len=*), intent(in) :: filename
210  complex(8), intent(in) :: tensor(:, :, :, :)
211  character(len=*), parameter :: var_type = "<c16"
212  integer(int32) :: p_un
213  open (newunit=p_un, file=filename, form="unformatted", access="stream")
214  call write_header(p_un, var_type, shape(tensor))
215  write (p_un) tensor
216  close (unit=p_un)
217  end subroutine write_cmplx_dbl_4dt
218 
219  subroutine write_cmplx_dbl_3dt(filename, tensor)
220  character(len=*), intent(in) :: filename
221  complex(8), intent(in) :: tensor(:, :, :)
222  character(len=*), parameter :: var_type = "<c16"
223  integer(int32) :: p_un
224  open (newunit=p_un, file=filename, form="unformatted", access="stream")
225  call write_header(p_un, var_type, shape(tensor))
226  write (p_un) tensor
227  close (unit=p_un)
228  end subroutine write_cmplx_dbl_3dt
229 
230  subroutine write_cmplx_dbl_mtx(filename, mtx)
231  character(len=*), intent(in) :: filename
232  complex(8), intent(in) :: mtx(:, :)
233  character(len=*), parameter :: var_type = "<c16"
234  integer(int32) :: p_un
235  open (newunit=p_un, file=filename, form="unformatted", access="stream")
236  call write_header(p_un, var_type, shape(mtx))
237  write (p_un) mtx
238  close (unit=p_un)
239  end subroutine write_cmplx_dbl_mtx
240 
241  subroutine write_cmplx_dbl_vec(filename, vec)
242  character(len=*), intent(in) :: filename
243  complex(8), intent(in) :: vec(:)
244  character(len=*), parameter :: var_type = "<c16"
245  integer(int32) :: p_un
246  open (newunit=p_un, file=filename, form="unformatted", access="stream")
247  call write_header(p_un, var_type, shape(vec))
248  write (p_un) vec
249  close (unit=p_un)
250  end subroutine write_cmplx_dbl_vec
251 
252  subroutine write_sng_3dt(filename, tensor)
253  character(len=*), intent(in) :: filename
254  real(real32), intent(in) :: tensor(:, :, :)
255  character(len=*), parameter :: var_type = "<f4"
256  integer(int32) :: p_un
257  open (newunit=p_un, file=filename, form="unformatted", access="stream")
258  call write_header(p_un, var_type, shape(tensor))
259  write (p_un) tensor
260  close (unit=p_un)
261  end subroutine write_sng_3dt
262 
263  subroutine write_sng_4dt(filename, tensor)
264  character(len=*), intent(in) :: filename
265  real(real32), intent(in) :: tensor(:, :, :, :)
266  character(len=*), parameter :: var_type = "<f4"
267  integer(int32) :: p_un
268  open (newunit=p_un, file=filename, form="unformatted", access="stream")
269  call write_header(p_un, var_type, shape(tensor))
270  write (p_un) tensor
271  close (unit=p_un)
272  end subroutine write_sng_4dt
273 
274  subroutine write_sng_mtx(filename, mtx)
275  character(len=*), intent(in) :: filename
276  real(real32), intent(in) :: mtx(:, :)
277  character(len=*), parameter :: var_type = "<f4"
278  integer(int32) :: p_un
279  open (newunit=p_un, file=filename, form="unformatted", access="stream")
280  call write_header(p_un, var_type, shape(mtx))
281  write (p_un) mtx
282  close (unit=p_un)
283  end subroutine write_sng_mtx
284 
285  subroutine write_sng_vec(filename, vec)
286  character(len=*), intent(in) :: filename
287  real(real32), intent(in) :: vec(:)
288  character(len=*), parameter :: var_type = "<f4"
289  integer(int32) :: p_un
290  open (newunit=p_un, file=filename, form="unformatted", access="stream")
291  call write_header(p_un, var_type, shape(vec))
292  write (p_un) vec
293  close (unit=p_un)
294  end subroutine write_sng_vec
295 
296  subroutine write_dbl_3dt(filename, tensor)
297  character(len=*), intent(in) :: filename
298  real(real64), intent(in) :: tensor(:, :, :)
299  character(len=*), parameter :: var_type = "<f8"
300  integer(int32) :: p_un
301  open (newunit=p_un, file=filename, form="unformatted", access="stream")
302  call write_header(p_un, var_type, shape(tensor))
303  write (p_un) tensor
304  close (unit=p_un)
305  end subroutine write_dbl_3dt
306 
307  subroutine write_dbl_4dt(filename, tensor4)
308  character(len=*), intent(in) :: filename
309  real(real64), intent(in) :: tensor4(:, :, :, :)
310  character(len=*), parameter :: var_type = "<f8"
311  integer(int32) :: p_un
312  open (newunit=p_un, file=filename, form="unformatted", access="stream")
313  call write_header(p_un, var_type, shape(tensor4))
314  write (p_un) tensor4
315  close (unit=p_un)
316  end subroutine write_dbl_4dt
317 
318  subroutine write_dbl_5dt(filename, tensor5)
319  character(len=*), intent(in) :: filename
320  real(real64), intent(in) :: tensor5(:, :, :, :, :)
321  character(len=*), parameter :: var_type = "<f8"
322  integer(int32) :: p_un
323  open (newunit=p_un, file=filename, form="unformatted", access="stream")
324  call write_header(p_un, var_type, shape(tensor5))
325  write (p_un) tensor5
326  close (unit=p_un)
327  end subroutine write_dbl_5dt
328 
329  subroutine write_dbl_mtx(filename, mtx)
330  character(len=*), intent(in) :: filename
331  real(real64), intent(in) :: mtx(:, :)
332  character(len=*), parameter :: var_type = "<f8"
333  integer(int32) :: p_un
334  open (newunit=p_un, file=filename, form="unformatted", access="stream")
335  call write_header(p_un, var_type, shape(mtx))
336  write (p_un) mtx
337  close (unit=p_un)
338  end subroutine write_dbl_mtx
339 
340  subroutine write_dbl_vec(filename, vec)
341  character(len=*), intent(in) :: filename
342  real(real64), intent(in) :: vec(:)
343  character(len=*), parameter :: var_type = "<f8"
344  integer(int32) :: p_un
345  open (newunit=p_un, file=filename, form="unformatted", access="stream")
346  call write_header(p_un, var_type, shape(vec))
347  write (p_un) vec
348  close (unit=p_un)
349  end subroutine write_dbl_vec
350 
351  subroutine write_int64_mtx(filename, mtx)
352  character(len=*), intent(in) :: filename
353  integer(int64), intent(in) :: mtx(:, :)
354  character(len=*), parameter :: var_type = "<i8"
355  integer(int32) :: p_un
356  open (newunit=p_un, file=filename, form="unformatted", access="stream")
357  call write_header(p_un, var_type, shape(mtx))
358  write (p_un) mtx
359  close (unit=p_un)
360  end subroutine write_int64_mtx
361 
362  subroutine write_int64_vec(filename, vec)
363  character(len=*), intent(in) :: filename
364  integer(int64), intent(in) :: vec(:)
365  character(len=*), parameter :: var_type = "<i8"
366  integer(int32) :: p_un
367  open (newunit=p_un, file=filename, form="unformatted", access="stream")
368  call write_header(p_un, var_type, shape(vec))
369  write (p_un) vec
370  close (unit=p_un)
371  end subroutine write_int64_vec
372 
373  subroutine write_int32_mtx(filename, mtx)
374  character(len=*), intent(in) :: filename
375  integer(int32), intent(in) :: mtx(:, :)
376  character(len=*), parameter :: var_type = "<i4"
377  integer(int32) :: p_un
378  open (newunit=p_un, file=filename, form="unformatted", access="stream")
379  call write_header(p_un, var_type, shape(mtx))
380  write (p_un) mtx
381  close (unit=p_un)
382  end subroutine write_int32_mtx
383 
384  subroutine write_int32_3d(filename, mtx)
385  character(len=*), intent(in) :: filename
386  integer(int32), intent(in) :: mtx(:,:,:)
387  character(len=*), parameter :: var_type = "<i4"
388  integer(int32) :: p_un
389  open (newunit=p_un, file=filename, form="unformatted", access="stream")
390  call write_header(p_un, var_type, shape(mtx))
391  write (p_un) mtx
392  close (unit=p_un)
393  end subroutine write_int32_3d
394 
395  subroutine write_int32_vec(filename, vec)
396  character(len=*), intent(in) :: filename
397  integer(int32), intent(in) :: vec(:)
398  character(len=*), parameter :: var_type = "<i4"
399  integer(int32) :: p_un
400  open (newunit=p_un, file=filename, form="unformatted", access="stream")
401  call write_header(p_un, var_type, shape(vec))
402  write (p_un) vec
403  close (unit=p_un)
404  end subroutine write_int32_vec
405 
406  subroutine write_int16_mtx(filename, mtx)
407  character(len=*), intent(in) :: filename
408  integer(int16), intent(in) :: mtx(:, :)
409  character(len=*), parameter :: var_type = "<i2"
410  integer(int32) :: p_un
411  open (newunit=p_un, file=filename, form="unformatted", access="stream")
412  call write_header(p_un, var_type, shape(mtx))
413  write (p_un) mtx
414  close (unit=p_un)
415  end subroutine write_int16_mtx
416 
417  subroutine write_int16_vec(filename, vec)
418  character(len=*), intent(in) :: filename
419  integer(int16), intent(in) :: vec(:)
420  character(len=*), parameter :: var_type = "<i2"
421  integer(int32) :: p_un
422  open (newunit=p_un, file=filename, form="unformatted", access="stream")
423  call write_header(p_un, var_type, shape(vec))
424  write (p_un) vec
425  close (unit=p_un)
426  end subroutine write_int16_vec
427 
428  subroutine write_int8_mtx(filename, mtx)
429  character(len=*), intent(in) :: filename
430  integer(int8), intent(in) :: mtx(:, :)
431  character(len=*), parameter :: var_type = "<i1"
432  integer(int32) :: p_un
433  open (newunit=p_un, file=filename, form="unformatted", access="stream")
434  call write_header(p_un, var_type, shape(mtx))
435  write (p_un) mtx
436  close (unit=p_un)
437  end subroutine write_int8_mtx
438 
439  subroutine write_int8_3d(filename, mtx)
440  character(len=*), intent(in) :: filename
441  integer(int8), intent(in) :: mtx(:,:,:)
442  character(len=*), parameter :: var_type = "<i1"
443  integer(int32) :: p_un
444  open (newunit=p_un, file=filename, form="unformatted", access="stream")
445  call write_header(p_un, var_type, shape(mtx))
446  write (p_un) mtx
447  close (unit=p_un)
448  end subroutine write_int8_3d
449 
450  subroutine write_int8_vec(filename, vec)
451  character(len=*), intent(in) :: filename
452  integer(int8), intent(in) :: vec(:)
453  character(len=*), parameter :: var_type = "<i1"
454  integer(int32) :: p_un
455  open (newunit=p_un, file=filename, form="unformatted", access="stream")
456  call write_header(p_un, var_type, shape(vec))
457  write (p_un) vec
458  close (unit=p_un)
459  end subroutine write_int8_vec
460 
461 end module m_npy
m_npy::save_npy
Definition: m_npy.f90:10
m_npy
Definition: m_npy.f90:1
Generated on Thu May 16 2024 05:02:04 for Afivo by doxygen 1.9.1