diff options
Diffstat (limited to 'fortran')
| -rw-r--r-- | fortran/test/tH5A.f90 | 29 | ||||
| -rw-r--r-- | fortran/test/tH5P.f90 | 24 | ||||
| -rw-r--r-- | fortran/test/tH5P_F03.f90 | 17 | ||||
| -rw-r--r-- | fortran/test/tH5T.f90 | 20 | ||||
| -rw-r--r-- | fortran/test/tH5T_F03.f90 | 37 | ||||
| -rw-r--r-- | fortran/test/tH5VL.f90 | 10 | ||||
| -rw-r--r-- | fortran/test/tf.f90 | 58 | ||||
| -rw-r--r-- | fortran/test/tf_include.f90 | 37 |
8 files changed, 136 insertions, 96 deletions
diff --git a/fortran/test/tH5A.f90 b/fortran/test/tH5A.f90 index b43707c..5ba2d62 100644 --- a/fortran/test/tH5A.f90 +++ b/fortran/test/tH5A.f90 @@ -117,7 +117,7 @@ CONTAINS ! !general purpose integer ! - INTEGER :: i, j + INTEGER :: i, j, wp INTEGER :: error ! Error flag ! @@ -129,8 +129,6 @@ CONTAINS !data buffers ! INTEGER, DIMENSION(NX,NY) :: data_in - LOGICAL :: differ - ! !Initialize data_in buffer @@ -519,27 +517,22 @@ CONTAINS data_dims(1) = 1 CALL h5aread_f(attr3_id, H5T_NATIVE_DOUBLE, aread_double_data, data_dims, error) CALL check("h5aread_f",error,total_error) - differ = .FALSE. - if(abs(aread_double_data(1)- 3.459D0) .ge. 1.D-08) then - differ = .TRUE. - endif - ! This is a temporary fix - !CALL compare_floats(aread_double_data(1), 3.459D0, differ) - IF (differ) THEN - WRITE(*,*) "Read back double attrbute is wrong", aread_double_data(1) - total_error = total_error + 1 - END IF + + IF( .NOT.(aread_double_data(1) .REALEQ. 3.459_Fortran_DOUBLE) )THEN + WRITE(*,*) "Read back double attrbute is wrong", aread_double_data(1) + total_error = total_error + 1 + ENDIF ! !read the real attribute data back to memory ! data_dims(1) = 1 CALL h5aread_f(attr4_id, H5T_NATIVE_REAL, aread_real_data, data_dims, error) CALL check("h5aread_f",error,total_error) - CALL compare_floats(aread_real_data(1), 4.0, differ) - IF (differ) THEN - WRITE(*,*) "Read back real attrbute is wrong ", aread_real_data - total_error = total_error + 1 - END IF + + IF( .NOT.(aread_real_data(1) .REALEQ. REAL(4.0)) )THEN + WRITE(*,*) "Read back real attrbute is wrong", aread_real_data(1) + total_error = total_error + 1 + ENDIF ! !read the Integer attribute data back to memory ! diff --git a/fortran/test/tH5P.f90 b/fortran/test/tH5P.f90 index 454f507..0ed12d2 100644 --- a/fortran/test/tH5P.f90 +++ b/fortran/test/tH5P.f90 @@ -450,8 +450,6 @@ SUBROUTINE test_chunk_cache(cleanup, total_error) INTEGER(size_t) rdcc_nelmts INTEGER(size_t) rdcc_nbytes REAL :: rdcc_w0 - LOGICAL :: differ - CALL h5_fixname_f(filename, fix_filename, H5P_DEFAULT_F, error) IF (error .NE. 0) THEN @@ -474,8 +472,8 @@ SUBROUTINE test_chunk_cache(cleanup, total_error) CALL check("H5Pget_chunk_cache_f", error, total_error) CALL VERIFY("H5Pget_chunk_cache_f", INT(nslots_1), INT(nslots_4), total_error) CALL VERIFY("H5Pget_chunk_cache_f", INT(nbytes_1), INT(nbytes_4), total_error) - CALL compare_floats(w0_1, w0_4, differ) - IF(differ)THEN + + IF( .NOT.( w0_1 .REALEQ. w0_4) )THEN CALL VERIFYlogical("H5Pget_chunk_cache_f", .TRUE., .FALSE., total_error) ENDIF @@ -533,8 +531,7 @@ SUBROUTINE test_chunk_cache(cleanup, total_error) CALL check("H5Pget_chunk_cache_f", error, total_error) CALL VERIFY("H5Pget_chunk_cache_f", INT(nslots_2), INT(nslots_4), total_error) CALL VERIFY("H5Pget_chunk_cache_f", INT(nbytes_2), INT(nbytes_4), total_error) - CALL compare_floats(w0_2, w0_4, differ) - IF(differ)THEN + IF( .NOT.( w0_2 .REALEQ. w0_4) )THEN CALL VERIFYlogical("H5Pget_chunk_cache_f", .TRUE., .FALSE., total_error) ENDIF CALL H5Pclose_f(dapl2,error) @@ -566,8 +563,7 @@ SUBROUTINE test_chunk_cache(cleanup, total_error) CALL check("H5Pget_chunk_cache_f", error, total_error) CALL VERIFY("H5Pget_chunk_cache_f", INT(nslots_3), INT(nslots_4), total_error) CALL VERIFY("H5Pget_chunk_cache_f", INT(nbytes_2), INT(nbytes_4), total_error) - CALL compare_floats(w0_3, w0_4, differ) - IF(differ)THEN + IF( .NOT.( w0_3 .REALEQ. w0_4) )THEN CALL VERIFYlogical("H5Pget_chunk_cache_f4", .TRUE., .FALSE., total_error) ENDIF CALL H5Pclose_f(dapl2,error) @@ -587,8 +583,7 @@ SUBROUTINE test_chunk_cache(cleanup, total_error) CALL check("H5Pget_chunk_cache_f", error, total_error) CALL VERIFY("H5Pget_chunk_cache_f", INT(nslots_2), INT(nslots_4), total_error) CALL VERIFY("H5Pget_chunk_cache_f", INT(nbytes_2), INT(nbytes_4), total_error) - CALL compare_floats(w0_2, w0_4, differ) - IF(differ)THEN + IF( .NOT.( w0_2 .REALEQ. w0_4) ) THEN CALL VERIFYlogical("H5Pget_chunk_cache_f", .TRUE., .FALSE., total_error) ENDIF CALL H5Pclose_f(dapl2,error) @@ -608,8 +603,7 @@ SUBROUTINE test_chunk_cache(cleanup, total_error) CALL check("H5Pget_chunk_cache_f", error, total_error) CALL VERIFY("H5Pget_chunk_cache_f", INT(nslots_2), INT(nslots_4), total_error) CALL VERIFY("H5Pget_chunk_cache_f", INT(nbytes_2), INT(nbytes_4), total_error) - CALL compare_floats(w0_2, w0_4, differ) - IF(differ)THEN + IF( .NOT.( w0_2 .REALEQ. w0_4) ) THEN CALL VERIFYlogical("H5Pget_chunk_cache_f", .TRUE., .FALSE., total_error) ENDIF ! Don't close dapl2, we will use it in the next section @@ -646,8 +640,7 @@ SUBROUTINE test_chunk_cache(cleanup, total_error) CALL check("H5Pget_chunk_cache_f", error, total_error) CALL VERIFY("H5Pget_chunk_cache_f", INT(nslots_2), INT(nslots_4), total_error) CALL VERIFY("H5Pget_chunk_cache_f", INT(nbytes_2), INT(nbytes_4), total_error) - CALL compare_floats(w0_2, w0_4, differ) - IF(differ)THEN + IF( .NOT.( w0_2 .REALEQ. w0_4) ) THEN CALL VERIFYlogical("H5Pget_chunk_cache_f", .TRUE., .FALSE., total_error) ENDIF @@ -672,8 +665,7 @@ SUBROUTINE test_chunk_cache(cleanup, total_error) CALL check("H5Pget_chunk_cache_f", error, total_error) CALL VERIFY("H5Pget_chunk_cache_f", INT(nslots_3), INT(nslots_4), total_error) CALL VERIFY("H5Pget_chunk_cache_f", INT(nbytes_2), INT(nbytes_4), total_error) - CALL compare_floats(w0_3, w0_4, differ) - IF(differ)THEN + IF( .NOT.( w0_3 .REALEQ. w0_4) ) THEN CALL VERIFYlogical("H5Pget_chunk_cache_f", .TRUE., .FALSE., total_error) ENDIF diff --git a/fortran/test/tH5P_F03.f90 b/fortran/test/tH5P_F03.f90 index 9f71a73..af8cad0 100644 --- a/fortran/test/tH5P_F03.f90 +++ b/fortran/test/tH5P_F03.f90 @@ -118,7 +118,6 @@ SUBROUTINE test_create(total_error) INTEGER :: error INTEGER(SIZE_T) :: h5off TYPE(C_PTR) :: f_ptr - LOGICAL :: differ1, differ2 !/* ! * Create a file. @@ -205,20 +204,8 @@ SUBROUTINE test_create(total_error) CALL H5Pget_fill_value_f(dcpl, comp_type_id, f_ptr, error) CALL check("H5Pget_fill_value_f", error, total_error) - differ1 = .FALSE. - differ2 = .FALSE. - if(abs(rd_c%a - fill_ctype%a) .ge. 1.D-08) then - differ1 = .TRUE. - endif - ! This is a workaround; needs to be fixed - !CALL compare_floats(rd_c%a, fill_ctype%a, differ1) - if(abs(rd_c%y - fill_ctype%y) .ge. 1.D-08) then - differ2 = .TRUE. - endif - ! This is a workaround; needs to be fixed - !CALL compare_floats(rd_c%y, fill_ctype%y, differ2) - IF( differ1 .OR. & - differ2 .OR. & + IF( .NOT.(rd_c%a .REALEQ. fill_ctype%a) .OR. & + .NOT.(rd_c%y .REALEQ. fill_ctype%y) .OR. & rd_c%x .NE. fill_ctype%x .OR. & rd_c%z .NE. fill_ctype%z )THEN diff --git a/fortran/test/tH5T.f90 b/fortran/test/tH5T.f90 index aac5f33..cb8e27c 100644 --- a/fortran/test/tH5T.f90 +++ b/fortran/test/tH5T.f90 @@ -112,7 +112,7 @@ CONTAINS INTEGER(HID_T) :: decoded_tid1 INTEGER(HID_T) :: fixed_str1, fixed_str2 - LOGICAL :: are_equal, differ + LOGICAL :: are_equal INTEGER(SIZE_T), PARAMETER :: str_size = 10 INTEGER(SIZE_T) :: query_size @@ -528,13 +528,8 @@ CONTAINS CALL h5dread_f(dset_id, dt3_id, double_member_out, data_dims, error) CALL check("h5dread_f", error, total_error) do i = 1, dimsize - differ = .FALSE. - if (abs(double_member_out(i) - double_member(i)) .ge. 1.D-08) THEN - differ = .TRUE. - endif - ! This is temorary fix until we figure out how to compare floats - !CALL compare_floats(double_member_out(i), double_member(i), differ) - if (differ) then + + IF( .NOT.(double_member_out(i) .REALEQ. double_member(i)) ) THEN write(*,*) " Wrong double precision data is read back " total_error = total_error + 1 endif @@ -552,11 +547,10 @@ CONTAINS CALL h5dread_f(dset_id, dt4_id, real_member_out, data_dims, error) CALL check("h5dread_f", error, total_error) do i = 1, dimsize - CALL compare_floats(real_member_out(i), real_member(i), differ) - if (differ) then - write(*,*) " Wrong real precision data is read back " - total_error = total_error + 1 - endif + IF( .NOT.(real_member_out(i) .REALEQ. real_member(i) ) ) THEN + WRITE(*,*) " Wrong real precision data is read back " + total_error = total_error + 1 + ENDIF enddo ! ! *----------------------------------------------------------------------- diff --git a/fortran/test/tH5T_F03.f90 b/fortran/test/tH5T_F03.f90 index bd6a701..f21f84a 100644 --- a/fortran/test/tH5T_F03.f90 +++ b/fortran/test/tH5T_F03.f90 @@ -90,7 +90,7 @@ SUBROUTINE test_array_compound_atomic(total_error) INTEGER :: error ! Generic RETURN value INTEGER :: namelen - LOGICAL :: flag, differ + LOGICAL :: flag TYPE(C_PTR) :: f_ptr ! Needed to pass the pointer, for g95 compiler to work @@ -258,8 +258,7 @@ SUBROUTINE test_array_compound_atomic(total_error) PRINT*, 'ERROR: Wrong integer data is read back by H5Dread_f ' total_error = total_error + 1 ENDIF - CALL compare_floats(wdata(i,j)%f, rdata(i,j)%f, differ) - IF(differ)THEN + IF( .NOT.( wdata(i,j)%f .REALEQ. rdata(i,j)%f) ) THEN PRINT*, 'ERROR: Wrong real data is read back by H5Dread_f ' total_error = total_error + 1 ENDIF @@ -349,7 +348,6 @@ END SUBROUTINE test_array_compound_atomic INTEGER(SIZE_T) :: attrlen ! Length of the attribute string TYPE(c_ptr) :: f_ptr - LOGICAL :: differ ! Initialize array data to write DO i = 1, SPACE1_DIM1 @@ -622,8 +620,8 @@ END SUBROUTINE test_array_compound_atomic total_error = total_error + 1 ENDIF DO k = 1, ARRAY2_DIM1 - CALL compare_floats(wdata(i,j)%f(k), rdata(i,j)%f(k), differ) - IF(differ)THEN + + IF(wdata(i,j)%f(k).NE.rdata(i,j)%f(k))THEN PRINT*, 'ERROR: Wrong real array data is read back by H5Dread_f ' total_error = total_error + 1 ENDIF @@ -722,7 +720,6 @@ END SUBROUTINE test_array_compound_atomic INTEGER :: error TYPE(c_ptr) :: f_ptr - LOGICAL :: differ ! Initialize the data ! ------------------- @@ -834,13 +831,12 @@ END SUBROUTINE test_array_compound_atomic PRINT*, 'ERROR: Wrong integer data is read back by H5Dread_f ' total_error = total_error + 1 ENDIF - CALL compare_floats(cf(i)%b(j), cfr(i)%b(j), differ) - IF(differ)THEN + + IF( .NOT.(cf(i)%b(j) .REALEQ. cfr(i)%b(j) ) ) THEN PRINT*, 'ERROR: Wrong real data is read back by H5Dread_f ' total_error = total_error + 1 ENDIF - CALL compare_floats(cf(i)%c(j), cfr(i)%c(j), differ) - IF(differ)THEN + IF( .NOT.(cf(i)%c(j) .REALEQ. cfr(i)%c(j) ) ) THEN PRINT*, 'ERROR: Wrong double data is read back by H5Dread_f ' total_error = total_error + 1 ENDIF @@ -903,8 +899,7 @@ END SUBROUTINE test_array_compound_atomic DO i = 1, LENGTH DO j = 1, ALEN - CALL compare_floats(fld(i)%b(j), fldr(i)%b(j), differ) - IF(differ)THEN + IF( .NOT.(fld(i)%b(j) .REALEQ. fldr(i)%b(j) ) ) THEN PRINT*, 'ERROR: Wrong real data is read back by H5Dread_f ' total_error = total_error + 1 ENDIF @@ -935,13 +930,11 @@ END SUBROUTINE test_array_compound_atomic PRINT*, 'ERROR: Wrong integer data is read back by H5Dread_f ' total_error = total_error + 1 ENDIF - CALL compare_floats(cf(i)%b(j), cfr(i)%b(j), differ) - IF(differ)THEN + IF( .NOT.(cf(i)%b(j) .REALEQ. cfr(i)%b(j) ) ) THEN PRINT*, 'ERROR: Wrong real data is read back by H5Dread_f ' total_error = total_error + 1 ENDIF - CALL compare_floats(cf(i)%c(j), cfr(i)%c(j), differ) - IF(differ)THEN + IF( .NOT.(cf(i)%c(j) .REALEQ. cfr(i)%c(j) ) ) THEN PRINT*, 'ERROR: Wrong double data is read back by H5Dread_f ' total_error = total_error + 1 ENDIF @@ -995,13 +988,11 @@ END SUBROUTINE test_array_compound_atomic PRINT*, 'ERROR: Wrong integer data is read back by H5Dread_f ' total_error = total_error + 1 ENDIF - CALL compare_floats(cf(i)%b(j),cfr(i)%b(j), differ) - IF(differ)THEN + IF( .NOT.(cf(i)%b(j) .REALEQ. cfr(i)%b(j) ) ) THEN PRINT*, 'ERROR: Wrong real data is read back by H5Dread_f ' total_error = total_error + 1 ENDIF - CALL compare_floats(cf(i)%c(j), cfr(i)%c(j), differ) - IF(differ)THEN + IF( .NOT.(cf(i)%c(j) .REALEQ. cfr(i)%c(j) ) ) THEN PRINT*, 'ERROR: Wrong double data is read back by H5Dread_f ' total_error = total_error + 1 ENDIF @@ -3006,7 +2997,6 @@ SUBROUTINE test_nbit(total_error ) LOGICAL :: status INTEGER(hsize_t) :: i, j TYPE(C_PTR) :: f_ptr - LOGICAL :: differ ! check to see if filter is available CALL H5Zfilter_avail_f(H5Z_FILTER_NBIT_F, status, error) @@ -3079,8 +3069,7 @@ SUBROUTINE test_nbit(total_error ) i_loop: DO i = 1, dims(1) j_loop: DO j = 1, dims(2) IF(.NOT.(orig_data(i,j).EQ.orig_data(i,j))) CYCLE ! skip IF value is NaN - CALL compare_floats(new_data(i,j), orig_data(i,j), differ) - IF(differ)THEN + IF( .NOT.(new_data(i,j) .REALEQ. orig_data(i,j) ) ) THEN total_error = total_error + 1 WRITE(*,'(" Read different values than written.")') WRITE(*,'(" At index ", 2(1X,I0))') i, j diff --git a/fortran/test/tH5VL.f90 b/fortran/test/tH5VL.f90 index d34b42c..6803f59 100644 --- a/fortran/test/tH5VL.f90 +++ b/fortran/test/tH5VL.f90 @@ -226,7 +226,6 @@ CONTAINS INTEGER(SIZE_T) max_len INTEGER(HID_T) :: vl_type_id LOGICAL :: vl_flag - LOGICAL :: differ ! ! Initialize the vl_int_data array. @@ -331,11 +330,10 @@ CONTAINS CALL check("h5dread_real_f", error, total_error) do ih = 1, data_dims(2) do jh = 1, len_out(ih) - CALL compare_floats(vl_real_data(jh,ih), vl_real_data_out(jh,ih), differ) - if(differ) then - total_error = total_error + 1 - write(*,*) "h5dread_vl_f returned incorrect data" - endif + IF( .NOT.(vl_real_data(jh,ih) .REALEQ. vl_real_data_out(jh,ih)) ) THEN + total_error = total_error + 1 + WRITE(*,*) "h5dread_vl_f returned incorrect data" + ENDIF enddo if (len(ih) .ne. len_out(ih)) then total_error = total_error + 1 diff --git a/fortran/test/tf.f90 b/fortran/test/tf.f90 index cfa403a..78c7034 100644 --- a/fortran/test/tf.f90 +++ b/fortran/test/tf.f90 @@ -28,13 +28,63 @@ ! !***** +! Define single, double and quadprecision + +MODULE h5_kinds + INTEGER, PARAMETER :: sp = SELECTED_REAL_KIND(6, 37) + INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(15, 307) + INTEGER, PARAMETER :: qp = SELECTED_REAL_KIND(33, 4931) +END MODULE h5_kinds + +! Functions for Comparing two REAL numbers that +! are quad, double and single precision. + +MODULE single_test_eqv + USE h5_kinds, ONLY: wp => sp + IMPLICIT NONE +CONTAINS + INCLUDE 'tf_include.f90' +END MODULE single_test_eqv + +MODULE double_test_eqv + USE h5_kinds, ONLY: wp => dp + IMPLICIT NONE +CONTAINS + INCLUDE 'tf_include.f90' +END MODULE double_test_eqv + +MODULE quad_test_eqv + USE h5_kinds, ONLY: wp => qp + IMPLICIT NONE +CONTAINS + INCLUDE 'tf_include.f90' +END MODULE quad_test_eqv + +! Interface operator for comparing reals + +MODULE generic_eqv + + USE single_test_eqv, ONLY: test_eqv_1 => test_eqv + USE double_test_eqv, ONLY: test_eqv_2 => test_eqv + USE quad_test_eqv , ONLY: test_eqv_3 => test_eqv + IMPLICIT NONE + PRIVATE + PUBLIC OPERATOR(.realeq.) + + INTERFACE OPERATOR(.realeq.) + MODULE PROCEDURE test_eqv_1, test_eqv_2, test_eqv_3 + END INTERFACE + +END MODULE generic_eqv + MODULE TH5_MISC + USE generic_eqv -INTERFACE compare_floats - MODULE PROCEDURE compare_floats_4 - MODULE PROCEDURE compare_floats_8 -END INTERFACE + INTERFACE compare_floats + MODULE PROCEDURE compare_floats_4 + MODULE PROCEDURE compare_floats_8 + END INTERFACE CONTAINS diff --git a/fortran/test/tf_include.f90 b/fortran/test/tf_include.f90 new file mode 100644 index 0000000..bb7fd1b --- /dev/null +++ b/fortran/test/tf_include.f90 @@ -0,0 +1,37 @@ +!****h* root/fortran/test/tf_include.f90 +! +! NAME +! tf_include.f90 +! +! FUNCTION +! Contains overloaded operators for the hdf5 fortran tests, include in +! tf.f90 +! +! COPYRIGHT +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! 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. * +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! +! CONTAINS SUBROUTINES +! test_eqv +! +!***** + +! Function for comparing two REAL(KIND=*) numbers. + +PURE FUNCTION test_eqv(a,b) + LOGICAL test_eqv + REAL(wp), INTENT (in):: a,b + test_eqv = ABS(a-b) .LT. 1.e-8 +END FUNCTION test_eqv |