path: root/fortran/test/fortranlib_test_1_8.f90

! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 
!   Copyright by The HDF Group.                                               *
!   Copyright by the Board of Trustees of the University of Illinois.         *
!   All rights reserved.                                                      *
!                                                                             *
!   This file is part of HDF5.  The full HDF5 copyright notice, including     *
!   terms governing use, modification, and redistribution, is contained in    *
!   the files COPYING and Copyright.html.  COPYING can be found at the root   *
!   of the source code distribution tree; Copyright.html can be found at the  *
!   root level of an installed copy of the electronic HDF5 document set and   *
!   is linked from the top-level documents page.  It can also be found at     *
!   http://hdfgroup.org/HDF5/doc/Copyright.html.  If you do not have          *
!   access to either file, you may request a copy from help@hdfgroup.org.     *
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 
!
!
! 
!    Testing Fortran wrappers introduced in 1.8 release.
!
PROGRAM fortranlibtest

  USE HDF5

  IMPLICIT NONE
  INTEGER :: total_error = 0
  INTEGER :: error
  INTEGER :: ret_total_error
  INTEGER :: majnum, minnum, relnum
  LOGICAL :: cleanup = .TRUE.
!       LOGICAL :: cleanup = .FALSE.

  CALL h5open_f(error) 
  WRITE(*,*) '                       ==========================                            '
  WRITE(*,*) '                              FORTRAN 1.8 tests '
  WRITE(*,*) '                       ==========================                            '
  CALL h5get_libversion_f(majnum, minnum, relnum, total_error)
  IF(total_error .EQ. 0) THEN
     WRITE(*, '(" FORTRANLIB_TEST is linked with HDF5 Library version ")', advance="NO")
     WRITE(*, '(I1)', advance="NO") majnum
     WRITE(*, '(".")', advance="NO") 
     WRITE(*, '(I1)', advance="NO") minnum
     WRITE(*, '(" release ")', advance="NO")
     WRITE(*, '(I3)') relnum
  ELSE
     total_error = total_error + 1
  ENDIF
  WRITE(*,*)

  ret_total_error = 0
  CALL file_space(cleanup, ret_total_error)
  CALL write_test_status(ret_total_error, &
       ' Testing file free space', &
       total_error)

  ret_total_error = 0
  CALL attribute_test_1_8(cleanup, ret_total_error)
  CALL write_test_status(ret_total_error, &
       ' Testing attributes', &
       total_error)

  ret_total_error = 0
  CALL group_test(cleanup, ret_total_error)
  CALL write_test_status(ret_total_error, &
       ' Testing groups', &
       total_error)

  ret_total_error = 0
  CALL test_h5o(cleanup, ret_total_error)
  CALL write_test_status(ret_total_error, &
       ' Testing object interface', &
       total_error)

  ret_total_error = 0
  CALL dtransform(cleanup, ret_total_error)
  CALL write_test_status(ret_total_error, &
       ' Testing data transform', &
       total_error)

  ret_total_error = 0
  CALL test_genprop_basic_class(cleanup, ret_total_error)
  CALL write_test_status(ret_total_error, &
       ' Testing basic generic properties', &
       total_error)

  ret_total_error = 0
  CALL test_h5s_encode(cleanup, ret_total_error)
  CALL write_test_status(ret_total_error, &
       ' Testing dataspace encoding and decoding', &
       total_error)

!  CALL test_hard_query(group_total_error)

  WRITE(*,*)

  WRITE(*,*) '                  ============================================  '
  WRITE(*, fmt = '(19x, 27a)', advance='NO') ' FORTRAN tests completed with '
  WRITE(*, fmt = '(i4)', advance='NO') total_error
  WRITE(*, fmt = '(12a)' ) ' error(s) ! '
  WRITE(*,*) '                  ============================================  '

  CALL h5close_f(error)

  ! if errors detected, exit with non-zero code.
  IF (total_error .NE. 0) CALL h5_exit_f (1)

END PROGRAM fortranlibtest

SUBROUTINE dtransform(cleanup, total_error)
  USE HDF5 ! This module contains all necessary modules 
  
  IMPLICIT NONE
  LOGICAL, INTENT(IN)  :: cleanup
  INTEGER, INTENT(INOUT) :: total_error

  INTEGER(HID_T) :: dxpl_id_c_to_f
  INTEGER(HID_T) :: file_id
  
  CHARACTER(LEN=15), PARAMETER :: c_to_f = "(9/5.0)*x + 123"
  INTEGER :: error
  CHARACTER(LEN=15) :: ptrgetTest
  CHARACTER(LEN=7) :: ptrgetTest_small
  CHARACTER(LEN=30) :: ptrgetTest_big

  INTEGER(SIZE_T) :: size


  CALL H5Fcreate_f("dtransform.h5", H5F_ACC_TRUNC_F, file_id, error)
  CALL check("dtransform.H5Fcreate_f", error, total_error)

  CALL H5Pcreate_f(H5P_DATASET_XFER_F, dxpl_id_c_to_f, error)
  CALL check("dtransform.H5Pcreate_f", error, total_error)
  
  CALL H5Pset_data_transform_f(dxpl_id_c_to_f, c_to_f, error)
  CALL check("dtransform.H5Pset_data_transform_f", error, total_error)

  CALL H5Pget_data_transform_f(dxpl_id_c_to_f, ptrgetTest, error, size=size)
  CALL check("dtransform.H5Pget_data_transform_f",  error, total_error)
  CALL VerifyString("dtransform.H5Pget_data_transform_f", c_to_f, ptrgetTest, total_error)
  CALL VERIFY("dtransform.H5Pget_data_transform_f", INT(size),15, total_error)

! check case when receiving buffer to small

  CALL H5Pget_data_transform_f(dxpl_id_c_to_f, ptrgetTest_small, error, size=size)
  CALL check("dtransform.H5Pget_data_transform_f",  error, total_error)
  CALL VerifyString("dtransform.H5Pget_data_transform_f", c_to_f(1:7), ptrgetTest_small, total_error)
  CALL VERIFY("dtransform.H5Pget_data_transform_f", INT(size),15, total_error)

! check case when receiving buffer to big

  CALL H5Pget_data_transform_f(dxpl_id_c_to_f, ptrgetTest_big, error, size=size)
  CALL check("dtransform.H5Pget_data_transform_f",  error, total_error)
  CALL VerifyString("dtransform.H5Pget_data_transform_f", c_to_f(1:15), ptrgetTest_big(1:15), total_error)
  CALL VERIFY("dtransform.H5Pget_data_transform_f", INT(size), 15, total_error)

  CALL H5Fclose_f(file_id, error)
  CALL check("H5Fclose_f", error, total_error)

  IF(cleanup) CALL h5_cleanup_f("dtransform", H5P_DEFAULT_F, error)
  CALL check("h5_cleanup_f", error, total_error)


END SUBROUTINE dtransform


!/****************************************************************
!**
!**  test_genprop_basic_class(): Test basic generic property list code.
!**      Tests creating new generic classes.
!**
!****************************************************************/

SUBROUTINE test_genprop_basic_class(cleanup, total_error)

  USE HDF5 ! This module contains all necessary modules 
  
  IMPLICIT NONE
  LOGICAL, INTENT(IN)  :: cleanup
  INTEGER, INTENT(INOUT) :: total_error

  INTEGER(HID_T) :: cid1		!/* Generic Property class ID */
  INTEGER(HID_T) :: cid2		!/* Generic Property class ID */

  CHARACTER(LEN=7) :: CLASS1_NAME = "Class 1"
  CHARACTER(LEN=7)  :: name              ! /* Name of class */
  CHARACTER(LEN=10) :: name_big          ! /* Name of class bigger buffer */
  CHARACTER(LEN=4)  :: name_small        ! /* Name of class smaller buffer*/
  INTEGER :: error
  INTEGER :: size
  LOGICAL :: flag

  !/* Output message about test being performed */

  !WRITE(*,*) "Testing Basic Generic Property List Class Creation Functionality"

  ! /* Create a new generic class, derived from the root of the class hierarchy */
  CALL H5Pcreate_class_f(H5P_ROOT_F, CLASS1_NAME, cid1, error)
  CALL check("H5Pcreate_class", error, total_error)

  ! /* Check class name */
  CALL H5Pget_class_name_f(cid1, name, size, error)
  CALL check("H5Pget_class_name", error, total_error)
  CALL VERIFY("H5Pget_class_name", size,7,error)
  CALL verifystring("H5Pget_class_name", name, CLASS1_NAME, error)
  IF(error.NE.0)THEN
     WRITE(*,*) 'Class names do not match! name=',name, 'CLASS1_NAME=',CLASS1_NAME
     total_error = total_error + 1
  ENDIF  
  
  ! /* Check class name smaller buffer*/
  CALL H5Pget_class_name_f(cid1, name_small, size, error)
  CALL check("H5Pget_class_name", error, total_error)
  CALL VERIFY("H5Pget_class_name", size,7,error)
  CALL verifystring("H5Pget_class_name", name_small(1:4), CLASS1_NAME(1:4), error)
  IF(error.NE.0)THEN
     WRITE(*,*) 'Class names do not match! name=',name_small(1:4), 'CLASS1_NAME=',CLASS1_NAME(1:4)
     total_error = total_error + 1
  ENDIF

  ! /* Check class name bigger buffer*/
  CALL H5Pget_class_name_f(cid1, name_big, size, error)
  CALL check("H5Pget_class_name", error, total_error)
  CALL VERIFY("H5Pget_class_name", size,7,error)
  CALL verifystring("H5Pget_class_name", TRIM(name_big), TRIM(CLASS1_NAME), error)
  IF(error.NE.0)THEN
     WRITE(*,*) 'Class names do not match! name=',TRIM(name_small), 'CLASS1_NAME=',TRIM(CLASS1_NAME)
     total_error = total_error + 1
  ENDIF

  ! /* Check class parent */
  CALL H5Pget_class_parent_f(cid1, cid2, error)
  CALL check("H5Pget_class_parent_f", error, total_error)

  ! /* Verify class parent correct */
  CALL H5Pequal_f(cid2, H5P_ROOT_F, flag, error)
  CALL check("H5Pequal_f", error, total_error)
  CALL verifylogical("H5Pequal_f", flag, .TRUE., total_error)


  ! /* Make certain false postives aren't being returned */
  CALL H5Pequal_f(cid2, H5P_FILE_CREATE_F, flag, error)
  CALL check("H5Pequal_f", error, total_error)
  CALL verifylogical("H5Pequal_f", flag, .FALSE., total_error)

  !/* Close parent class */
  CALL H5Pclose_class_f(cid2, error)
  CALL check("H5Pclose_class_f", error, total_error)


  !/* Close class */
  CALL H5Pclose_class_f(cid1, error)
  CALL check("H5Pclose_class_f", error, total_error)

END SUBROUTINE test_genprop_basic_class

SUBROUTINE test_h5s_encode(cleanup, total_error)

!/****************************************************************
!**
!**  test_h5s_encode(): Test H5S (dataspace) encoding and decoding.
!**
!****************************************************************/

  USE HDF5 ! This module contains all necessary modules 
  
  IMPLICIT NONE
  LOGICAL, INTENT(IN)  :: cleanup
  INTEGER, INTENT(INOUT) :: total_error

  INTEGER(hid_t) :: sid1, sid3!	/* Dataspace ID		*/
  INTEGER(hid_t) :: decoded_sid1, decoded_sid3
  INTEGER :: rank	!/* LOGICAL rank of dataspace	*/
  INTEGER(size_t) :: sbuf_size=0, scalar_size=0

! Make sure the size is large, need variable length in fortran 2003
  CHARACTER(LEN=288) :: sbuf
  CHARACTER(LEN=288) :: scalar_buf
! F2003  CHARACTER(LEN=:), ALLOCATABLE :: sbuf

!    unsigned char       *sbuf=NULL, *null_sbuf=NULL, *scalar_buf=NULL;
!    hsize_t		tdims[4];	/* Dimension array to test with */
  INTEGER(hsize_t) :: n ! /* Number of dataspace elements */

  INTEGER(hsize_t), DIMENSION(1:3) :: start = (/0, 0, 0/)
  INTEGER(hsize_t), DIMENSION(1:3) :: stride = (/2, 5, 3/)
  INTEGER(hsize_t), DIMENSION(1:3) :: count = (/2, 2, 2/)
  INTEGER(hsize_t), DIMENSION(1:3) :: BLOCK = (/1, 3, 1/)

  INTEGER :: space_type

!    H5S_sel_type        sel_type;
!    hssize_t            nblocks;
  !
  !Dataset dimensions 
  !
  INTEGER, PARAMETER :: SPACE1_DIM1= 3,  SPACE1_DIM2=15, SPACE1_DIM3=13

  INTEGER(HSIZE_T), DIMENSION(1:3) :: dims1 = (/SPACE1_DIM1, SPACE1_DIM2, SPACE1_DIM3/)
  INTEGER :: SPACE1_RANK = 3
  INTEGER :: error

  !/* Output message about test being performed */
  !WRITE(*,*) "Testing Dataspace Encoding and Decoding"

  !/*-------------------------------------------------------------------------
  ! * Test encoding and decoding of simple dataspace and hyperslab selection.
  ! *-------------------------------------------------------------------------
  ! */
  
  CALL H5Screate_simple_f(SPACE1_RANK, dims1, sid1, error)
  CALL check("H5Screate_simple", error, total_error)
  
  CALL h5sselect_hyperslab_f(sid1, H5S_SELECT_SET_F, &
       start, count, error, stride=stride, BLOCK=BLOCK) 
  CALL check("h5sselect_hyperslab_f", error, total_error)
  
  
  !/* Encode simple data space in a buffer */

  !         First find the buffer size
  CALL H5Sencode_f(sid1, sbuf, sbuf_size, error)
  CALL check("H5Sencode", error, total_error)

  ! In fortran 2003 we can allocate the needed character size here

  ! /* Try decoding bogus buffer */

  CALL H5Sdecode_f(sbuf, decoded_sid1, error)
  CALL VERIFY("H5Sdecode", error, -1, total_error)

  CALL H5Sencode_f(sid1, sbuf, sbuf_size, error)
  CALL check("H5Sencode", error, total_error)

  ! /* Decode from the dataspace buffer and return an object handle */
  CALL H5Sdecode_f(sbuf, decoded_sid1, error)
  CALL check("H5Sdecode", error, total_error)


  ! /* Verify the decoded dataspace */
  CALL h5sget_simple_extent_npoints_f(decoded_sid1, n, error)
  CALL check("h5sget_simple_extent_npoints_f", error, total_error)
  CALL VERIFY("h5sget_simple_extent_npoints_f", INT(n), SPACE1_DIM1 * SPACE1_DIM2 * SPACE1_DIM3, &
       total_error)

!!$
!!$    rank = H5Sget_simple_extent_ndims(decoded_sid1);
!!$    CHECK(rank, FAIL, "H5Sget_simple_extent_ndims");
!!$    VERIFY(rank, SPACE1_RANK, "H5Sget_simple_extent_ndims");
!!$
!!$    rank = H5Sget_simple_extent_dims(decoded_sid1, tdims, NULL);
!!$    CHECK(rank, FAIL, "H5Sget_simple_extent_dims");
!!$    VERIFY(HDmemcmp(tdims, dims1, SPACE1_RANK * sizeof(hsize_t)), 0,
!!$	   "H5Sget_simple_extent_dims");
!!$
!!$    /* Verify hyperslabe selection */
!!$    sel_type = H5Sget_select_type(decoded_sid1);
!!$    VERIFY(sel_type, H5S_SEL_HYPERSLABS, "H5Sget_select_type");
!!$
!!$    nblocks = H5Sget_select_hyper_nblocks(decoded_sid1);
!!$    VERIFY(nblocks, 2*2*2, "H5Sget_select_hyper_nblocks");
!!$
  !
  !Close the dataspace for the dataset.
  !
  CALL h5sclose_f(sid1, error)
  CALL check("h5sclose_f", error, total_error)
 
  CALL h5sclose_f(decoded_sid1, error)
  CALL check("h5sclose_f", error, total_error)    

  ! /*-------------------------------------------------------------------------
  !  * Test encoding and decoding of scalar dataspace.
  !  *-------------------------------------------------------------------------
  !  */
  ! /* Create scalar dataspace */

  CALL H5Screate_f(H5S_SCALAR_F, sid3, error)
  CALL check("H5Screate_f",error, total_error)

  ! /* Encode scalar data space in a buffer */

  !        First find the buffer size
  CALL H5Sencode_f(sid3, scalar_buf, scalar_size, error)
  CALL check("H5Sencode_f", error, total_error)

  ! encode

  CALL H5Sencode_f(sid3, scalar_buf, scalar_size, error)
  CALL check("H5Sencode_f", error, total_error)


  ! /* Decode from the dataspace buffer and return an object handle */

  CALL H5Sdecode_f(scalar_buf, decoded_sid3, error)
  CALL check("H5Sdecode_f", error, total_error)


  ! /* Verify extent type */

  CALL H5Sget_simple_extent_type_f(decoded_sid3, space_type, error)
  CALL check("H5Sget_simple_extent_type_f", error, total_error)
  CALL VERIFY("H5Sget_simple_extent_type_f", space_type, H5S_SCALAR_F, total_error)

  ! /* Verify decoded dataspace */
  CALL h5sget_simple_extent_npoints_f(decoded_sid3, n, error)
  CALL check("h5sget_simple_extent_npoints_f", error, total_error)
  CALL VERIFY("h5sget_simple_extent_npoints_f", INT(n), 1, total_error)

  CALL H5Sget_simple_extent_ndims_f(decoded_sid3, rank, error)
  CALL CHECK("H5Sget_simple_extent_ndims_f", error, total_error)
  CALL VERIFY("H5Sget_simple_extent_ndims_f", rank, 0, total_error )

  CALL h5sclose_f(sid3, error)
  CALL check("h5sclose_f", error, total_error)
 
  CALL h5sclose_f(decoded_sid3, error)
  CALL check("h5sclose_f", error, total_error)

END SUBROUTINE test_h5s_encode