ALF  dev.
A QMC Code for fermionic models
alf_hdf5_mod.F90
1 ! Copyright (C) 2020-2021 The ALF project
2 !
3 ! The ALF project 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 3 of the License, or
6 ! (at your option) any later version.
7 !
8 ! The ALF project 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 Foobar. If not, see http://www.gnu.org/licenses/.
15 !
16 ! Under Section 7 of GPL version 3 we require you to fulfill the following additional terms:
17 !
18 ! - It is our hope that this program makes a contribution to the scientific community. Being
19 ! part of that community we feel that it is reasonable to require you to give an attribution
20 ! back to the original authors if you have benefitted from this program.
21 ! Guidelines for a proper citation can be found on the project's homepage
22 ! http://alf.physik.uni-wuerzburg.de .
23 !
24 ! - We require the preservation of the above copyright notice and this license in all original files.
25 !
26 ! - We prohibit the misrepresentation of the origin of the original source files. To obtain
27 ! the original source files please visit the homepage http://alf.physik.uni-wuerzburg.de .
28 !
29 ! - If you make substantial changes to the program we require you to either consider contributing
30 ! to the ALF project or to mark your material in a reasonable way as different from the original version.
31 
32 
33 #if defined(HDF5)
34  Module alf_hdf5
35 !--------------------------------------------------------------------
38 !
41 !
42 !--------------------------------------------------------------------
43  use runtime_error_mod
44  use iso_fortran_env, only: output_unit, error_unit
45  USE iso_c_binding
46 
47  Use hdf5
48  use h5lt
49 
50  Use lattices_v3
51 
52  implicit none
53  private
54  public :: write_attribute, read_attribute, test_attribute, &
55  init_dset, append_dat, write_latt, write_comment
56 
57  interface write_attribute
58  MODULE PROCEDURE write_attribute_double, write_attribute_int, write_attribute_string, write_attribute_logical
59  end interface write_attribute
60  interface read_attribute
61  MODULE PROCEDURE read_attribute_double, read_attribute_int, read_attribute_string, read_attribute_logical
62  end interface read_attribute
63  interface test_attribute
64  MODULE PROCEDURE test_attribute_double, test_attribute_int, test_attribute_string, test_attribute_logical
65  end interface test_attribute
66 
67  contains
68 
69  Subroutine init_dset(file_id, dsetname, dims, is_complex, chunklen)
70 !--------------------------------------------------------------------
73 !
77 !
98 !-------------------------------------------------------------------
99  Implicit none
100 
101  INTEGER(HID_T), intent(in) :: file_id
102  Character (len=64), intent(in) :: dsetname
103  INTEGER(HSIZE_T), intent(in) :: dims(:)
104  logical, intent(in) :: is_complex
105  INTEGER(HSIZE_T), intent(in), optional :: chunklen
106 
107  INTEGER :: rank, hdferr
108  INTEGER(HSIZE_T), allocatable :: dimsc(:), maxdims(:)
109  INTEGER(HID_T) :: dset_id, dataspace, crp_list
110 
111  !CALL h5open_f(hdferr)
112 
113  !Define size of dataset and of chunks
114  rank = size(dims)
115  allocate( dimsc(rank), maxdims(rank) )
116  dimsc = dims
117  dimsc(rank) = 1
118  if ( present(chunklen) ) dimsc(rank) = chunklen
119  maxdims = dims
120  maxdims(rank) = h5s_unlimited_f
121 
122  !Check for dims(rank) = 0
123  if (dims(rank) /= 0) then
124  write(error_unit,*) 'Error in init_dset: dims(rank) /= 0'
125  Call terminate_on_error(error_generic,__file__,__line__)
126  endif
127 
128  !Create Dataspace
129  CALL h5screate_simple_f(rank, dims, dataspace, hdferr, maxdims)
130 
131  !Modify dataset creation properties, i.e. enable chunking
132  CALL h5pcreate_f(h5p_dataset_create_f, crp_list, hdferr)
133  CALL h5pset_chunk_f(crp_list, rank, dimsc, hdferr)
134 #ifdef HDF5_ZLIB
135  ! Set ZLIB / DEFLATE Compression using compression level HDF5_ZLIB
136  CALL h5pset_deflate_f(crp_list, hdf5_zlib, hdferr)
137 #endif
138 
139  !Create a dataset using cparms creation properties.
140  CALL h5dcreate_f(file_id, dsetname, h5t_native_double, dataspace, &
141  dset_id, hdferr, crp_list )
142 
143  CALL write_attribute_logical(dset_id, '.', 'is_complex', is_complex, hdferr)
144 
145  !Close objects
146  CALL h5sclose_f(dataspace, hdferr)
147  CALL h5pclose_f(crp_list, hdferr)
148  CALL h5dclose_f(dset_id, hdferr)
149  deallocate( dimsc, maxdims )
150 
151  end Subroutine init_dset
152 
153 !--------------------------------------------------------------------
154 
155  Subroutine append_dat(file_id, dsetname, dat_ptr, Nbins_in)
156 !--------------------------------------------------------------------
159 !
162 !
181 !-------------------------------------------------------------------
182  Implicit none
183 
184  INTEGER(HID_T), intent(in) :: file_id
185  Character (len=64), intent(in) :: dsetname
186  TYPE(c_ptr), intent(in) :: dat_ptr
187  INTEGER, optional, intent(in) :: nbins_in
188 
189  INTEGER :: rank, hdferr, i, nbins
190  INTEGER(HSIZE_T) :: mem_dims(1)
191  INTEGER(HSIZE_T), allocatable :: dims(:), maxdims(:), offset(:), count(:)
192  INTEGER(HID_T) :: dset_id, dataspace, memspace
193 
194  !CALL h5open_f(hdferr)
195  if( present(nbins_in) ) then
196  nbins = nbins_in
197  else
198  nbins = 1
199  endif
200 
201  !Open the dataset.
202  CALL h5dopen_f(file_id, dsetname, dset_id, hdferr)
203 
204  !Get dataset's dataspace handle.
205  CALL h5dget_space_f(dset_id, dataspace, hdferr)
206 
207  !Get dataspace's rank.
208  CALL h5sget_simple_extent_ndims_f(dataspace, rank, hdferr)
209  allocate( dims(rank), maxdims(rank), offset(rank), count(rank) )
210 
211  !Get dataspace's dimensions.
212  CALL h5sget_simple_extent_dims_f(dataspace, dims, maxdims, hdferr)
213 
214  !Extent dataset and define hyperslab to write on
215  offset(:) = 0
216  offset(rank) = dims(rank)
217  count(:) = dims(:)
218  count(rank) = nbins
219  dims(rank) = dims(rank)+nbins
220  CALL h5dset_extent_f(dset_id, dims, hdferr)
221  CALL h5sclose_f(dataspace, hdferr)
222  CALL h5dget_space_f(dset_id, dataspace, hdferr)
223  CALL h5sselect_hyperslab_f(dataspace, h5s_select_set_f, offset, count, hdferr)
224 
225  !Define memory space of data
226  mem_dims = nbins
227  do i=1, rank-1
228  mem_dims = mem_dims*dims(i)
229  enddo
230  CALL h5screate_simple_f (1, mem_dims, memspace, hdferr)
231 
232  !Write data
233  CALL h5dwrite_f(dset_id, h5t_native_double, dat_ptr, hdferr, &
234  mem_space_id = memspace, file_space_id = dataspace)
235 
236  !Close objects
237  CALL h5sclose_f(memspace, hdferr)
238  CALL h5sclose_f(dataspace, hdferr)
239  CALL h5dclose_f(dset_id, hdferr)
240 
241  deallocate( dims, maxdims, offset, count )
242 
243  end Subroutine append_dat
244 
245 !--------------------------------------------------------------------
246 
247  Subroutine write_latt(obj_id, Latt, Latt_Unit)
248 !--------------------------------------------------------------------
251 !
254 !
267 !-------------------------------------------------------------------
268  Implicit none
269  INTEGER(HID_T), intent(in) :: obj_id
270  type(lattice), intent(in) :: latt
271  type(unit_cell), intent(in) :: latt_unit
272 
273  Character (len=64) :: group_name, dset_name, attr_name
274  INTEGER(HID_T) :: group_id
275  LOGICAL :: link_exists
276  INTEGER :: ierr, no
277  INTEGER(HSIZE_T) :: size_dat
278  Real (Kind=Kind(0.d0)), allocatable :: temp(:)
279 
280  group_name = "lattice"
281  CALL h5lexists_f(obj_id, group_name, link_exists, ierr)
282  if ( link_exists ) return
283  call h5gcreate_f(obj_id, group_name, group_id, ierr)
284 
285  size_dat = size(latt%L1_p)
286  dset_name = "."
287  attr_name = "a1"
288  call h5ltset_attribute_double_f(group_id, dset_name, attr_name, latt%a1_p, size_dat, ierr )
289  attr_name = "a2"
290  call h5ltset_attribute_double_f(group_id, dset_name, attr_name, latt%a2_p, size_dat, ierr )
291  attr_name = "L1"
292  call h5ltset_attribute_double_f(group_id, dset_name, attr_name, latt%L1_p, size_dat, ierr )
293  attr_name = "L2"
294  call h5ltset_attribute_double_f(group_id, dset_name, attr_name, latt%L2_p, size_dat, ierr )
295 
296  attr_name = "N_coord"
297  call write_attribute(group_id, '.', attr_name, latt_unit%N_coord, ierr)
298  attr_name = "Norb"
299  call write_attribute(group_id, '.', attr_name, latt_unit%Norb, ierr)
300  attr_name = "Ndim"
301  call write_attribute(group_id, '.', attr_name, size(latt_unit%Orb_pos_p, 2), ierr)
302 
303  size_dat = size(latt_unit%Orb_pos_p, 2)
304  allocate(temp(size_dat))
305  do no = 1, latt_unit%Norb
306  temp(:) = latt_unit%Orb_pos_p(no,:)
307  write(attr_name, '("Orbital", I0)') no
308  call h5ltset_attribute_double_f(group_id, dset_name, attr_name, temp, size_dat, ierr )
309  enddo
310  deallocate(temp)
311 
312  call h5gclose_f(group_id, ierr)
313 
314  end Subroutine write_latt
315 
316 !--------------------------------------------------------------------
317 
318 !--------------------------------------------------------------------
319 
320  Subroutine write_attribute_double(loc_id, obj_name, attr_name, attr_value, ierr)
321 !--------------------------------------------------------------------
324 !
327 !
348 !-------------------------------------------------------------------
349  Implicit none
350  INTEGER(HID_T), INTENT(IN) :: loc_id
351  CHARACTER(LEN=*), INTENT(IN) :: obj_name
352  CHARACTER(LEN=*), INTENT(IN) :: attr_name
353  real(Kind=Kind(0.d0)), INTENT(IN) :: attr_value
354  INTEGER, INTENT(OUT) :: ierr
355 
356  INTEGER(HID_T) :: space_id, attr_id
357  INTEGER(HSIZE_T), parameter :: dims(1) = 1
358 
359  CALL h5screate_f (h5s_scalar_f, space_id, ierr)
360  call h5acreate_by_name_f(loc_id, obj_name, attr_name, h5t_native_double, &
361  space_id, attr_id, ierr)
362  call h5awrite_f (attr_id, h5t_native_double, attr_value, dims, ierr)
363  call h5aclose_f (attr_id, ierr)
364  call h5sclose_f (space_id, ierr)
365  end Subroutine write_attribute_double
366 
367 !--------------------------------------------------------------------
368 
369  Subroutine write_attribute_int(loc_id, obj_name, attr_name, attr_value, ierr)
370 !--------------------------------------------------------------------
373 !
376 !
397 !-------------------------------------------------------------------
398  Implicit none
399  INTEGER(HID_T), INTENT(IN) :: loc_id
400  CHARACTER(LEN=*), INTENT(IN) :: obj_name
401  CHARACTER(LEN=*), INTENT(IN) :: attr_name
402  INTEGER, INTENT(IN) :: attr_value
403  INTEGER, INTENT(OUT) :: ierr
404 
405  INTEGER(HID_T) :: space_id, attr_id
406  INTEGER(HSIZE_T), parameter :: dims(1) = 1
407 
408  CALL h5screate_f (h5s_scalar_f, space_id, ierr)
409  call h5acreate_by_name_f(loc_id, obj_name, attr_name, h5t_native_integer, &
410  space_id, attr_id, ierr)
411  call h5awrite_f (attr_id, h5t_native_integer, attr_value, dims, ierr)
412  call h5aclose_f (attr_id, ierr)
413  call h5sclose_f (space_id, ierr)
414  end Subroutine write_attribute_int
415 
416 !--------------------------------------------------------------------
417 
418  Subroutine write_attribute_string(loc_id, obj_name, attr_name, attr_value, ierr)
419 !--------------------------------------------------------------------
422 !
425 !
446 !-------------------------------------------------------------------
447  Implicit none
448  INTEGER(HID_T), INTENT(IN) :: loc_id
449  CHARACTER(LEN=*), INTENT(IN) :: obj_name
450  CHARACTER(LEN=*), INTENT(IN) :: attr_name
451  CHARACTER(LEN=*), INTENT(IN) :: attr_value
452  INTEGER, INTENT(OUT) :: ierr
453 
454  call h5ltset_attribute_string_f(loc_id, obj_name, attr_name, &
455  attr_value, ierr)
456  end Subroutine write_attribute_string
457 
458 !--------------------------------------------------------------------
459 
460  Subroutine write_attribute_logical(loc_id, obj_name, attr_name, attr_value, ierr)
461 !--------------------------------------------------------------------
464 !
467 !
488 !-------------------------------------------------------------------
489  Implicit none
490  INTEGER(HID_T), INTENT(IN) :: loc_id
491  CHARACTER(LEN=*), INTENT(IN) :: obj_name
492  CHARACTER(LEN=*), INTENT(IN) :: attr_name
493  LOGICAL, INTENT(IN) :: attr_value
494  INTEGER, INTENT(OUT) :: ierr
495 
496  INTEGER :: attr_value2
497  INTEGER(HID_T) :: space_id, attr_id
498  INTEGER(HSIZE_T), parameter :: dims(1) = 1
499 
500  attr_value2 = 0
501  if ( attr_value ) attr_value2 = 1
502 
503  CALL h5screate_f (h5s_scalar_f, space_id, ierr)
504  call h5acreate_by_name_f(loc_id, obj_name, attr_name, h5t_native_integer, &
505  space_id, attr_id, ierr)
506  call h5awrite_f (attr_id, h5t_native_integer, attr_value2, dims, ierr)
507  call h5aclose_f (attr_id, ierr)
508  call h5sclose_f (space_id, ierr)
509  end Subroutine write_attribute_logical
510 
511 !--------------------------------------------------------------------
512 
513  Subroutine read_attribute_double(loc_id, obj_name, attr_name, attr_value, ierr)
514 !--------------------------------------------------------------------
517 !
520 !
541 !-------------------------------------------------------------------
542  Implicit none
543  INTEGER(HID_T), INTENT(IN) :: loc_id
544  CHARACTER(LEN=*), INTENT(IN) :: obj_name
545  CHARACTER(LEN=*), INTENT(IN) :: attr_name
546  real(Kind=Kind(0.d0)), INTENT(OUT) :: attr_value
547  INTEGER, INTENT(OUT) :: ierr
548 
549  INTEGER(HID_T) :: attr_id
550  INTEGER(HSIZE_T), parameter :: dims(1) = 1
551 
552  call h5aopen_by_name_f(loc_id, obj_name, attr_name, attr_id, ierr)
553  call h5aread_f (attr_id, h5t_native_double, attr_value, dims, ierr)
554  call h5aclose_f (attr_id, ierr)
555  end Subroutine read_attribute_double
556 
557 !--------------------------------------------------------------------
558 
559  Subroutine read_attribute_int(loc_id, obj_name, attr_name, attr_value, ierr)
560 !--------------------------------------------------------------------
563 !
566 !
587 !-------------------------------------------------------------------
588  Implicit none
589  INTEGER(HID_T), INTENT(IN) :: loc_id
590  CHARACTER(LEN=*), INTENT(IN) :: obj_name
591  CHARACTER(LEN=*), INTENT(IN) :: attr_name
592  INTEGER, INTENT(OUT) :: attr_value
593  INTEGER, INTENT(OUT) :: ierr
594 
595  INTEGER(HID_T) :: attr_id
596  INTEGER(HSIZE_T), parameter :: dims(1) = 1
597 
598  call h5aopen_by_name_f(loc_id, obj_name, attr_name, attr_id, ierr)
599  call h5aread_f (attr_id, h5t_native_integer, attr_value, dims, ierr)
600  call h5aclose_f (attr_id, ierr)
601  end Subroutine read_attribute_int
602 
603 !--------------------------------------------------------------------
604 
605  Subroutine read_attribute_string(loc_id, obj_name, attr_name, attr_value, ierr)
606 !--------------------------------------------------------------------
609 !
612 !
633 !-------------------------------------------------------------------
634  Implicit none
635  INTEGER(HID_T), INTENT(IN) :: loc_id
636  CHARACTER(LEN=*), INTENT(IN) :: obj_name
637  CHARACTER(LEN=*), INTENT(IN) :: attr_name
638  CHARACTER(LEN=*), INTENT(OUT) :: attr_value
639  INTEGER, INTENT(OUT) :: ierr
640 
641  call h5ltget_attribute_string_f(loc_id, obj_name, attr_name, &
642  attr_value, ierr)
643  end Subroutine read_attribute_string
644 
645 !--------------------------------------------------------------------
646 
647  Subroutine read_attribute_logical(loc_id, obj_name, attr_name, attr_value, ierr)
648 !--------------------------------------------------------------------
651 !
654 !
675 !-------------------------------------------------------------------
676  Implicit none
677  INTEGER(HID_T), INTENT(IN) :: loc_id
678  CHARACTER(LEN=*), INTENT(IN) :: obj_name
679  CHARACTER(LEN=*), INTENT(IN) :: attr_name
680  LOGICAL, INTENT(OUT) :: attr_value
681  INTEGER, INTENT(OUT) :: ierr
682 
683  INTEGER :: attr_value2
684  INTEGER(HID_T) :: attr_id
685  INTEGER(HSIZE_T), parameter :: dims(1) = 1
686 
687  call h5aopen_by_name_f(loc_id, obj_name, attr_name, attr_id, ierr)
688  call h5aread_f (attr_id, h5t_native_integer, attr_value2, dims, ierr)
689  call h5aclose_f (attr_id, ierr)
690 
691  if ( attr_value2 == 0 ) then
692  attr_value = .false.
693  elseif ( attr_value2 == 1 ) then
694  attr_value = .true.
695  else
696  write(error_unit,*) "Error in read_attribute_logical: attr_value2 is neither 0 or 1, but", attr_value2
697  Call terminate_on_error(error_generic,__file__,__line__)
698  endif
699  end Subroutine read_attribute_logical
700 
701 !--------------------------------------------------------------------
702 
703  Subroutine test_attribute_double(loc_id, obj_name, attr_name, attr_value, ierr)
704 !--------------------------------------------------------------------
707 !
711 !
732 !-------------------------------------------------------------------
733  Implicit none
734  INTEGER(HID_T), INTENT(IN) :: loc_id
735  CHARACTER(LEN=*), INTENT(IN) :: obj_name
736  CHARACTER(LEN=*), INTENT(IN) :: attr_name
737  real(Kind=Kind(0.d0)), INTENT(IN) :: attr_value
738  INTEGER, INTENT(OUT) :: ierr
739 
740  LOGICAL :: attr_exists
741  real(Kind=Kind(0.d0)), parameter :: ZERO = 10d-8
742  real(Kind=Kind(0.d0)) :: test_double, diff
743 
744  call h5aexists_by_name_f(loc_id, obj_name, attr_name, attr_exists, ierr)
745 
746  if ( .not. attr_exists ) then
747  call write_attribute_double(loc_id, obj_name, attr_name, attr_value, ierr)
748  else
749  call read_attribute_double(loc_id, obj_name, attr_name, test_double, ierr)
750  diff = abs(attr_value - test_double)
751  if (diff > zero) then
752  write(error_unit,*) 'Error in test_attribute_double:', attr_name, ' = ', attr_value, '/=', test_double
753  Call terminate_on_error(error_generic,__file__,__line__)
754  endif
755  endif
756  end Subroutine test_attribute_double
757 
758 !--------------------------------------------------------------------
759 
760  Subroutine test_attribute_int(loc_id, obj_name, attr_name, attr_value, ierr)
761 !--------------------------------------------------------------------
764 !
768 !
789 !-------------------------------------------------------------------
790  Implicit none
791  INTEGER(HID_T), INTENT(IN) :: loc_id
792  CHARACTER(LEN=*), INTENT(IN) :: obj_name
793  CHARACTER(LEN=*), INTENT(IN) :: attr_name
794  INTEGER, INTENT(IN) :: attr_value
795  INTEGER, INTENT(OUT) :: ierr
796 
797  LOGICAL :: attr_exists
798  INTEGER :: test_int
799 
800  call h5aexists_by_name_f(loc_id, obj_name, attr_name, attr_exists, ierr)
801 
802  if ( .not. attr_exists ) then
803  call write_attribute_int(loc_id, obj_name, attr_name, attr_value, ierr)
804  else
805  call read_attribute_int(loc_id, obj_name, attr_name, test_int, ierr)
806  if (attr_value /= test_int) then
807  write(error_unit,*) 'Error in test_attribute_int:', attr_name, ' = ', attr_value, '/=', test_int
808  Call terminate_on_error(error_generic,__file__,__line__)
809  endif
810  endif
811  end Subroutine test_attribute_int
812 
813 !--------------------------------------------------------------------
814 
815  Subroutine test_attribute_string(loc_id, obj_name, attr_name, attr_value, ierr)
816 !--------------------------------------------------------------------
819 !
823 !
844 !-------------------------------------------------------------------
845  Implicit none
846  INTEGER(HID_T), INTENT(IN) :: loc_id
847  CHARACTER(LEN=*), INTENT(IN) :: obj_name
848  CHARACTER(LEN=*), INTENT(IN) :: attr_name
849  CHARACTER(LEN=*), INTENT(IN) :: attr_value
850  INTEGER, INTENT(OUT) :: ierr
851 
852  LOGICAL :: attr_exists
853  CHARACTER(LEN=64) :: test_string
854 
855  call h5aexists_by_name_f(loc_id, obj_name, attr_name, attr_exists, ierr)
856 
857  if ( .not. attr_exists ) then
858  call write_attribute_string(loc_id, obj_name, attr_name, attr_value, ierr)
859  else
860  call read_attribute_string(loc_id, obj_name, attr_name, test_string, ierr)
861  if (trim(attr_value) /= trim(test_string)) then
862  write(error_unit,*) 'Error in test_attribute_string:', attr_name, ' = ', attr_value, '/=', test_string
863  Call terminate_on_error(error_generic,__file__,__line__)
864  endif
865  endif
866  end Subroutine test_attribute_string
867 
868 !--------------------------------------------------------------------
869 
870  Subroutine test_attribute_logical(loc_id, obj_name, attr_name, attr_value, ierr)
871 !--------------------------------------------------------------------
874 !
878 !
899 !-------------------------------------------------------------------
900  Implicit none
901  INTEGER(HID_T), INTENT(IN) :: loc_id
902  CHARACTER(LEN=*), INTENT(IN) :: obj_name
903  CHARACTER(LEN=*), INTENT(IN) :: attr_name
904  LOGICAL, INTENT(IN) :: attr_value
905  INTEGER, INTENT(OUT) :: ierr
906 
907  LOGICAL :: attr_exists
908  LOGICAL :: test_bool
909 
910  call h5aexists_by_name_f(loc_id, obj_name, attr_name, attr_exists, ierr)
911 
912  if ( .not. attr_exists ) then
913  call write_attribute_logical(loc_id, obj_name, attr_name, attr_value, ierr)
914  else
915  call read_attribute_logical(loc_id, obj_name, attr_name, test_bool, ierr)
916  if (attr_value .neqv. test_bool) then
917  write(error_unit,*) 'Error in test_attribute_logical:', attr_name, ' = ', attr_value, '/=', test_bool
918  Call terminate_on_error(error_generic,__file__,__line__)
919  endif
920  endif
921  end Subroutine test_attribute_logical
922 
923 
924 
925  Subroutine write_comment(loc_id, obj_name, attr_name, comment, ierr)
926 !--------------------------------------------------------------------
929 !
933 !
954 !-------------------------------------------------------------------
955 
956  IMPLICIT NONE
957  INTEGER(HID_T), INTENT(IN) :: loc_id
958  CHARACTER(LEN=*), INTENT(IN) :: obj_name
959  CHARACTER(LEN=*), INTENT(IN) :: attr_name
960  CHARACTER(len=64), INTENT(IN) :: comment(:)
961  INTEGER, INTENT(OUT) :: ierr
962 
963  INTEGER(HID_T) :: attr_id ! Attribute identifier
964  INTEGER(HID_T) :: space_id ! Attribute Dataspace identifier
965  INTEGER(HID_T) :: type_id ! Attribute datatype identifier
966  INTEGER :: rank = 1 ! Attribure rank
967  INTEGER(HSIZE_T) :: dims(1) ! Attribute dimensions
968  INTEGER(SIZE_T) :: attrlen = 64 ! Length of the attribute string
969 
970  ! Create scalar data space for the attribute.
971  dims(1) = size(comment)
972  CALL h5screate_simple_f(rank, dims, space_id, ierr)
973 
974  ! Create datatype for the attribute.
975  CALL h5tcopy_f(h5t_native_character, type_id, ierr)
976  CALL h5tset_size_f(type_id, attrlen, ierr)
977 
978  ! Create dataset attribute.
979  call h5acreate_by_name_f(loc_id, obj_name, attr_name, type_id, &
980  space_id, attr_id, ierr)
981 
982  ! Write the attribute data.
983  CALL h5awrite_f(attr_id, type_id, comment, dims, ierr)
984 
985  ! Close the attribute, datatype and data space.
986  CALL h5aclose_f(attr_id, ierr)
987  CALL h5tclose_f(type_id, ierr)
988  CALL h5sclose_f(space_id, ierr)
989 
990  end Subroutine write_comment
991 
992  end Module alf_hdf5
993 #endif
alf_hdf5::read_attribute
Definition: alf_hdf5_mod.F90:60
lattices_v3::unit_cell
Definition: lattices_v3_mod.F90:52
alf_hdf5::write_attribute
Definition: alf_hdf5_mod.F90:57
lattices_v3::lattice
Definition: lattices_v3_mod.F90:61
alf_hdf5::test_attribute
Definition: alf_hdf5_mod.F90:63
Generated by   doxygen 1.8.13