hdf_tools_misc.F90 19.7 KB
Newer Older
1 2 3 4 5 6
!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------

7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30
      MODULE m_hdf_tools4 
      USE hdf5
!-----------------------------------------------                        
!     major rewrite of hdf_tools                                        
!     this module contains various subroutines                          
!                                                                       
!-----------------------------------------------                        
      !<--Parameters...                                                 
      INTEGER,PARAMETER::rkind=SELECTED_REAL_KIND(12) 
      INTEGER,PARAMETER::ckind=SELECTED_REAL_KIND(12) 
      !>
      PRIVATE:: io_datadim_did,io_datadim_name


      INTERFACE io_datadim
      MODULE PROCEDURE io_datadim_did,io_datadim_name
      END INTERFACE

      CONTAINS

      SUBROUTINE  io_hdfopen(filename,access_mode,fid,hdferr,access_prp)
      USE hdf5
      IMPLICIT NONE
      character(len=*),intent(in)    :: filename
Daniel Wortmann's avatar
Daniel Wortmann committed
31
      INTEGER       ,INTENT(in)      :: access_mode
32 33 34 35 36 37
      INTEGER(HID_T),INTENT(out)     :: fid
      INTEGER,INTENT(OUT),optional   :: hdferr
      INTEGER(HID_T),INTENT(in),optional ::access_prp
      INTEGER:: err

#ifdef CPP_DEBUG
38
#ifdef CPP_HDFMPI
39 40 41 42 43 44 45 46 47 48
      include "mpif.h"
      integer:: irank
      call MPI_COMM_RANK (MPI_COMM_WORLD,irank,err)
      write(*,"('PE:',i3,' opened:',a20,' rw:',l1)") irank,filename,access_mode==H5F_ACC_RDWR_F
#else
      write(*,"('Opened:',a20,' rw:',1l)") filename,access_mode==H5F_ACC_RDWR_F
#endif
#endif


Daniel Wortmann's avatar
Daniel Wortmann committed
49
      CALL h5fopen_f (filename,access_Mode,fid,err,access_prp)
50 51 52 53 54 55 56 57 58 59 60 61 62

      IF (present(hdferr)) hdferr=err

      end subroutine

      subroutine io_hdfclose(fid,hdferr)
      USE hdf5
      IMPLICIT NONE
      INTEGER(HID_T),INTENT(in)    :: fid
      INTEGER,INTENT(OUT),optional :: hdferr

      INTEGER::err
#ifdef CPP_DEBUG
63
#ifdef CPP_HDFMPI
64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299
      include "mpif.h"
      integer:: irank
      character(len=20)::filename
      integer(size_t)::flength
      call h5fget_name_f(fid,filename,flength,err)
      call MPI_COMM_RANK (MPI_COMM_WORLD,irank,err)
      write(*,"('PE:',i3,' closed:',a20)") irank,filename
#else
      character(len=20)::filename
      integer(size_t)::flength
      call H5Fget_name_f(fid,filename,flength,err)
      write(*,"('Closed:',a20)") filename
#endif
#endif
      call h5fclose_f(fid,err)
      IF (present(hdferr)) hdferr=err
      end subroutine

      SUBROUTINE IO_gopen(fid,name,gid,hdferr)
      USE hdf5
      IMPLICIT NONE
      INTEGER(HID_T),INTENT(in)    :: fid
      character(len=*),intent(in)  :: name
      INTEGER(HID_T),INTENT(out)   :: gid
      INTEGER,INTENT(OUT),optional :: hdferr
      INTEGER::err

      call h5gopen_f(fid,name,gid,err)
      IF (present(hdferr)) hdferr=err
      end subroutine

      SUBROUTINE IO_gcreate(fid,name,gid,hdferr)
      USE hdf5
      IMPLICIT NONE
      INTEGER(HID_T),INTENT(in)    :: fid
      character(len=*),intent(in)  :: name
      INTEGER(HID_T),INTENT(out)   :: gid
      INTEGER,INTENT(OUT),optional :: hdferr
      INTEGER::err

      call h5gcreate_f(fid,name,gid,err)
      IF (present(hdferr)) hdferr=err
      end subroutine

      SUBROUTINE IO_gdelete(fid,name,hdferr)
      USE hdf5
      IMPLICIT NONE
      INTEGER(HID_T),INTENT(in)    :: fid
      character(len=*),intent(in)  :: name
      INTEGER,INTENT(OUT),optional :: hdferr
      INTEGER::err

      call h5gunlink_f(fid,name,err)
      IF (present(hdferr)) hdferr=err
      end subroutine


      SUBROUTINE IO_gclose(gid,hdferr)
      USE hdf5
      IMPLICIT NONE
      INTEGER(HID_T),INTENT(IN)   :: gid
      INTEGER,INTENT(OUT),optional :: hdferr
      INTEGER::err

      call h5gclose_f(gid,err)
      IF (present(hdferr)) hdferr=err
      end subroutine

      SUBROUTINE IO_dopen(fid,name,did,hdferr)
      USE hdf5
      IMPLICIT NONE
      INTEGER(HID_T),INTENT(in)    :: fid
      character(len=*),intent(in)  :: name
      INTEGER(HID_T),INTENT(out)   :: did
      INTEGER,INTENT(OUT),optional :: hdferr
      INTEGER::err

      call h5dopen_f(fid,name,did,err)
      IF (present(hdferr)) hdferr=err
      end subroutine

      SUBROUTINE IO_dclose(did,hdferr)
      USE hdf5
      IMPLICIT NONE
      INTEGER(HID_T),INTENT(IN)   :: did
      INTEGER,INTENT(OUT),optional :: hdferr
      INTEGER::err

      call h5dclose_f(did,err)
      IF (present(hdferr)) hdferr=err
      end subroutine

      subroutine io_datadim_name(gid,name,dim)
      IMPLICIT NONE
      INTEGER(HID_T),INTENT(IN)::gid
      CHARACTER*(*),INTENT(IN)::name
      INTEGER,INTENT(OUT)::dim(:)

      INTEGER(HID_T)::did
      CALL io_dopen(gid,name,did)
      CALL io_datadim_did(did,dim)
      CALL io_dclose(did)
      END SUBROUTINE

      !<-- S: io_datadim(did,dim)                                       
      SUBROUTINE io_datadim_did(did,dim)
!-----------------------------------------------                        
!  determine the dimesions of a hdf-dataspace                           
!           (last modified: 2004-00-00) D. Wortmann                     
!-----------------------------------------------                        
      USE hdf5 
      IMPLICIT NONE 
      !<--Arguments                                                     
      INTEGER(HID_T),INTENT(in) :: did 
      INTEGER,INTENT(OUT)       :: DIM(:) 
      !>                                                                
      !<-- Locals                                                       
      INTEGER(HID_T)      :: sid 
      INTEGER(hsize_T)    :: md(SIZE(dim)),d(SIZE(dim)) 
      INTEGER             :: n,hdferr 
                                                                        
      !>                                                                
      CALL h5dget_space_f(did, sid, hdferr) 
      CALL io_check("Invalid dataset-id in data_dimension",hdferr) 
      CALL h5sget_simple_extent_ndims_f(sid,n,hdferr) 
      CALL io_check("Invalid dataspace in data_dimension",hdferr) 
                                                                        
      IF (n>SIZE(dim)) CALL                                             &
     &     hdf_err("data_dimension called with too small array")        
      d = 0 
      call h5sget_simple_extent_dims_f(sid, d, md, hdferr) 
      CALL io_check("Invalid dataspace in data_dimension",hdferr) 
      dim = d 
      CALL h5sclose_f(sid, hdferr) 
                                                                        
      END SUBROUTINE 
      !>                                                                
      !<-- F: io_layername(layer)                                       
      FUNCTION io_layername(layer) 
!-----------------------------------------------                        
!  return string for layername                                          
!             (last modified: 07-11-08) D. Wortmann                     
!-----------------------------------------------                        
      IMPLICIT NONE 
      !<--Arguments                                                     
      INTEGER,INTENT(IN)     :: layer 
      CHARACTER(len = 10)       ::io_layername 
      !>                                                                

                                                                        
      WRITE(io_layername,"(a6,i0)") "layer-",layer
                                                                        
      END FUNCTION 
      !>                                                                
      !<-- init,close library                                           
      SUBROUTINE hdf_init() 
!*****************************************************************      
! DESC:Opens library    No longer needed?!                              
!*****************************************************************      
      USE hdf5 
      IMPLICIT NONE 
      INTEGER :: hdferr 
      CALL h5open_f(hdferr) 
      !Turn automatic error checking on!                                
      CALL h5eset_auto_f(1,hdferr) 
      !CALL h5init_types(hdferr)                                        
#ifndef CPP_AIX                                                         
      CALL checklib() 
#endif                                                                  
      END SUBROUTINE 
      SUBROUTINE hdf_close() 
!*****************************************************************      
! DESC:Closes library   No longer needed?!                              
!*****************************************************************      
      USE hdf5 
      IMPLICIT NONE 
      INTEGER::hdferr 
      !CALL h5close_types(hdferr)                                       
      CALL h5close_f(hdferr) 
      END SUBROUTINE 
      !>                                                                
      !<-- create a variable                                            
!*****************************************************************      
!                                                                       
!     The following subroutines create a var                            
!                                                                       
!                                                                       
!************************************************************           
      SUBROUTINE io_createvar(did,name,TYPE,dims,vid,chunk,fill)
!*****************************************************************      
      USE hdf5 
      IMPLICIT NONE 
      INTEGER(HID_T),INTENT(IN)  :: did 
      CHARACTER,INTENT(IN)       :: name*(*) 
      INTEGER(HID_T),INTENT(IN)  ::TYPE 
      INTEGER,INTENT(IN)         ::dims(:) 
      INTEGER(HID_T),INTENT(OUT) :: vid 
      INTEGER,INTENT(IN),OPTIONAL :: chunk 
      logical,intent(in),optional :: fill
                                                                        
      !locals                                                           
      INTEGER(HSIZE_T) ::DIM(SIZE(dims)) 
      INTEGER(HSIZE_T) :: chunk_DIM(SIZE(dims)) 
      INTEGER(HID_t) ::spaceid,prp_id 
      INTEGER       ::hdferr 
      dim = dims 
      WHERE (dim == 0) 
         dim = 1 
      endwhere 

      CALL h5pcreate_f(H5P_DATASET_CREATE_F, prp_id, hdferr)
      IF (PRESENT(chunk)) THEN 
         chunk_dim = dim 
         IF (chunk<SIZE(chunk_dim)) chunk_DIM(chunk+1:) = 1 
         CALL h5pset_chunk_f(prp_id, SIZE(dims),chunk_dim, hdferr) 
      ENDIF
      if (present(fill)) then
        if (.not.fill) call h5pset_fill_time_f(prp_id, H5D_FILL_TIME_NEVER_F, hdferr)
      endif

      CALL h5screate_simple_f(SIZE(dim),dim ,spaceid,hdferr) 
      CALL h5dcreate_f(did,name,TYPE,spaceid,                           &
     &                 vid, hdferr,prp_id)                              
      call h5pclose_f(prp_id,hdferr)
      CALL h5sclose_f(spaceid,hdferr) 
      CALL io_check('io_createvar:'//name,hdferr) 
      END SUBROUTINE 
      !>                                                                
      !<-- F:gettransprop()RESULT(trans)                                
      FUNCTION gettransprop()RESULT(trans) 
!********************************************************************** 
!  local FUNCTION to get default transfer-property                      
!********************************************************************** 
      USE hdf5 
      IMPLICIT NONE 
      INTEGER(HID_T)::trans 
300
#ifdef CPP_HDFMPI
301 302
      INCLUDE 'mpif.h' 
      INTEGER::hdferr 
303 304 305 306 307 308 309 310
      LOGICAL::l_mpi
      CALL MPI_INITIALIZED(l_mpi,hdferr)
      IF (l_mpi) THEN
         CALL h5pcreate_f(H5P_DATASET_XFER_F, trans, hdferr) 
         CALL h5pset_dxpl_mpio_f(trans,H5FD_MPIO_INDEPENDENT_F,hdferr)
      ELSE
         trans=H5P_DEFAULT_f 
      ENDIF
311 312 313 314 315 316 317 318 319 320 321 322 323 324
#else                                                                   
      trans=H5P_DEFAULT_f 
#endif                                                                  
      END FUNCTION 
!---------------------------------------------------------------------- 
      !>                                                                
      !<-- S:cleartransprop(trans)                                      
      SUBROUTINE cleartransprop(trans) 
!********************************************************************** 
!  local FUNCTION to get default transfer-property                      
!********************************************************************** 
      USE hdf5 
      IMPLICIT NONE 
      INTEGER(HID_T),INTENT(INOUT)::trans 
325
#ifdef CPP_HDFMPI
326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356
      INTEGER::hdferr 
      INCLUDE 'mpif.h' 
      IF (trans==H5P_DEFAULT_f) RETURN 
      CALL h5pclose_f(trans,hdferr) 
#else                                                                   
                             !just to use trans                         
      IF (trans == 1) RETURN 
      RETURN 
#endif                                                                  
      END SUBROUTINE 
                                                                        
      !>                                                                
      !<-- S:io_check(text,err)                                         
                                                                        
      SUBROUTINE io_check(text,err,oid) 
!***********************************************************************
!      SUBROUTINE to check IO for error                                 
!                                                                       
!                                  Daniel Wortmann, Juelich, 2002       
!***********************************************************************
      USE hdf5 
      IMPLICIT NONE 
      INTEGER,INTENT(INOUT)              :: err 
      CHARACTER*(*),OPTIONAL             :: text 
      INTEGER(hid_t),INTENT(IN),OPTIONAL :: oid 
                                                                        
      CHARACTER(len = 5)  :: pe ="    :" 
      CHARACTER(len = 500):: object_name 
      INTEGER (hid_t)     :: itype 
      INTEGER             :: hdferr 
      INTEGER (size_t)    :: n,nn 
357
#ifdef CPP_HDFMPI                                                          
358 359
      include 'mpif.h' 
      INTEGER             :: irank,nerr 
360 361 362 363 364 365
      LOGICAL             :: l_mpi
      CALL MPI_INITIALIZED(l_mpi,nerr)
      IF (l_mpi) THEN
         CALL MPI_COMM_rank(MPI_COMM_WORLD,irank,nerr) 
         WRITE(pe,"(i4,a)") irank,":" 
      ENDIF
366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456
#endif                                                                  
      n = 500 
      IF (err>=0) RETURN 
                                                                        
      CALL h5eprint_f(err) 
      IF (PRESENT(text)) THEN 
         WRITE(*,*) pe,'IO-Error detected in: ',text 
      ENDIF 
                                                                        
      !Try to get a name for the oid                                    
      IF (PRESENT(oid)) THEN 
         write(*,*) "Offending Object-ID:",oid 
!         CALl h5iget_name_f(oid, object_name,n,nn,Hdferr) 
         hdferr=1
         If (hdferr /= 0) THEN 
            write(*,*) "Name of OID could not be determined" 
         ELSE 
            WRITE(*,*) "Name of OID:",object_name 
            !call h5iget_type_f(oid, itype, hdferr) 
            IF (hdferr /= 0) THEN 
               write(*,*) "Type of OID could not be determined" 
            ELSE 
               IF (iTYPE == H5I_FILE_F)                                 &
     &              WRITE(*,*) "OID is a file"                          
               IF (iTYPE == H5I_group_F)                                &
     &              WRITE(*,*) "OID is a group"                         
               IF (iTYPE == H5I_datatype_F)                             &
     &              WRITE(*,*) "OID is a datatype"                      
               IF (iTYPE == H5I_dataset_F)                              &
     &              WRITE(*,*) "OID is a dataset"                       
               IF (iTYPE == H5I_attr_F)                                 &
     &              WRITE(*,*) "OID is a attribute"                     
            ENDIF 
         ENDIF 
         !CALL h5fget_name_f(oid, object_name, n, hdferr) 
         !IF (hdferr /= 0 ) THEN 
         !   WRITE(*,*) "No File found" 
         !ELSE 
         !   WRITE(*,*) "Filename:", object_name 
         !ENDIF 
      ENDIF 
      !try to generate a execption to get a traceback :-)               
                              !log of a negative real                   
      write(*,*) log(1.0*err) 
                                                                        
      CALL hdf_err('IO-Error in hdf_tools') 
                                                                        
      END SUBROUTINE 
                                                                        
      !>                                                                
                                                                        
      !<-- S:checklib()                                                 
      SUBROUTINE checklib() 
!***********************************************************************
!      SUBROUTINE to check the basic library functions                  
!                                                                       
!                                  Daniel Wortmann, Juelich, 2002       
!***********************************************************************
      USE hdf5 
      IMPLICIT NONE 
      INTEGER :: hdferr 
      INTEGER(HID_T)::fid,gid 
                                                                        
      !In most cases this check is not needed!                          
             !comment this line if you want to perform the check!       
      return 
                                                                        
      CALL h5fcreate_f("hdftest_tmp.hdf",H5F_ACC_TRUNC_F,fid,hdferr) 
      CALL h5gcreate_f(fid,"testgroup",gid,hdferr) 
      CALL h5gclose_f(gid,hdferr) 
      CALL h5fclose_f(fid,hdferr) 
                                                                        
      CALL h5fopen_f("hdftest_tmp.hdf",H5F_ACC_RDONLY_F,fid,hdferr) 
      CALL h5gopen_f(fid,"testgroup",gid,hdferr) 
      CALL h5gclose_f(gid,hdferr) 
      CALL h5fclose_f(fid,hdferr) 
                                                                        
      OPEN(99,file ="hdftest_tmp.hdf") 
      CLOSE(99) 
                                                                        
      WRITE(*,*) 'HDF library was initialized' 
                                                                        
      END SUBROUTINE 
      !>                                                                
                                                                        
      !<--S:hdf_err                                                     
      SUBROUTINE hdf_err(message) 
!-----------------------------------------------                        
!     Version for LINUX compiled with IFC                               
!             (last modified: 05-02-25) D. Wortmann                     
!-----------------------------------------------                        
457
      use m_juDFT_stop
458 459 460 461 462 463 464
      IMPLICIT NONE 
      !<-- Arguments                                                    
      CHARACTER*(*)        ::message 
                                                                        
      !>                                                                
      WRITE(*,*) "Error in HDF-io" 
      WRITE(*,*) message 
465
      call judft_error(message)
466 467 468 469 470
      END SUBROUTINE 
                                                                        
      !>                                                                
                                                                        
      END