From f8cc1a038076bcb95128580e69f05f525a9ee21c Mon Sep 17 00:00:00 2001 From: Ian Porter Date: Sun, 4 Aug 2019 22:17:43 -0400 Subject: [PATCH 1/6] Format consistency. WIP: Start of binary support --- CMakeLists.txt | 1 + src/legacy/VTK_io.f90 | 14 +- src/legacy/VTK_io_procedures.f90 | 83 +++---- src/legacy/VTK_vars.f90 | 8 +- src/modern/VTK_DataArray_procedures.f90 | 27 +-- src/modern/VTK_formats_types.f90 | 24 ++ src/modern/VTK_piece_element_procedures.f90 | 39 ++-- src/utilities/Misc_procedures.f90 | 14 +- src/utilities/Precision.f90 | 5 +- src/utilities/xml.f90 | 50 +++- src/utilities/xml_procedures.f90 | 220 ++++++++++++++---- tests/integration/serial/Rectilinear_grid.f90 | 15 +- tests/unit/DataArray_unit.f90 | 7 +- 13 files changed, 356 insertions(+), 151 deletions(-) create mode 100644 src/modern/VTK_formats_types.f90 diff --git a/CMakeLists.txt b/CMakeLists.txt index 8dbe6fc..3a1c568 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -103,6 +103,7 @@ set(VTKmofo_interfaces legacy/VTK_vars.f90 modern/VTK_DataArray.f90 modern/VTK_element.f90 + modern/VTK_formats_types.f90 modern/VTK_piece_element.f90 modern/VTK_serial_file.f90 modern/VTK_serial_Grid.f90 diff --git a/src/legacy/VTK_io.f90 b/src/legacy/VTK_io.f90 index e5237a0..f94b1eb 100644 --- a/src/legacy/VTK_io.f90 +++ b/src/legacy/VTK_io.f90 @@ -28,7 +28,7 @@ MODULE vtk_io INTERFACE MODULE SUBROUTINE vtk_legacy_full_write (geometry, celldata, pointdata, celldatasets, pointdatasets, & - & unit, filename, multiple_io, data_type, title) + & unit, filename, multiple_io, format, title) IMPLICIT NONE !! author: Ian Porter !! date: 12/1/2017 @@ -41,7 +41,7 @@ MODULE SUBROUTINE vtk_legacy_full_write (geometry, celldata, pointdata, celldata TYPE(attributes), DIMENSION(:), INTENT(IN), OPTIONAL :: celldatasets !! TYPE(attributes), DIMENSION(:), INTENT(IN), OPTIONAL :: pointdatasets !! INTEGER(i4k), INTENT(IN), OPTIONAL :: unit !! VTK file unit - INTEGER(i4k), INTENT(IN), OPTIONAL :: data_type !! Identifier to write in ascii or Binary + INTEGER(i4k), INTENT(IN), OPTIONAL :: format !! Identifier to write in ascii or Binary LOGICAL, INTENT(IN), OPTIONAL :: multiple_io !! Identifier as to whether there will be multiple files written !! (i.e., time-dependent output) CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: filename !! VTK filename @@ -75,7 +75,7 @@ MODULE SUBROUTINE vtk_legacy_finalize (finished) END SUBROUTINE vtk_legacy_finalize MODULE SUBROUTINE vtk_legacy_read (unit, geometry, celldata, pointdata, celldatasets, pointdatasets, & - & filename, data_type, title) + & filename, format, title) IMPLICIT NONE !! author: Ian Porter !! date: 12/20/2017 @@ -87,15 +87,15 @@ MODULE SUBROUTINE vtk_legacy_read (unit, geometry, celldata, pointdata, celldata CLASS(attribute), INTENT(INOUT), OPTIONAL :: pointdata !! TYPE(attributes), DIMENSION(:), INTENT(INOUT), OPTIONAL :: celldatasets !! TYPE(attributes), DIMENSION(:), INTENT(INOUT), OPTIONAL :: pointdatasets !! - INTEGER(i4k), INTENT(IN) :: unit !! VTK file unit - INTEGER(i4k), INTENT(OUT), OPTIONAL :: data_type !! Identifier as to whether VTK file is ascii or Binary + INTEGER(i4k), INTENT(IN) :: unit !! VTK file unit + INTEGER(i4k), INTENT(OUT), OPTIONAL :: format !! Identifier as to whether VTK file is ascii or Binary CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: filename !! VTK filename CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: title !! Title to be written on title line (#2) in output file END SUBROUTINE vtk_legacy_read MODULE SUBROUTINE vtk_serial_full_write (geometry, celldata, pointdata, celldatasets, pointdatasets, & - & unit, filename, multiple_io, data_type, title) + & unit, filename, multiple_io, format, title) IMPLICIT NONE !! author: Ian Porter !! date: 5/08/2019 @@ -108,7 +108,7 @@ MODULE SUBROUTINE vtk_serial_full_write (geometry, celldata, pointdata, celldata TYPE(attributes), DIMENSION(:), INTENT(IN), OPTIONAL :: celldatasets !! TYPE(attributes), DIMENSION(:), INTENT(IN), OPTIONAL :: pointdatasets !! INTEGER(i4k), INTENT(IN), OPTIONAL :: unit !! VTK file unit - INTEGER(i4k), INTENT(IN), OPTIONAL :: data_type !! Identifier to write in ascii or Binary + INTEGER(i4k), INTENT(IN), OPTIONAL :: format !! Identifier to write in ascii or Binary LOGICAL, INTENT(IN), OPTIONAL :: multiple_io !! Identifier as to whether there will be multiple files written !! (i.e., time-dependent output) CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: filename !! VTK filename diff --git a/src/legacy/VTK_io_procedures.f90 b/src/legacy/VTK_io_procedures.f90 index 83f4295..ed56136 100644 --- a/src/legacy/VTK_io_procedures.f90 +++ b/src/legacy/VTK_io_procedures.f90 @@ -15,24 +15,28 @@ MODULE PROCEDURE vtk_legacy_full_write USE Misc, ONLY : to_uppercase - USE vtk_vars, ONLY : default_fn, default_title, filetype, vtkfilename, vtktitle, ascii, binary, & - & version, fcnt, file_extension + USE vtk_vars, ONLY : default_fn, default_title, vtkfilename, vtktitle, version, fcnt, file_extension + USE XML, ONLY : convert_format_to_string, file_format_text, file_format, ascii, binary, format_ascii, format_binary IMPLICIT NONE !! author: Ian Porter !! date: 12/1/2017 !! !! This subroutine writes the legacy vtk output file !! - INTEGER(i4k) :: i, inputstat - CHARACTER(LEN=:), ALLOCATABLE :: filetype_text + INTEGER(i4k) :: i, inputstat CHARACTER(LEN=11) :: fm ! Clear out any pre-existing data - IF (ALLOCATED(vtkfilename)) DEALLOCATE(vtkfilename) - IF (ALLOCATED(form)) DEALLOCATE(form) - IF (ALLOCATED(vtktitle)) DEALLOCATE(vtktitle) + IF (ALLOCATED(vtkfilename)) DEALLOCATE(vtkfilename) + IF (ALLOCATED(form)) DEALLOCATE(form) + IF (ALLOCATED(vtktitle)) DEALLOCATE(vtktitle) + IF (ALLOCATED(file_format_text)) DEALLOCATE(file_format_text) - IF (PRESENT(data_type)) filetype = data_type !! Calling program provided what file type to use for vtk file + IF (PRESENT(format)) THEN + file_format = format !! Calling program provided what file type to use for vtk file + ELSE + file_format = ascii !! Default to ascii + END IF IF (PRESENT(filename)) THEN ALLOCATE(vtkfilename, source=filename) !! Calling program provided a filename ELSE @@ -61,51 +65,46 @@ IF (PRESENT(unit)) THEN newunit = unit INQUIRE(unit=newunit, opened=file_was_already_open) !! Check to see if file is already open - IF (.NOT. file_was_already_open) THEN !! File is not yet open. Determine format from filetype - SELECT CASE (filetype) + IF (.NOT. file_was_already_open) THEN !! File is not yet open. Determine format from file_format + SELECT CASE (file_format) CASE (ascii) ALLOCATE(form, source='formatted') - ALLOCATE(filetype_text, source='ASCII') CASE (binary) ALLOCATE(form, source='unformatted') - ALLOCATE(filetype_text, source='BINARY') CASE DEFAULT - WRITE(*,*) 'Warning: filetype is incorrectly defined. Will default to ASCII' - ALLOCATE(form, source='formatted') - ALLOCATE(filetype_text, source='ASCII') + ERROR STOP 'Error: file_format is incorrectly defined in vtk_legacy_full_write' END SELECT + ALLOCATE(file_format_text, source=convert_format_to_string(file_format)) OPEN(unit=newunit, file=vtkfilename, iostat=inputstat, status='REPLACE', form=form) !! Open the VTK file ELSE !! File is already open. Determine format based on file format INQUIRE(unit=newunit,form=fm) SELECT CASE (TO_UPPERCASE(TRIM(fm))) CASE ('FORMATTED') - ALLOCATE(filetype_text, source='ASCII') + ALLOCATE(file_format_text, source=format_ascii) CASE DEFAULT - ALLOCATE(filetype_text, source='BINARY') + ALLOCATE(file_format_text, source=format_binary) END SELECT END IF ELSE - !! No unit # provided. Make determination by value set for filetype - SELECT CASE (filetype) + !! No unit # provided. Make determination by value set for file_format + SELECT CASE (file_format) CASE (ascii) ALLOCATE(form, source='formatted') - ALLOCATE(filetype_text, source='ASCII') CASE (binary) ALLOCATE(form, source='unformatted') - ALLOCATE(filetype_text, source='BINARY') CASE DEFAULT - WRITE(*,*) 'Warning: filetype is incorrectly defined. Will default to ASCII' + WRITE(*,*) 'Warning: file_format is incorrectly defined. Will default to ASCII' ALLOCATE(form, source='formatted') - ALLOCATE(filetype_text, source='ASCII') END SELECT + ALLOCATE(file_format_text, source=convert_format_to_string(file_format)) OPEN(newunit=newunit, file=vtkfilename, iostat=inputstat, status='REPLACE', form=form) !! Open the VTK file END IF WRITE(newunit,100) version !! VTK version (currently, 3.0) WRITE(newunit,100) vtktitle !! VTK title card - WRITE(newunit,100) filetype_text !! VTK file type + WRITE(newunit,100) file_format_text !! VTK file type CALL geometry%write(newunit) !! Write the geometry information @@ -143,8 +142,7 @@ MODULE PROCEDURE vtk_legacy_append USE Misc, ONLY : to_uppercase - USE vtk_vars, ONLY : default_fn, default_title, ascii, binary, & - & version, file_extension + USE vtk_vars, ONLY : default_fn, default_title, version, file_extension IMPLICIT NONE !! author: Ian Porter !! date: 12/1/2017 @@ -216,7 +214,8 @@ MODULE PROCEDURE vtk_legacy_read USE Misc, ONLY : def_len - USE vtk_vars, ONLY : default_fn, default_title, filetype, vtkfilename, vtktitle, ascii, binary, version + USE vtk_vars, ONLY : default_fn, default_title, vtkfilename, vtktitle, version + USE XML, ONLY : convert_string_to_format, ascii, binary, file_format, file_format_text IMPLICIT NONE !! author: Ian Porter !! date: 12/20/2017 @@ -225,7 +224,7 @@ !! INTEGER(i4k) :: i, inputstat LOGICAL :: file_is_open - CHARACTER(LEN=:), ALLOCATABLE :: form, filetype_text, vtk_version + CHARACTER(LEN=:), ALLOCATABLE :: form, vtk_version CHARACTER(LEN=def_len) :: line INQUIRE(unit = unit, opened = file_is_open) !! Check to see if file is already open @@ -244,17 +243,16 @@ READ(unit,100) title !! VTK title card READ(unit,100) line !! VTK file type - ALLOCATE(filetype_text, source=TRIM(line)) + ALLOCATE(file_format_text, source=TRIM(line)) line = '' CLOSE(unit) !! Close the file to re-open it in the proper format - SELECT CASE (filetype_text) - CASE ('ASCII') - data_type = ascii + file_format = convert_string_to_format(file_format_text) + SELECT CASE (file_format) + CASE (ascii) ALLOCATE(form, source='formatted') - CASE ('BINARY') - data_type = binary + CASE (binary) ALLOCATE(form, source='unformatted') CASE DEFAULT ERROR STOP 'Unsupported file type. Must be ASCII or BINARY. Terminated in vtk_legacy_read' @@ -291,7 +289,6 @@ ALLOCATE(vtkfilename, source=filename) !! Save the filename for future internal use ALLOCATE(vtktitle, source=title) !! Save the title for future internal use - filetype = data_type !! Save the file type for future internal use 100 FORMAT(a) @@ -301,6 +298,7 @@ USE vtk_datasets, ONLY : struct_pts, struct_grid, rectlnr_grid, polygonal_data, unstruct_grid USE VTK_serial_file, ONLY : serial_file USE VTK_serial_Grid, ONLY : VTK_serial_RectilinearGrid_dt, VTK_serial_StructuredGrid_dt, VTK_serial_UnstructuredGrid_dt + USE XML, ONLY : file_format, file_format_text, convert_format_to_string, ascii, format_ascii IMPLICIT NONE !! author: Ian Porter !! date: 5/08/2019 @@ -309,10 +307,17 @@ !! ! Clear out any pre-existing data - IF (ALLOCATED(vtkfilename)) DEALLOCATE(vtkfilename) - IF (ALLOCATED(form)) DEALLOCATE(form) + IF (ALLOCATED(vtkfilename)) DEALLOCATE(vtkfilename) + IF (ALLOCATED(form)) DEALLOCATE(form) + IF (ALLOCATED(file_format_text)) DEALLOCATE(file_format_text) - IF (PRESENT(data_type)) filetype = data_type !! Calling program provided what file type to use for vtk file + IF (PRESENT(format)) THEN + ALLOCATE(file_format_text, source=convert_format_to_string(format)) + file_format = format + ELSE + ALLOCATE(file_format_text,source=format_ascii) !! Default to binary + file_format = ascii + END IF IF (PRESENT(filename)) THEN ALLOCATE(vtkfilename, source=filename) !! Calling program provided a filename ELSE @@ -352,7 +357,7 @@ CALL serial_file%vtk_dataset%set_grid(geometry) - CALL serial_file%setup(filename=vtkfilename // TRIM(serial_file%vtk_dataset%file_extension),form='formatted') + CALL serial_file%setup(filename=vtkfilename // TRIM(serial_file%vtk_dataset%file_extension)) !! Append data CALL vtk_serial_append (celldata, pointdata, celldatasets, pointdatasets) !! Finalize the write diff --git a/src/legacy/VTK_vars.f90 b/src/legacy/VTK_vars.f90 index a2f7c65..97f3924 100644 --- a/src/legacy/VTK_vars.f90 +++ b/src/legacy/VTK_vars.f90 @@ -1,5 +1,6 @@ MODULE vtk_vars USE Precision, ONLY : i4k + USE XML, ONLY : ascii, binary, file_format IMPLICIT NONE !! author: Ian Porter !! date: 12/20/2017 @@ -7,10 +8,9 @@ MODULE vtk_vars !! This module contains basic information needed for reading/writing to the vtk file !! PRIVATE - PUBLIC :: ascii, binary, filetype, vtkunit, version, default_title, default_fn, vtkfilename, vtktitle, fcnt, file_extension - - INTEGER(i4k), PARAMETER :: ascii=0_i4k, binary=1_i4k !! Available file types - INTEGER(i4k) :: filetype = ascii !! Selected file type + PUBLIC :: vtkunit, version, default_title, default_fn, vtkfilename, vtktitle, fcnt, file_extension + PUBLIC :: ascii, binary, file_format + !! Selected file type INTEGER(i4k) :: vtkunit = 20_i4k !! Default VTK unit # INTEGER(i4k) :: fcnt = 0_i4k !! File counter for time-dependent output files INTEGER(i4k), PARAMETER :: bit=0_i4k, unsigned_char=1_i4k, char=2_i4k, unsigned_short=3_i4k, short=4_i4k, & diff --git a/src/modern/VTK_DataArray_procedures.f90 b/src/modern/VTK_DataArray_procedures.f90 index be4352c..e509a3a 100644 --- a/src/modern/VTK_DataArray_procedures.f90 +++ b/src/modern/VTK_DataArray_procedures.f90 @@ -1,4 +1,5 @@ SUBMODULE (VTK_DataArray_element) VTK_DataArray_element_implementation + USE VTK_formats_types IMPLICIT NONE !! author: Ian Porter !! date: 06/07/2019 @@ -6,20 +7,6 @@ !! This is the basic file piece elements !! !! Data storage formats - CHARACTER(LEN=*), PARAMETER :: format_ascii = 'ascii' - CHARACTER(LEN=*), PARAMETER :: format_binary = 'binary' - CHARACTER(LEN=*), PARAMETER :: format_append = 'appended' - !! Data types - CHARACTER(LEN=*), PARAMETER :: type_int8 = 'Int8' - CHARACTER(LEN=*), PARAMETER :: type_uint8 = 'UInt8' - CHARACTER(LEN=*), PARAMETER :: type_int16 = 'Int16' - CHARACTER(LEN=*), PARAMETER :: type_uint16 = 'UInt16' - CHARACTER(LEN=*), PARAMETER :: type_int32 = 'Int32' - CHARACTER(LEN=*), PARAMETER :: type_uint32 = 'UInt32' - CHARACTER(LEN=*), PARAMETER :: type_int64 = 'Int64' - CHARACTER(LEN=*), PARAMETER :: type_uint64 = 'UInt64' - CHARACTER(LEN=*), PARAMETER :: type_float32 = 'Float32' - CHARACTER(LEN=*), PARAMETER :: type_float64 = 'Float64' CONTAINS @@ -93,14 +80,18 @@ !! IF (PRESENT(type)) THEN - !! May need to convert the legacy type names to the modern type names + !! May need to convert the legacy data type names to the modern type names + !bit, unsigned_char, char, unsigned_short, short, unsigned_int, int, unsigned_long, long, float, or double + !Int8, UInt8, Int16, UInt16, Int32, UInt32, Int64, UInt64, Float32, Float64 SELECT CASE (to_lowercase(type)) CASE ('float') - ALLOCATE(me%type,source='Float32') + ALLOCATE(me%type,source=type_float32) CASE ('double') - ALLOCATE(me%type,source='Float64') + ALLOCATE(me%type,source=type_float64) CASE ('int') - ALLOCATE(me%type,source='Int32') + ALLOCATE(me%type,source=type_int32) + CASE ('unsigned_int') + ALLOCATE(me%type,source=type_uint32) CASE DEFAULT !! Assume all other data types are ok ALLOCATE(me%type,source=type) diff --git a/src/modern/VTK_formats_types.f90 b/src/modern/VTK_formats_types.f90 new file mode 100644 index 0000000..2efef51 --- /dev/null +++ b/src/modern/VTK_formats_types.f90 @@ -0,0 +1,24 @@ +MODULE VTK_formats_types + IMPLICIT NONE + !! author: Ian Porter + !! date: 06/07/2019 + !! + !! This is the basic file piece elements + !! + !! Data storage formats + + PUBLIC + + !! Data types + CHARACTER(LEN=*), PARAMETER :: type_int8 = 'Int8' + CHARACTER(LEN=*), PARAMETER :: type_uint8 = 'UInt8' + CHARACTER(LEN=*), PARAMETER :: type_int16 = 'Int16' + CHARACTER(LEN=*), PARAMETER :: type_uint16 = 'UInt16' + CHARACTER(LEN=*), PARAMETER :: type_int32 = 'Int32' + CHARACTER(LEN=*), PARAMETER :: type_uint32 = 'UInt32' + CHARACTER(LEN=*), PARAMETER :: type_int64 = 'Int64' + CHARACTER(LEN=*), PARAMETER :: type_uint64 = 'UInt64' + CHARACTER(LEN=*), PARAMETER :: type_float32 = 'Float32' + CHARACTER(LEN=*), PARAMETER :: type_float64 = 'Float64' + +END MODULE VTK_formats_types diff --git a/src/modern/VTK_piece_element_procedures.f90 b/src/modern/VTK_piece_element_procedures.f90 index 1ac0ef4..79e38f7 100644 --- a/src/modern/VTK_piece_element_procedures.f90 +++ b/src/modern/VTK_piece_element_procedures.f90 @@ -1,5 +1,7 @@ SUBMODULE (VTK_piece_element) VTK_piece_element_implementation USE Precision, ONLY : i4k, r8k + USE VTK_formats_types + USE XML, ONLY : file_format_text IMPLICIT NONE !! author: Ian Porter !! date: 06/07/2019 @@ -7,20 +9,6 @@ !! This is the basic file piece elements !! !! Data storage formats - CHARACTER(LEN=*), PARAMETER :: format_ascii = 'ascii' - CHARACTER(LEN=*), PARAMETER :: format_binary = 'binary' - CHARACTER(LEN=*), PARAMETER :: format_append = 'appended' - !! Data types - CHARACTER(LEN=*), PARAMETER :: type_int8 = 'Int8' - CHARACTER(LEN=*), PARAMETER :: type_uint8 = 'UInt8' - CHARACTER(LEN=*), PARAMETER :: type_int16 = 'Int16' - CHARACTER(LEN=*), PARAMETER :: type_uint16 = 'UInt16' - CHARACTER(LEN=*), PARAMETER :: type_int32 = 'Int32' - CHARACTER(LEN=*), PARAMETER :: type_uint32 = 'UInt32' - CHARACTER(LEN=*), PARAMETER :: type_int64 = 'Int64' - CHARACTER(LEN=*), PARAMETER :: type_uint64 = 'UInt64' - CHARACTER(LEN=*), PARAMETER :: type_float32 = 'Float32' - CHARACTER(LEN=*), PARAMETER :: type_float64 = 'Float64' CONTAINS @@ -116,7 +104,7 @@ END PROCEDURE Data_deallocate MODULE PROCEDURE Points_initialize - USE vtk_datasets, ONLY : dataset, struct_pts, struct_grid, rectlnr_grid, polygonal_data, unstruct_grid + USE vtk_datasets, ONLY : struct_grid, unstruct_grid USE Misc, ONLY : convert_to_string IMPLICIT NONE !1 author: Ian Porter @@ -132,7 +120,7 @@ SELECT TYPE (geometry) CLASS IS (struct_grid) !! For now, don't allow "pieces" but instead force the piece to be the whole extent - CALL me%DataArray%initialize(type=type_float64,format=format_ascii,NumberofComponents=3) + CALL me%DataArray%initialize(type=type_float64,format=file_format_text,NumberofComponents=3) DO i = 1, geometry%n_points CALL me%DataArray%add(geometry%get_point(i)) !! New procedure under works to append an array of reals END DO @@ -140,7 +128,7 @@ CALL me%DataArray%me_deallocate() CLASS IS (unstruct_grid) !! For now, don't allow "pieces" but instead force the piece to be the whole extent - CALL me%DataArray%initialize(type=type_float64,format=format_ascii,NumberofComponents=3) + CALL me%DataArray%initialize(type=type_float64,format=file_format_text,NumberofComponents=3) DO i = 1, geometry%n_points CALL me%DataArray%add(geometry%get_point(i)) !! New procedure under works to append an array of reals END DO @@ -163,8 +151,7 @@ END PROCEDURE Points_deallocate MODULE PROCEDURE Cells_initialize - USE vtk_datasets, ONLY : dataset, struct_pts, struct_grid, rectlnr_grid, polygonal_data, unstruct_grid - USE Misc, ONLY : convert_to_string + USE vtk_datasets, ONLY : unstruct_grid IMPLICIT NONE !1 author: Ian Porter !! date: 07/09/2019 @@ -179,14 +166,14 @@ SELECT TYPE (geometry) CLASS IS (unstruct_grid) !! Set up cell connectivity - CALL me%connectivity%initialize(name='connectivity',type=type_float64,format=format_ascii) + CALL me%connectivity%initialize(name='connectivity',type=type_float64,format=file_format_text) DO i = 1, geometry%n_cells CALL me%connectivity%add(geometry%get_connectivity(i)) !! New procedure under works to append an array of reals END DO CALL me%add(me%connectivity) CALL me%connectivity%me_deallocate() !! Set up cell offsets - CALL me%offsets%initialize(name='offsets',type=type_float64,format=format_ascii) + CALL me%offsets%initialize(name='offsets',type=type_float64,format=file_format_text) cnt = 0 DO i = 1, geometry%n_cells cnt = cnt + geometry%get_offset(i) @@ -195,7 +182,7 @@ CALL me%add(me%offsets) CALL me%offsets%me_deallocate() !! Set up cell types - CALL me%types%initialize(name='types',type=type_float64,format=format_ascii) + CALL me%types%initialize(name='types',type=type_float64,format=file_format_text) DO i = 1, geometry%n_cells CALL me%types%add([geometry%get_type(i)]) !! New procedure under works to append an array of reals END DO @@ -242,11 +229,11 @@ SELECT TYPE (geometry) CLASS IS (rectlnr_grid) !! For now, don't allow "pieces" but instead force the piece to be the whole extent - CALL me%DataArray_x%initialize(type=type_float64,format=format_ascii,range_min=range(1,1),range_max=range(2,1)) - CALL me%DataArray_x%add(geometry%get_coord(1_i4k)) !! New procedure under works to append an array of reals - CALL me%DataArray_y%initialize(type=type_float64,format=format_ascii,range_min=range(1,2),range_max=range(2,2)) + CALL me%DataArray_x%initialize(type=type_float64,format=file_format_text,range_min=range(1,1),range_max=range(2,1)) + CALL me%DataArray_x%add(geometry%get_coord(1)) + CALL me%DataArray_y%initialize(type=type_float64,format=file_format_text,range_min=range(1,2),range_max=range(2,2)) CALL me%DataArray_y%add(geometry%get_coord(2)) - CALL me%DataArray_z%initialize(type=type_float64,format=format_ascii,range_min=range(1,3),range_max=range(2,3)) + CALL me%DataArray_z%initialize(type=type_float64,format=file_format_text,range_min=range(1,3),range_max=range(2,3)) CALL me%DataArray_z%add(geometry%get_coord(3)) CALL me%add(me%DataArray_x) diff --git a/src/utilities/Misc_procedures.f90 b/src/utilities/Misc_procedures.f90 index 5b35761..ca474a7 100644 --- a/src/utilities/Misc_procedures.f90 +++ b/src/utilities/Misc_procedures.f90 @@ -113,7 +113,7 @@ MODULE PROCEDURE convert_real32_to_string IMPLICIT NONE !! Converts a real to a character string - CHARACTER(LEN=30) :: tmp_string = ' ' + CHARACTER(LEN=20) :: tmp_string = ' ' WRITE(tmp_string,*) var ALLOCATE(string,source=TRIM(ADJUSTL(tmp_string))) @@ -123,7 +123,7 @@ MODULE PROCEDURE convert_real64_to_string IMPLICIT NONE !! Converts a real to a character string - CHARACTER(LEN=30) :: tmp_string = ' ' + CHARACTER(LEN=30) :: tmp_string = ' ' WRITE(tmp_string,*) var ALLOCATE(string,source=TRIM(ADJUSTL(tmp_string))) @@ -132,25 +132,25 @@ MODULE PROCEDURE convert_int32_to_string IMPLICIT NONE - CHARACTER(LEN=10) :: tmp_string = ' ' + CHARACTER(LEN=20) :: tmp_string = ' ' - WRITE(tmp_string,'(i10)') var + WRITE(tmp_string,*) var ALLOCATE(string,source=TRIM(ADJUSTL(tmp_string))) END PROCEDURE convert_int32_to_string MODULE PROCEDURE convert_int64_to_string IMPLICIT NONE - CHARACTER(LEN=20) :: tmp_string = ' ' + CHARACTER(LEN=30) :: tmp_string = ' ' - WRITE(tmp_string,'(i20)') var + WRITE(tmp_string,*) var ALLOCATE(string,source=TRIM(ADJUSTL(tmp_string))) END PROCEDURE convert_int64_to_string MODULE PROCEDURE convert_logical_to_string IMPLICIT NONE - + IF (var) THEN ALLOCATE(string,source='True') ELSE diff --git a/src/utilities/Precision.f90 b/src/utilities/Precision.f90 index cdfc33d..5e3807b 100644 --- a/src/utilities/Precision.f90 +++ b/src/utilities/Precision.f90 @@ -1,5 +1,6 @@ MODULE Precision - USE ISO_FORTRAN_ENV, ONLY : i4k => INT32, i8k => INT64, r4k => REAL32, r8k =>REAL64 + USE ISO_FORTRAN_ENV, ONLY : i1k => INT8, i2k => INT16, i4k => INT32, i8k => INT64, & + & r4k => REAL32, r8k => REAL64, r16k => REAL128 IMPLICIT NONE !! author: Ian Porter !! date: 12/9/2017 @@ -7,6 +8,6 @@ MODULE Precision !! This module contains the Precision used for specifying the precision of variables !! PRIVATE - PUBLIC :: i4k, i8k, r4k, r8k + PUBLIC :: i1k, i2k, i4k, i8k, r4k, r8k, r16k END MODULE Precision diff --git a/src/utilities/xml.f90 b/src/utilities/xml.f90 index 2feed78..e10a8e7 100644 --- a/src/utilities/xml.f90 +++ b/src/utilities/xml.f90 @@ -1,5 +1,5 @@ MODULE XML - USE Precision, ONLY : i4k, i8k, r4k, r8k + USE Precision, ONLY : i1k, i4k, i8k, r4k, r8k USE File_utility, ONLY : file_data_structure USE ISO_FORTRAN_ENV, ONLY : output_unit IMPLICIT NONE @@ -11,6 +11,19 @@ MODULE XML PRIVATE PUBLIC :: xml_element_dt, xml_file_dt, gcc_bug_workaround_allocate, gcc_bug_workaround_deallocate + PUBLIC :: file_format, binary, ascii, convert_format_to_string, convert_string_to_format + PUBLIC :: format_ascii, format_binary, format_append, file_format_text + + ENUM, BIND(C) + ENUMERATOR :: ascii, binary, append + END ENUM + + INTEGER(i4k) :: file_format = ascii + + CHARACTER(LEN=*), PARAMETER :: format_ascii = 'ascii' + CHARACTER(LEN=*), PARAMETER :: format_binary = 'binary' + CHARACTER(LEN=*), PARAMETER :: format_append = 'appended' + CHARACTER(LEN=:), ALLOCATABLE :: file_format_text TYPE string_dt CHARACTER(LEN=:), ALLOCATABLE :: text @@ -19,6 +32,14 @@ MODULE XML GENERIC, PUBLIC :: deallocate => gcc_bug_deallocate_string_dt END TYPE string_dt + TYPE real32_dt + REAL(r4k), DIMENSION(:), ALLOCATABLE :: val + END TYPE real32_dt + + TYPE real64_dt + REAL(r8k), DIMENSION(:), ALLOCATABLE :: val + END TYPE real64_dt + TYPE xml_element_dt PRIVATE !! XML derived type @@ -27,6 +48,8 @@ MODULE XML CHARACTER(LEN=:), ALLOCATABLE :: offset !! Offset for data within XML block CHARACTER(LEN=:), ALLOCATABLE :: additional_data !! Additional data to write in header TYPE(string_dt), DIMENSION(:), ALLOCATABLE :: string !! String data set(s) within element + TYPE(real32_dt), DIMENSION(:), ALLOCATABLE :: real32 !! String of real64 + TYPE(real64_dt), DIMENSION(:), ALLOCATABLE :: real64 !! String of real64 TYPE(xml_element_dt), DIMENSION(:), ALLOCATABLE :: element !! Element data set(s) within element CONTAINS PROCEDURE, PUBLIC :: setup => element_setup !! Set up element block @@ -47,6 +70,7 @@ MODULE XML GENERIC, PUBLIC :: add => element_add_logical PROCEDURE, PRIVATE :: end => element_end !! Write closure of element block PROCEDURE, PUBLIC :: write => element_write !! Writes the element block + PROCEDURE, PUBLIC :: replace => replace_in_string !! Replaces an identifier in the string PROCEDURE, PRIVATE :: gcc_bug_workaround_deallocate_single GENERIC, PUBLIC :: deallocate => gcc_bug_workaround_deallocate_single END TYPE xml_element_dt @@ -68,7 +92,7 @@ MODULE XML INTERFACE gcc_bug_workaround_deallocate PROCEDURE :: gcc_bug_workaround_deallocate_array PROCEDURE :: gcc_bug_workaround_deallocate_single - END INTERFACE + END INTERFACE gcc_bug_workaround_deallocate INTERFACE @@ -151,6 +175,14 @@ RECURSIVE MODULE SUBROUTINE element_write (me, unit) INTEGER(i4k), INTENT(IN) :: unit !! File unit # to write to END SUBROUTINE element_write + MODULE SUBROUTINE replace_in_string (me, tag, value) + IMPLICIT NONE + !! Replaces the existing value associated with tag with value + CLASS(xml_element_dt), INTENT(INOUT) :: me + CHARACTER(LEN=*), INTENT(IN) :: tag + CHARACTER(LEN=*), INTENT(IN) :: value + END SUBROUTINE replace_in_string + MODULE SUBROUTINE xml_file_setup (me, filename, open_status, close_status, form, access) IMPLICIT NONE !! author: Ian Porter @@ -240,6 +272,20 @@ RECURSIVE MODULE SUBROUTINE gcc_bug_workaround_deallocate_xml_file_dt (me) CLASS(xml_file_dt), INTENT(INOUT) :: me END SUBROUTINE gcc_bug_workaround_deallocate_xml_file_dt + MODULE FUNCTION convert_format_to_string (format) RESULT(string) + IMPLICIT NONE + !! Converts the format integer to string + INTEGER(i4k), INTENT(IN) :: format + CHARACTER(LEN=:), ALLOCATABLE :: string + END FUNCTION convert_format_to_string + + MODULE FUNCTION convert_string_to_format (string) RESULT(format) + IMPLICIT NONE + !! Converts the format integer to string + CHARACTER(LEN=*), INTENT(IN) :: string + INTEGER(i4k) :: format + END FUNCTION convert_string_to_format + END INTERFACE END MODULE XML diff --git a/src/utilities/xml_procedures.f90 b/src/utilities/xml_procedures.f90 index 447fa6e..4cf2675 100644 --- a/src/utilities/xml_procedures.f90 +++ b/src/utilities/xml_procedures.f90 @@ -54,7 +54,12 @@ !! This begins an xml element block CHARACTER(LEN=:), ALLOCATABLE :: tmp_offset - WRITE(unit,'(a)',advance='no') prior_offset // '<' // me%name // me%additional_data // '>' // new_line('a') + SELECT CASE (file_format) + CASE (ascii) + WRITE(unit,'(a)',advance='no') prior_offset // '<' // me%name // me%additional_data // '>' // new_line('a') + CASE (binary) + WRITE(unit) prior_offset // '<' // me%name // me%additional_data // '>' // new_line('a') + END SELECT ALLOCATE(tmp_offset,source=prior_offset // me%offset) !! Set the new offset length CALL MOVE_ALLOC(tmp_offset,prior_offset) @@ -66,28 +71,41 @@ IMPLICIT NONE !! This adds data inside of an xml element block INTEGER(i4k) :: i + TYPE(real32_dt) :: real32 TYPE(string_dt), DIMENSION(:), ALLOCATABLE :: tmp_string_dt + TYPE(real32_dt), DIMENSION(:), ALLOCATABLE :: tmp_real32_dt CHARACTER(LEN=:), ALLOCATABLE :: string - IF (.NOT. ALLOCATED(me%string)) THEN - ALLOCATE(me%string(0)) - END IF - - ALLOCATE(tmp_string_dt(1:SIZE(me%string)+1)) - tmp_string_dt(1:SIZE(me%string)) = me%string - CALL MOVE_ALLOC(tmp_string_dt, me%string) + SELECT CASE (file_format) + CASE (binary) + IF (.NOT. ALLOCATED(me%real32)) THEN + ALLOCATE(me%real32(0)) + END IF + ALLOCATE(real32%val, source=var) + ALLOCATE(tmp_real32_dt, source = [me%real32, real32]) + CALL MOVE_ALLOC(tmp_real32_dt, me%real32) - DO i = 1, SIZE(var) - IF (i == 1) THEN - ALLOCATE(string, source=convert_to_string(var(i))) - ELSE - string = string // " " // convert_to_string(var(i)) + CASE (ascii) + IF (.NOT. ALLOCATED(me%string)) THEN + ALLOCATE(me%string(0)) END IF - END DO - ASSOCIATE (my_entry => UBOUND(me%string,DIM=1)) - ALLOCATE(me%string(my_entry)%text,source= string // new_line('a')) - END ASSOCIATE + ALLOCATE(tmp_string_dt(1:SIZE(me%string)+1)) + tmp_string_dt(1:SIZE(me%string)) = me%string + CALL MOVE_ALLOC(tmp_string_dt, me%string) + + DO i = 1, SIZE(var) + IF (i == 1) THEN + ALLOCATE(string, source=convert_to_string(var(i))) + ELSE + string = string // " " // convert_to_string(var(i)) + END IF + END DO + + ASSOCIATE (my_entry => UBOUND(me%string,DIM=1)) + ALLOCATE(me%string(my_entry)%text,source= string // new_line('a')) + END ASSOCIATE + END SELECT END PROCEDURE element_add_real32 @@ -96,28 +114,40 @@ IMPLICIT NONE !! This adds data inside of an xml element block INTEGER(i4k) :: i + TYPE(real64_dt) :: real64 TYPE(string_dt), DIMENSION(:), ALLOCATABLE :: tmp_string_dt + TYPE(real64_dt), DIMENSION(:), ALLOCATABLE :: tmp_real64_dt CHARACTER(LEN=:), ALLOCATABLE :: string - IF (.NOT. ALLOCATED(me%string)) THEN - ALLOCATE(me%string(0)) - END IF + SELECT CASE (file_format) + CASE (binary) + IF (.NOT. ALLOCATED(me%real64)) THEN + ALLOCATE(me%real64(0)) + END IF + ALLOCATE(real64%val, source=var) + ALLOCATE(tmp_real64_dt, source = [me%real64, real64]) + CALL MOVE_ALLOC(tmp_real64_dt, me%real64) + CASE (ascii) + IF (.NOT. ALLOCATED(me%string)) THEN + ALLOCATE(me%string(0)) + END IF - ALLOCATE(tmp_string_dt(1:SIZE(me%string)+1)) - tmp_string_dt(1:SIZE(me%string)) = me%string - CALL MOVE_ALLOC(tmp_string_dt, me%string) + ALLOCATE(tmp_string_dt(1:SIZE(me%string)+1)) + tmp_string_dt(1:SIZE(me%string)) = me%string + CALL MOVE_ALLOC(tmp_string_dt, me%string) - DO i = 1, SIZE(var) - IF (i == 1) THEN - ALLOCATE(string, source=convert_to_string(var(i))) - ELSE - string = string // " " // convert_to_string(var(i)) - END IF - END DO + DO i = 1, SIZE(var) + IF (i == 1) THEN + ALLOCATE(string, source=convert_to_string(var(i))) + ELSE + string = string // " " // convert_to_string(var(i)) + END IF + END DO - ASSOCIATE (my_entry => UBOUND(me%string,DIM=1)) - ALLOCATE(me%string(my_entry)%text,source= string // new_line('a')) - END ASSOCIATE + ASSOCIATE (my_entry => UBOUND(me%string,DIM=1)) + ALLOCATE(me%string(my_entry)%text,source= string // new_line('a')) + END ASSOCIATE + END SELECT END PROCEDURE element_add_real64 @@ -268,7 +298,12 @@ CALL MOVE_ALLOC(tmp_offset,prior_offset) !! Reset the offset length END ASSOCIATE - WRITE(unit,'(a)',advance='no') prior_offset // '' // new_line('a') + SELECT CASE (file_format) + CASE (ascii) + WRITE(unit,'(a)',advance='no') prior_offset // '' // new_line('a') + CASE (binary) + WRITE(unit) prior_offset // '' // new_line('a') + END SELECT END PROCEDURE element_end @@ -279,14 +314,33 @@ !! !! Writes the element to the file !! - INTEGER(i4k) :: i + INTEGER(i4k) :: i, j CALL me%begin(unit) IF (ALLOCATED(me%string)) THEN DO i = 1, SIZE(me%string) - WRITE(unit,'(a)',advance='no') prior_offset // me%string(i)%text + SELECT CASE (file_format) + CASE (ASCII) + WRITE(unit,'(a)',advance='no') prior_offset // me%string(i)%text + CASE (BINARY) + WRITE(unit) prior_offset // me%string(i)%text + END SELECT + END DO + ELSE IF (ALLOCATED(me%real32)) THEN + DO i = 1, SIZE(me%real32) + ASSOCIATE (n_vals => SIZE(me%real32(i)%val)) + WRITE(unit) prior_offset, (me%real32(i)%val(j),j=1,n_vals) + END ASSOCIATE + END DO + WRITE(unit) new_line('a') + ELSE IF (ALLOCATED(me%real64)) THEN + DO i = 1, SIZE(me%real64) + ASSOCIATE (n_vals => SIZE(me%real64(i)%val)) + WRITE(unit) prior_offset, (me%real64(i)%val(j),j=1,n_vals) + END ASSOCIATE END DO + WRITE(unit) new_line('a') END IF IF (ALLOCATED(me%element)) THEN @@ -299,7 +353,22 @@ END PROCEDURE element_write + MODULE PROCEDURE replace_in_string + IMPLICIT NONE + !! Replaces the existing value associated with tag with value + + !! Find where "tag" is located + + !! Find the end of the string associated with "tag" + + !! Replace that value with value + + ERROR STOP 'Error: replace_in_string in xml_procedures is not yet implemented.' + + END PROCEDURE replace_in_string + MODULE PROCEDURE XML_file_setup + USE Misc, ONLY : to_lowercase IMPLICIT NONE !! author: Ian Porter !! date: 05/02/2019 @@ -319,9 +388,26 @@ ELSE ALLOCATE(me%close_status, source='KEEP') END IF - - ALLOCATE(me%form, source='FORMATTED') !! Ignore the user-defined form, even if present - ALLOCATE(me%access, source='SEQUENTIAL') !! Ignore the user-defined access, even if present + IF (PRESENT(form)) THEN + SELECT CASE (to_lowercase(form)) + CASE ('formatted') + ALLOCATE(me%form, source='FORMATTED') !! Ignore the user-defined form, even if present + file_format = ascii + CASE ('unformatted') + ALLOCATE(me%form, source='UNFORMATTED') !! Ignore the user-defined form, even if present + file_format = binary + END SELECT + ELSE + SELECT CASE (file_format) + CASE (ascii) + ALLOCATE(me%form, source='FORMATTED') + CASE (binary) + ALLOCATE(me%form, source='UNFORMATTED') + END SELECT + END IF + file_format_text = convert_format_to_string (file_format) +! ALLOCATE(me%access, source='SEQUENTIAL') !! Ignore the user-defined access, even if present + ALLOCATE(me%access, source='STREAM') !! Ignore the user-defined access, even if present IF (.NOT. ALLOCATED(prior_offset)) ALLOCATE(prior_offset,source='') @@ -335,9 +421,19 @@ !! Begins the writing of the XMl file !! + IF (.NOT. ALLOCATED(me%filename)) THEN + WRITE(0,*) 'WARNING: FILE NAME HAS NOT YET BEEN SET IN XML_begin' + CALL me%setup('dummy') + END IF + CALL me%make_file() - WRITE(me%unit,'(a)',advance='no') version // new_line('a') + SELECT CASE (file_format) + CASE (ascii) + WRITE(me%unit,'(a)',advance='no') version // new_line('a') + CASE (binary) + WRITE(me%unit) version // new_line('a') + END SELECT END PROCEDURE XML_begin @@ -426,6 +522,8 @@ IF (ALLOCATED(oldfoo(i)%additional_data)) & & ALLOCATE(me(i)%additional_data, source=oldfoo(i)%additional_data) IF (ALLOCATED(oldfoo(i)%string)) ALLOCATE(me(i)%string, source=oldfoo(i)%string) + IF (ALLOCATED(oldfoo(i)%real32)) ALLOCATE(me(i)%real32, source=oldfoo(i)%real32) + IF (ALLOCATED(oldfoo(i)%real64)) ALLOCATE(me(i)%real64, source=oldfoo(i)%real64) IF (ALLOCATED(oldfoo(i)%element)) CALL gcc_bug_workaround_allocate(me(i)%element, oldfoo=oldfoo(i)%element) END DO ELSE @@ -439,6 +537,8 @@ IF (ALLOCATED(addfoo%additional_data)) & & ALLOCATE(me(i)%additional_data, source=addfoo%additional_data) IF (ALLOCATED(addfoo%string)) ALLOCATE(me(i)%string, source=addfoo%string) + IF (ALLOCATED(addfoo%real32)) ALLOCATE(me(i)%real32, source=addfoo%real32) + IF (ALLOCATED(addfoo%real64)) ALLOCATE(me(i)%real64, source=addfoo%real64) IF (ALLOCATED(addfoo%element)) CALL gcc_bug_workaround_allocate(me(i)%element, oldfoo=addfoo%element) END IF @@ -451,7 +551,6 @@ IF (ALLOCATED(me)) THEN DO i = LBOUND(me,DIM=1), UBOUND(me,DIM=1) - CALL gcc_bug_workaround_deallocate(me(i)) END DO IF (ALLOCATED(me)) DEALLOCATE(me) @@ -474,7 +573,8 @@ END DO IF (ALLOCATED(me%string)) DEALLOCATE(me%string) END IF - + IF (ALLOCATED(me%real32)) DEALLOCATE(me%real32) + IF (ALLOCATED(me%real64)) DEALLOCATE(me%real64) IF (ALLOCATED(me%element)) THEN DO i = LBOUND(me%element,DIM=1), UBOUND(me%element,DIM=1) CALL gcc_bug_workaround_deallocate (me%element(i)) @@ -492,7 +592,6 @@ END PROCEDURE gcc_bug_deallocate_string_dt - MODULE PROCEDURE gcc_bug_workaround_deallocate_xml_file_dt IMPLICIT NONE !! gcc Work-around to de-allocate the string derived type @@ -501,4 +600,39 @@ END PROCEDURE gcc_bug_workaround_deallocate_xml_file_dt + MODULE PROCEDURE convert_format_to_string + IMPLICIT NONE + !! Converts the format integer to string + + SELECT CASE (format) + CASE (ascii) + ALLOCATE(string,source=format_ascii) + CASE (binary) + ALLOCATE(string,source=format_binary) + CASE (append) + ALLOCATE(string,source=format_append) + CASE DEFAULT + ERROR STOP 'Error: Undefined format in convert_format_to_string' + END SELECT + + END PROCEDURE convert_format_to_string + + MODULE PROCEDURE convert_string_to_format + USE Misc, ONLY : to_lowercase + IMPLICIT NONE + !! Converts the format integer to string + + SELECT CASE (to_lowercase(string)) + CASE (format_ascii) + format = ascii + CASE (format_binary) + format = binary + CASE (format_append) + format = append + CASE DEFAULT + ERROR STOP 'Error: Undefined string in convert_string_to_format' + END SELECT + + END PROCEDURE convert_string_to_format + END SUBMODULE XML_implementation diff --git a/tests/integration/serial/Rectilinear_grid.f90 b/tests/integration/serial/Rectilinear_grid.f90 index d3e003b..4e6fa15 100644 --- a/tests/integration/serial/Rectilinear_grid.f90 +++ b/tests/integration/serial/Rectilinear_grid.f90 @@ -3,6 +3,7 @@ PROGRAM modern_Rectilinear_test USE vtk_datasets, ONLY : rectlnr_grid USE vtk_attributes, ONLY : scalar, attributes USE vtk, ONLY : vtk_serial_write + USE XML, ONLY : binary, ascii IMPLICIT NONE !! author: Ian Porter !! date: 05/20/2019 @@ -50,8 +51,20 @@ PROGRAM modern_Rectilinear_test CALL vtk_serial_write (cube, pointdatasets=vals_to_write, unit=unit, filename=filename, title=title) !! This tests a full 1-time write + CLOSE(unit) +write(0,*) 'rectilinear_grid, before vtk_serial_write for binary' + !! Binary file + CALL vtk_serial_write (cube, unit=unit, filename='binary_cube_append_' // filename, title=title, format=binary) - CALL vtk_serial_write (cube, unit=unit, filename='append_' // filename, title=title) + CALL vtk_serial_write (pointdata=vals_to_write(1)%attribute) + + CALL vtk_serial_write (pointdatasets=vals_to_write(2:3)) + + CALL vtk_serial_write (finished=.TRUE.) + CLOSE(unit) +write(0,*) 'rectilinear_grid, before vtk_serial_write for ascii' + !! Ascii file + CALL vtk_serial_write (cube, unit=unit, filename='ascii_cube_append_' // filename, title=title, format=ascii) CALL vtk_serial_write (pointdata=vals_to_write(1)%attribute) diff --git a/tests/unit/DataArray_unit.f90 b/tests/unit/DataArray_unit.f90 index 8320c6d..5897767 100644 --- a/tests/unit/DataArray_unit.f90 +++ b/tests/unit/DataArray_unit.f90 @@ -2,6 +2,7 @@ PROGRAM DataArray_test USE Precision, ONLY : i4k USE VTKmofoPassFail, ONLY : all_tests_pass USE VTK_DataArray_element, ONLY : DataArray_dt + USE XML, ONLY : file_format, ascii IMPLICIT NONE !! author: Ian Porter !! date: 06/07/2019 @@ -19,10 +20,12 @@ PROGRAM DataArray_test INTEGER(i4k) :: unit CHARACTER(LEN=*), PARAMETER :: type = 'Float32' CHARACTER(LEN=*), PARAMETER :: name = 'foo_data' - INTEGER(i4k), PARAMETER :: NumberOfComponents = 1 + INTEGER(i4k), PARAMETER :: NumberOfComponents = 1 CHARACTER(LEN=*), PARAMETER :: format = 'ascii' CHARACTER(LEN=*), PARAMETER :: offset = '0' + file_format = ascii + CALL foo%initialize(type=type) CALL foo%initialize(name=name) CALL foo%initialize(NumberOfComponents=NumberOfComponents) @@ -32,7 +35,7 @@ PROGRAM DataArray_test CALL foo%add(foo2) - OPEN (newunit=unit,file="DataArray_test.xml",status="replace") + OPEN (newunit=unit,file="DataArray_test.xml",status="replace",form="formatted") CALL foo%write(unit) CALL all_tests_pass() From c76f499ecfff85d7257fc392ba655137218c208a Mon Sep 17 00:00:00 2001 From: Ian Porter Date: Mon, 5 Aug 2019 21:57:12 -0400 Subject: [PATCH 2/6] Added little endian checker --- src/modern/VTK_element.f90 | 5 +---- src/modern/VTK_element_procedures.f90 | 9 ++++----- src/utilities/file_utility.f90 | 9 ++++++++- src/utilities/file_utility_procedures.f90 | 15 ++++++++++++--- 4 files changed, 25 insertions(+), 13 deletions(-) diff --git a/src/modern/VTK_element.f90 b/src/modern/VTK_element.f90 index 19b6f64..145f1dd 100644 --- a/src/modern/VTK_element.f90 +++ b/src/modern/VTK_element.f90 @@ -13,13 +13,11 @@ MODULE VTK_element PUBLIC :: VTK_element_dt CHARACTER(LEN=*), PARAMETER :: def_version = "0.1" - CHARACTER(LEN=*), PARAMETER :: def_byte_order = "LittleEndian" TYPE, EXTENDS(xml_element_dt) :: VTK_element_dt PRIVATE CHARACTER(LEN=:), ALLOCATABLE :: type CHARACTER(LEN=:), ALLOCATABLE :: version - CHARACTER(LEN=:), ALLOCATABLE :: byte_order CHARACTER(LEN=:), ALLOCATABLE :: compression CHARACTER(LEN=:), ALLOCATABLE, PUBLIC :: file_extension CHARACTER(LEN=:), ALLOCATABLE, PUBLIC :: filename @@ -45,7 +43,7 @@ MODULE SUBROUTINE vtk_element_setup (me) END SUBROUTINE vtk_element_setup - MODULE SUBROUTINE initialize (me, type, byte_order, compression, file_extension) + MODULE SUBROUTINE initialize (me, type, compression, file_extension) IMPLICIT NONE !! author: Ian Porter !! date: 05/07/2019 @@ -54,7 +52,6 @@ MODULE SUBROUTINE initialize (me, type, byte_order, compression, file_extension) !! CLASS(VTK_element_dt), INTENT(INOUT) :: me !! CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: type !! Grid type - CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: byte_order !! Byte order (BigEndian or LittleEndian) CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: compression !! CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: file_extension !! diff --git a/src/modern/VTK_element_procedures.f90 b/src/modern/VTK_element_procedures.f90 index de1f9fa..6d6d865 100644 --- a/src/modern/VTK_element_procedures.f90 +++ b/src/modern/VTK_element_procedures.f90 @@ -10,6 +10,7 @@ CONTAINS MODULE PROCEDURE vtk_element_setup + USE File_utility, ONLY : is_little_endian IMPLICIT NONE !! author: Ian Porter !! date: 05/06/2019 @@ -30,10 +31,10 @@ ELSE ERROR STOP "Error. Can't create VTK file without a known type. Terminated in vtk_element_setup" END IF - IF (ALLOCATED(me%byte_order)) THEN - ALLOCATE(byte_order_string,source=' byte_order="' // me%byte_order // '"') + IF (is_little_endian()) THEN + ALLOCATE(byte_order_string,source=' byte_order="LittleEndian"') ELSE - ALLOCATE(byte_order_string,source=' byte_order="' // def_byte_order // '"') + ALLOCATE(byte_order_string,source=' byte_order="BigEndian"') END IF IF (ALLOCATED(me%compression)) THEN ALLOCATE(compression_string,source=' compression="' // me%compression // '"') @@ -56,7 +57,6 @@ !! IF (PRESENT(type)) ALLOCATE(me%type,source=type) - IF (PRESENT(byte_order)) ALLOCATE(me%byte_order,source=byte_order) IF (PRESENT(compression)) ALLOCATE(me%compression,source=compression) IF (PRESENT(file_extension)) ALLOCATE(me%file_extension,source=file_extension) @@ -84,7 +84,6 @@ IF (ALLOCATED(foo%type)) DEALLOCATE(foo%type) IF (ALLOCATED(foo%version)) DEALLOCATE(foo%version) - IF (ALLOCATED(foo%byte_order)) DEALLOCATE(foo%byte_order) IF (ALLOCATED(foo%compression)) DEALLOCATE(foo%compression) IF (ALLOCATED(foo%file_extension)) DEALLOCATE(foo%file_extension) IF (ALLOCATED(foo%filename)) DEALLOCATE(foo%filename) diff --git a/src/utilities/file_utility.f90 b/src/utilities/file_utility.f90 index e1f0204..8e6fa67 100644 --- a/src/utilities/file_utility.f90 +++ b/src/utilities/file_utility.f90 @@ -7,7 +7,7 @@ MODULE File_utility !! This module contains a derived type for file information !! PRIVATE - PUBLIC :: file_data_structure + PUBLIC :: file_data_structure, is_little_endian TYPE file_data_structure !! File data derived type @@ -29,6 +29,7 @@ MODULE File_utility PROCEDURE, PUBLIC :: file_read_error PROCEDURE, PUBLIC :: wait_for_file PROCEDURE, PUBLIC :: get_unit + PROCEDURE, PUBLIC, NOPASS :: is_little_endian END TYPE file_data_structure INTERFACE @@ -142,6 +143,12 @@ MODULE FUNCTION get_unit (me) RESULT (unit) END FUNCTION get_unit + PURE MODULE FUNCTION is_little_endian() RESULT (is_little) + !! Checks the type of bit ordering to determine if the architecture is little endian + LOGICAL :: is_little !! Flag to determine if little endian + + END FUNCTION is_little_endian + END INTERFACE END MODULE File_utility diff --git a/src/utilities/file_utility_procedures.f90 b/src/utilities/file_utility_procedures.f90 index 6ae43ac..4e34393 100644 --- a/src/utilities/file_utility_procedures.f90 +++ b/src/utilities/file_utility_procedures.f90 @@ -1,5 +1,5 @@ SUBMODULE (file_utility) file_utility_implementation - USE Precision, ONLY : i4k, r8k + USE Precision, ONLY : i1k, i4k, r8k IMPLICIT NONE !! author: Ian Porter !! date: 04/04/2018 @@ -129,8 +129,8 @@ IF (me%unit < 0) THEN me%unit = 0 !! Re-set this to a non-negative number for a gfortran-8.3 bug w/ newunit END IF - - OPEN (newunit=me%unit, file=me%filename, iostat=inputstat, Status='REPLACE', Form=me%form) +write(0,*) me%form + OPEN (newunit=me%unit, file=me%filename, iostat=inputstat, Status='REPLACE', Form=me%form, access=me%access) END PROCEDURE make_file @@ -192,4 +192,13 @@ END PROCEDURE get_unit + MODULE PROCEDURE is_little_endian + !! Checks the type of bit ordering to determine if the running architecture is little endian. + INTEGER(i1k) :: int1(1:4) !! One byte integer array for casting 4 bytes integer. + + int1 = TRANSFER(1_i4k, int1) + is_little = (int1(1) == 1_i1k) + + END PROCEDURE is_little_endian + END SUBMODULE file_utility_implementation From d4d7e95a4880b524e6537a892b3206adfe7ac7fa Mon Sep 17 00:00:00 2001 From: Ian Porter Date: Thu, 8 Aug 2019 22:21:16 -0400 Subject: [PATCH 3/6] Fix bad link in readme --- README.md | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/README.md b/README.md index 2bbfcc4..0546ee6 100644 --- a/README.md +++ b/README.md @@ -6,7 +6,7 @@ VTK legacy format using modern Fortran [![release downloads][download image]](https://github.com/porteri/vtkmofo/releases) [![codecov][codecov image]](https://codecov.io/gh/porteri/vtkmofo) -This is a generic modern Fortran interface to write a VTK formatted file using the specifications outlined in [version 3.0][VTK Format Link]. +This is a generic modern Fortran interface to write a VTK formatted file using the specifications outlined in [version 3.0][VTK Format link]. Format support: - [X] Legacy Format @@ -59,3 +59,4 @@ Examples: [gcc link]: https://gcc.gnu.org/ [Intel link]: https://software.intel.com/en-us/fortran-compilers [CMake link]: https://cmake.org +[VTK Format link]: https://www.vtk.org/VTK/img/file-formats.pdf From 7df275c94233ec22c488fa085271fd6bab1aac97 Mon Sep 17 00:00:00 2001 From: Ian Porter Date: Thu, 8 Aug 2019 22:37:04 -0400 Subject: [PATCH 4/6] Stub for ImageData --- src/modern/VTK_serial_Grid.f90 | 29 +++++++++++- src/modern/VTK_serial_Grid_procedures.f90 | 39 ++++++++++++++++ tests/integration/CMakeLists.txt | 1 + tests/integration/serial/Image_Data.f90 | 54 +++++++++++++++++++++++ 4 files changed, 122 insertions(+), 1 deletion(-) create mode 100644 tests/integration/serial/Image_Data.f90 diff --git a/src/modern/VTK_serial_Grid.f90 b/src/modern/VTK_serial_Grid.f90 index 8be4ffd..3a8c85c 100644 --- a/src/modern/VTK_serial_Grid.f90 +++ b/src/modern/VTK_serial_Grid.f90 @@ -27,6 +27,13 @@ MODULE VTK_serial_Grid PROCEDURE :: finalize END TYPE VTK_dataset_dt + TYPE, EXTENDS(VTK_dataset_dt) :: VTK_serial_ImageData_dt + !! Serial file ImageData Grid + PRIVATE + CONTAINS + PROCEDURE :: set_grid => ImageData_set_grid + END TYPE VTK_serial_ImageData_dt + TYPE, EXTENDS(VTK_dataset_dt) :: VTK_serial_RectilinearGrid_dt !! Serial file Rectilinear Grid PRIVATE @@ -42,7 +49,7 @@ MODULE VTK_serial_Grid END TYPE VTK_serial_StructuredGrid_dt TYPE, EXTENDS(VTK_dataset_dt) :: VTK_serial_UnstructuredGrid_dt - !! Serial file Structured Grid + !! Serial file Unstructured Grid PRIVATE CONTAINS PROCEDURE :: set_grid => Unstructuredgrid_set_grid @@ -64,18 +71,38 @@ END SUBROUTINE abs_set_grid MODULE SUBROUTINE finalize (me) IMPLICIT NONE + !! author: Ian Porter + !! date: 07/28/2019 + !! !! Writes data inside of itself + !! CLASS(VTK_dataset_dt), INTENT(INOUT) :: me END SUBROUTINE finalize RECURSIVE MODULE SUBROUTINE vtk_dataset_deallocate (foo) IMPLICIT NONE + !! author: Ian Porter + !! date: 07/28/2019 + !! !! gcc Work-around for deallocating a multi-dimension derived type w/ allocatable character strings + !! CLASS(VTK_dataset_dt), INTENT(INOUT) :: foo END SUBROUTINE vtk_dataset_deallocate + MODULE SUBROUTINE ImageData_set_grid (me, geometry) + IMPLICIT NONE + !! author: Ian Porter + !! date: 08/08/2019 + !! + !! This writes the grid information for an image data grid + !! + CLASS(VTK_serial_ImageData_dt), INTENT(INOUT) :: me !! Serial geometry DT + CLASS(dataset), INTENT(IN) :: geometry !! DT of geometry information + + END SUBROUTINE ImageData_set_grid + MODULE SUBROUTINE Rectilineargrid_set_grid (me, geometry) IMPLICIT NONE !! author: Ian Porter diff --git a/src/modern/VTK_serial_Grid_procedures.f90 b/src/modern/VTK_serial_Grid_procedures.f90 index 3c3f732..e9e6038 100644 --- a/src/modern/VTK_serial_Grid_procedures.f90 +++ b/src/modern/VTK_serial_Grid_procedures.f90 @@ -38,6 +38,45 @@ END PROCEDURE vtk_dataset_deallocate + MODULE PROCEDURE ImageData_set_grid + IMPLICIT NONE + !! author: Ian Porter + !! date: 08/08/2019 + !! + !! This writes the grid information for an image data grid + !! + CHARACTER(LEN=10) :: tmp_string = ' ' + CHARACTER(LEN=:), ALLOCATABLE :: range_string + INTEGER(i4k) :: i, j + INTEGER(i4k), DIMENSION(2,3) :: range + CHARACTER(LEN=*), PARAMETER :: file_extension = ".vti" + CHARACTER(LEN=*), PARAMETER :: grid_type = "ImageData" + +ERROR STOP 'ImageData_set_grid is not yet implemented' + + CALL me%initialize(type=grid_type,file_extension=file_extension) + range = geometry%get_range_cnt() + + DO i = 1, 3 + DO j = 1, 2 + WRITE(tmp_string,'(i10)') range(j,i) + IF (.NOT. ALLOCATED(range_string)) THEN + ALLOCATE(range_string,source=TRIM(ADJUSTL(tmp_string))) + ELSE + range_string = range_string // ' ' // TRIM(ADJUSTL(tmp_string)) + END IF + END DO + END DO + + ALLOCATE(me%WholeExtent, source=range_string) + ALLOCATE(me%grid_type, source=grid_type) + + !! For now, don't allow "pieces" but instead force the piece to be the whole extent + IF (.NOT. ALLOCATED(me%piece)) ALLOCATE(me%piece) + CALL me%piece%set(geometry) + + END PROCEDURE ImageData_set_grid + MODULE PROCEDURE Rectilineargrid_set_grid IMPLICIT NONE !! author: Ian Porter diff --git a/tests/integration/CMakeLists.txt b/tests/integration/CMakeLists.txt index 9c9197f..69d067d 100644 --- a/tests/integration/CMakeLists.txt +++ b/tests/integration/CMakeLists.txt @@ -29,6 +29,7 @@ endforeach() # serial modern tests foreach(test + Image_Data Rectilinear_grid Structured_grid Unstructured_grid) diff --git a/tests/integration/serial/Image_Data.f90 b/tests/integration/serial/Image_Data.f90 new file mode 100644 index 0000000..66ca3ae --- /dev/null +++ b/tests/integration/serial/Image_Data.f90 @@ -0,0 +1,54 @@ +PROGRAM rectangular_prism_test + USE Precision, ONLY : i4k, r8k + USE vtk_datasets, ONLY : struct_pts + USE vtk_attributes, ONLY : scalar, attributes + USE vtk, ONLY : vtk_serial_write + IMPLICIT NONE + !! author: Ian Porter + !! date: 12/28/2017 + !! + !! This is a test of a rectangular_prism geometry using structured points + !! + INTEGER(i4k), PARAMETER :: n_params_to_write = 3 + TYPE (struct_pts) :: rectangular_prism + TYPE (attributes), DIMENSION(n_params_to_write) :: vals_to_write + INTEGER(i4k) :: i = 0_i4k + INTEGER(i4k), PARAMETER :: n_x = 11, n_y = 6, n_z = 3, unit = 20 + REAL(r8k) :: j = 0.0_r8k + REAL(r8k), PARAMETER :: temp_val = 555.0_r8k + CHARACTER(LEN=*), PARAMETER :: filename = 'rectangular_prism' + CHARACTER(LEN=*), PARAMETER :: title = 'Testing of rectangular_prism geometry' + INTEGER(i4k), DIMENSION(3) :: dims + REAL(r8k), DIMENSION(3), PARAMETER :: origin = & + & [ 0.0_r8k, 0.0_r8k, 0.0_r8k ] + REAL(r8k), DIMENSION(3), PARAMETER :: spacing = & + & [ 0.3_r8k, 0.2_r8k, 0.1_r8k ] + REAL(r8k), DIMENSION(n_x*n_y*n_z,1:n_params_to_write) :: vals + CHARACTER(LEN=20), DIMENSION(n_params_to_write), PARAMETER :: dataname = & + & [ 'Temperature_(K) ', 'Pressure_(Pa) ', 'Stress_(Pa) ' ] + + vals(1,:) = temp_val + DO i = 2, SIZE(vals,DIM=1) + IF (i <= SIZE(vals) / 2) THEN + vals(i,1) = vals(i-1,1) + 2.0_r8k !! Temperature + ELSE + vals(i,1) = vals(i-1,1) - 2.0_r8k !! Temperature + END IF + j = j + 1.0_r8k + vals(i,2) = vals(i-1,2) + MAX(50.0_r8k, j) !! Pressure + vals(i,3) = vals(i-1,3) + SQRT(REAL(i)) !! Stress + END DO + dims = [ n_x, n_y, n_z ] + CALL rectangular_prism%init (dims=dims, origin=origin, spacing=spacing) + DO i = 1, n_params_to_write + IF (.NOT. ALLOCATED(vals_to_write(i)%attribute))THEN + ALLOCATE(scalar::vals_to_write(i)%attribute) + END IF + CALL vals_to_write(i)%attribute%init (TRIM(dataname(i)), numcomp=1, real1d=vals(:,i)) + END DO + + CALL vtk_serial_write (rectangular_prism, pointdatasets=vals_to_write, unit=unit, filename=filename, title=title) + + WRITE(*,*) 'Finished' + +END PROGRAM rectangular_prism_test From 77fb50eadafccf5df498c42109107afbd81a6da9 Mon Sep 17 00:00:00 2001 From: Ian Porter Date: Sat, 10 Aug 2019 18:55:12 -0400 Subject: [PATCH 5/6] Implements ImageData --- src/legacy/VTK_datasets.f90 | 22 ++++++++++- src/legacy/VTK_datasets_procedures.f90 | 16 ++++++++ src/legacy/VTK_io_procedures.f90 | 5 ++- src/modern/VTK_piece_element_procedures.f90 | 2 +- src/modern/VTK_serial_Grid.f90 | 2 + src/modern/VTK_serial_Grid_procedures.f90 | 23 ++++++++++-- src/utilities/Misc.f90 | 8 ++++ src/utilities/Misc_procedures.f90 | 18 +++++++++ src/utilities/xml.f90 | 9 +++-- src/utilities/xml_procedures.f90 | 41 +++++++++++---------- 10 files changed, 115 insertions(+), 31 deletions(-) diff --git a/src/legacy/VTK_datasets.f90 b/src/legacy/VTK_datasets.f90 index 7e67c15..e034884 100644 --- a/src/legacy/VTK_datasets.f90 +++ b/src/legacy/VTK_datasets.f90 @@ -48,7 +48,11 @@ MODULE VTK_datasets CONTAINS PROCEDURE :: read => struct_pts_read PROCEDURE :: write => struct_pts_write - PROCEDURE, PRIVATE :: setup => struct_pts_setup + PROCEDURE :: struct_pts_get_origin + PROCEDURE :: struct_pts_get_spacing + GENERIC, PUBLIC :: get_origin => struct_pts_get_origin + GENERIC, PUBLIC :: get_spacing => struct_pts_get_spacing + PROCEDURE :: setup => struct_pts_setup PROCEDURE :: check_for_diffs => struct_pts_check_for_diffs END TYPE struct_pts @@ -209,6 +213,22 @@ MODULE SUBROUTINE struct_pts_write (me, unit) END SUBROUTINE struct_pts_write + PURE MODULE FUNCTION struct_pts_get_origin (me) RESULT (origin) + IMPLICIT NONE + !! Gets the private DT data for origin + CLASS (struct_pts), INTENT(IN) :: me + REAL(r8k), DIMENSION(3) :: origin + + END FUNCTION struct_pts_get_origin + + PURE MODULE FUNCTION struct_pts_get_spacing (me) RESULT (spacing) + IMPLICIT NONE + !! Gets the private DT data for spacing + CLASS (struct_pts), INTENT(IN) :: me + REAL(r8k), DIMENSION(3) :: spacing + + END FUNCTION struct_pts_get_spacing + MODULE SUBROUTINE struct_pts_setup (me, dims, origin, spacing) IMPLICIT NONE !! Sets up the structured points dataset with information diff --git a/src/legacy/VTK_datasets_procedures.f90 b/src/legacy/VTK_datasets_procedures.f90 index 5394541..0788cc1 100644 --- a/src/legacy/VTK_datasets_procedures.f90 +++ b/src/legacy/VTK_datasets_procedures.f90 @@ -149,6 +149,22 @@ END PROCEDURE struct_pts_write + MODULE PROCEDURE struct_pts_get_origin + IMPLICIT NONE + !! Gets the private DT data for origin + + origin = me%origin + + END PROCEDURE struct_pts_get_origin + + MODULE PROCEDURE struct_pts_get_spacing + IMPLICIT NONE + !! Gets the private DT data for spacing + + spacing = me%spacing + + END PROCEDURE struct_pts_get_spacing + MODULE PROCEDURE struct_pts_setup IMPLICIT NONE !! Sets up the structured points dataset with information diff --git a/src/legacy/VTK_io_procedures.f90 b/src/legacy/VTK_io_procedures.f90 index ed56136..1307846 100644 --- a/src/legacy/VTK_io_procedures.f90 +++ b/src/legacy/VTK_io_procedures.f90 @@ -297,7 +297,8 @@ MODULE PROCEDURE vtk_serial_full_write USE vtk_datasets, ONLY : struct_pts, struct_grid, rectlnr_grid, polygonal_data, unstruct_grid USE VTK_serial_file, ONLY : serial_file - USE VTK_serial_Grid, ONLY : VTK_serial_RectilinearGrid_dt, VTK_serial_StructuredGrid_dt, VTK_serial_UnstructuredGrid_dt + USE VTK_serial_Grid, ONLY : VTK_serial_RectilinearGrid_dt, VTK_serial_StructuredGrid_dt, & + & VTK_serial_UnstructuredGrid_dt, VTK_serial_ImageData_dt USE XML, ONLY : file_format, file_format_text, convert_format_to_string, ascii, format_ascii IMPLICIT NONE !! author: Ian Porter @@ -342,7 +343,7 @@ SELECT TYPE (geometry) CLASS IS (struct_pts) - ERROR STOP 'Procedure not yet implemented for: STRUCTURED POINTS. Termination in subroutine: vtk_serial_full_write' + ALLOCATE(VTK_serial_ImageData_dt::serial_file%vtk_dataset) CLASS IS (struct_grid) ALLOCATE(VTK_serial_StructuredGrid_dt::serial_file%vtk_dataset) CLASS IS (rectlnr_grid) diff --git a/src/modern/VTK_piece_element_procedures.f90 b/src/modern/VTK_piece_element_procedures.f90 index 79e38f7..45d7feb 100644 --- a/src/modern/VTK_piece_element_procedures.f90 +++ b/src/modern/VTK_piece_element_procedures.f90 @@ -294,7 +294,7 @@ SELECT TYPE (geometry) CLASS IS (struct_pts) - ERROR STOP 'Error: struct_pts is not yet implemented in piece_set_grid' + CALL me%setup(name="Piece",string="Extent=" // '"' // range_string // '"') CLASS IS (struct_grid) !! For now, don't allow "pieces" but instead force the piece to be the whole extent CALL me%setup(name="Piece",string="Extent=" // '"' // range_string // '"') diff --git a/src/modern/VTK_serial_Grid.f90 b/src/modern/VTK_serial_Grid.f90 index 3a8c85c..5c3073f 100644 --- a/src/modern/VTK_serial_Grid.f90 +++ b/src/modern/VTK_serial_Grid.f90 @@ -15,11 +15,13 @@ MODULE VTK_serial_Grid PUBLIC :: VTK_serial_RectilinearGrid_dt PUBLIC :: VTK_serial_StructuredGrid_dt PUBLIC :: VTK_serial_UnstructuredGrid_dt + PUBLIC :: VTK_serial_ImageData_dt TYPE, EXTENDS(VTK_element_dt), ABSTRACT :: VTK_dataset_dt !! VTK dataset derived type CHARACTER(LEN=:), ALLOCATABLE :: WholeExtent !! String for the whole extent of the range CHARACTER(LEN=:), ALLOCATABLE :: grid_type !! Name of the grid type + CHARACTER(LEN=:), ALLOCATABLE :: extra_string !! Additional data needed to be written TYPE(piece_dt), ALLOCATABLE :: piece !! Piece DT (Currently only supporting one piece) CONTAINS PROCEDURE(abs_set_grid), DEFERRED :: set_grid diff --git a/src/modern/VTK_serial_Grid_procedures.f90 b/src/modern/VTK_serial_Grid_procedures.f90 index e9e6038..f4cc151 100644 --- a/src/modern/VTK_serial_Grid_procedures.f90 +++ b/src/modern/VTK_serial_Grid_procedures.f90 @@ -1,5 +1,5 @@ SUBMODULE (VTK_serial_Grid) VTK_serial_Grid_procedures - USE Precision, ONLY : i4k + USE Precision, ONLY : i4k, r8k !! author: Ian Porter !! date: 05/06/2019 !! @@ -21,6 +21,7 @@ ELSE CALL grid%setup(name=me%grid_type) END IF + IF (ALLOCATED(me%extra_string)) CALL grid%add(me%extra_string, quotes=.FALSE.) CALL grid%add(me%piece) CALL me%add(grid) CALL grid%me_deallocate() @@ -39,6 +40,8 @@ END PROCEDURE vtk_dataset_deallocate MODULE PROCEDURE ImageData_set_grid + USE VTK_datasets, ONLY : struct_pts + USE Misc, ONLY : convert_to_string IMPLICIT NONE !! author: Ian Porter !! date: 08/08/2019 @@ -46,15 +49,14 @@ !! This writes the grid information for an image data grid !! CHARACTER(LEN=10) :: tmp_string = ' ' - CHARACTER(LEN=:), ALLOCATABLE :: range_string + CHARACTER(LEN=:), ALLOCATABLE :: range_string, origin_string, spacing_string INTEGER(i4k) :: i, j INTEGER(i4k), DIMENSION(2,3) :: range CHARACTER(LEN=*), PARAMETER :: file_extension = ".vti" CHARACTER(LEN=*), PARAMETER :: grid_type = "ImageData" -ERROR STOP 'ImageData_set_grid is not yet implemented' - CALL me%initialize(type=grid_type,file_extension=file_extension) + range = geometry%get_range_cnt() DO i = 1, 3 @@ -71,6 +73,19 @@ ALLOCATE(me%WholeExtent, source=range_string) ALLOCATE(me%grid_type, source=grid_type) + !! Still need to set the following line of information: + !! Origin=”x0 y0 z0” Spacing=”dx dy dz”> + SELECT TYPE(geometry) + CLASS IS (struct_pts) + ALLOCATE(origin_string, source=convert_to_string(geometry%get_origin())) + ALLOCATE(spacing_string, source=convert_to_string(geometry%get_spacing())) + ALLOCATE(me%extra_string, source='Origin="' // origin_string // '", Spacing="' // spacing_string // '"') + CLASS DEFAULT + ERROR STOP 'Bad geometry type for ImageData. Terminated in ImageData_set_grid' + END SELECT + +! ERROR STOP 'ImageData_set_grid is not yet implemented. Need to set origin, spacing' + !! For now, don't allow "pieces" but instead force the piece to be the whole extent IF (.NOT. ALLOCATED(me%piece)) ALLOCATE(me%piece) CALL me%piece%set(geometry) diff --git a/src/utilities/Misc.f90 b/src/utilities/Misc.f90 index 25a3cde..9db19ea 100644 --- a/src/utilities/Misc.f90 +++ b/src/utilities/Misc.f90 @@ -18,6 +18,7 @@ MODULE Misc INTERFACE convert_to_string PROCEDURE :: convert_real32_to_string PROCEDURE :: convert_real64_to_string + PROCEDURE :: convert_real64_array_to_string PROCEDURE :: convert_int32_to_string PROCEDURE :: convert_int64_to_string PROCEDURE :: convert_logical_to_string @@ -86,6 +87,13 @@ MODULE FUNCTION convert_real64_to_string (var) RESULT (string) CHARACTER(LEN=:), ALLOCATABLE :: string !! Character string END FUNCTION convert_real64_to_string + MODULE FUNCTION convert_real64_array_to_string (var) RESULT (string) + IMPLICIT NONE + !! Converts a real64 to a character string + REAL(r8k), DIMENSION(:), INTENT(IN) :: var !! Real array + CHARACTER(LEN=:), ALLOCATABLE :: string !! Character string + END FUNCTION convert_real64_array_to_string + MODULE FUNCTION convert_int32_to_string (var) RESULT (string) IMPLICIT NONE !! Converts an int32 to a character string diff --git a/src/utilities/Misc_procedures.f90 b/src/utilities/Misc_procedures.f90 index ca474a7..f120af9 100644 --- a/src/utilities/Misc_procedures.f90 +++ b/src/utilities/Misc_procedures.f90 @@ -130,6 +130,24 @@ END PROCEDURE convert_real64_to_string + MODULE PROCEDURE convert_real64_array_to_string + IMPLICIT NONE + !! Converts a real to a character string + INTEGER(i4k) :: i + CHARACTER(LEN=:), ALLOCATABLE :: tmp_string + + DO i = 1, SIZE(var) + ALLOCATE(tmp_string, source=convert_real64_to_string(var(i))) + IF (.NOT. ALLOCATED(string)) THEN + ALLOCATE(string,source=tmp_string) + ELSE + string = string // " " // tmp_string + END IF + DEALLOCATE(tmp_string) + END DO + + END PROCEDURE convert_real64_array_to_string + MODULE PROCEDURE convert_int32_to_string IMPLICIT NONE CHARACTER(LEN=20) :: tmp_string = ' ' diff --git a/src/utilities/xml.f90 b/src/utilities/xml.f90 index e10a8e7..e53b3ee 100644 --- a/src/utilities/xml.f90 +++ b/src/utilities/xml.f90 @@ -54,14 +54,14 @@ MODULE XML CONTAINS PROCEDURE, PUBLIC :: setup => element_setup !! Set up element block PROCEDURE, PRIVATE :: begin => element_begin !! Write open of element block - PROCEDURE, PRIVATE :: element_add_data !! Write raw data inside of element block + PROCEDURE, PRIVATE :: element_add_string !! Write raw data inside of element block PROCEDURE, PRIVATE :: element_add_element !! Write another element inside element block PROCEDURE, PRIVATE :: element_add_real32 !! Write real32 into a string inside of element block PROCEDURE, PRIVATE :: element_add_real64 !! Write real64 into a string inside of element block PROCEDURE, PRIVATE :: element_add_int32 !! Write ints32 into a string inside of element block PROCEDURE, PRIVATE :: element_add_int64 !! Write ints64 into a string inside of element block PROCEDURE, PRIVATE :: element_add_logical !! Write logical into a string inside of element block - GENERIC, PUBLIC :: add => element_add_data + GENERIC, PUBLIC :: add => element_add_string GENERIC, PUBLIC :: add => element_add_element GENERIC, PUBLIC :: add => element_add_real64 GENERIC, PUBLIC :: add => element_add_real32 @@ -147,12 +147,13 @@ RECURSIVE MODULE SUBROUTINE element_add_logical (me, var) LOGICAL, DIMENSION(:), INTENT(IN) :: var !! Data to write END SUBROUTINE element_add_logical - RECURSIVE MODULE SUBROUTINE element_add_data (me, string) + RECURSIVE MODULE SUBROUTINE element_add_string (me, string, quotes) IMPLICIT NONE !! This adds data inside of an xml element block CLASS(xml_element_dt), INTENT(INOUT) :: me !! XML element derived type CHARACTER(LEN=*), INTENT(IN) :: string !! String of data to write - END SUBROUTINE element_add_data + LOGICAL, OPTIONAL, INTENT(IN) :: quotes !! Flag to turn quotation marks around string on/off + END SUBROUTINE element_add_string RECURSIVE MODULE SUBROUTINE element_add_element (me, element) IMPLICIT NONE diff --git a/src/utilities/xml_procedures.f90 b/src/utilities/xml_procedures.f90 index 4cf2675..7d3ae8f 100644 --- a/src/utilities/xml_procedures.f90 +++ b/src/utilities/xml_procedures.f90 @@ -58,7 +58,7 @@ CASE (ascii) WRITE(unit,'(a)',advance='no') prior_offset // '<' // me%name // me%additional_data // '>' // new_line('a') CASE (binary) - WRITE(unit) prior_offset // '<' // me%name // me%additional_data // '>' // new_line('a') + WRITE(unit) '<' // me%name // me%additional_data // '>' // new_line('a') END SELECT ALLOCATE(tmp_offset,source=prior_offset // me%offset) !! Set the new offset length @@ -113,11 +113,9 @@ USE Misc, ONLY : convert_to_string IMPLICIT NONE !! This adds data inside of an xml element block - INTEGER(i4k) :: i TYPE(real64_dt) :: real64 TYPE(string_dt), DIMENSION(:), ALLOCATABLE :: tmp_string_dt TYPE(real64_dt), DIMENSION(:), ALLOCATABLE :: tmp_real64_dt - CHARACTER(LEN=:), ALLOCATABLE :: string SELECT CASE (file_format) CASE (binary) @@ -136,16 +134,8 @@ tmp_string_dt(1:SIZE(me%string)) = me%string CALL MOVE_ALLOC(tmp_string_dt, me%string) - DO i = 1, SIZE(var) - IF (i == 1) THEN - ALLOCATE(string, source=convert_to_string(var(i))) - ELSE - string = string // " " // convert_to_string(var(i)) - END IF - END DO - ASSOCIATE (my_entry => UBOUND(me%string,DIM=1)) - ALLOCATE(me%string(my_entry)%text,source= string // new_line('a')) + ALLOCATE(me%string(my_entry)%text,source=convert_to_string(var) // new_line('a')) END ASSOCIATE END SELECT @@ -241,11 +231,18 @@ END PROCEDURE element_add_logical - MODULE PROCEDURE element_add_data + MODULE PROCEDURE element_add_string IMPLICIT NONE !! This adds data inside of an xml element block + LOGICAL :: add_quotes TYPE(string_dt), DIMENSION(:), ALLOCATABLE :: tmp_string_dt + IF (PRESENT(quotes)) THEN + add_quotes = quotes + ELSE + add_quotes = .TRUE. !! By default, add quotation marks around a string + END IF + IF (.NOT. ALLOCATED(me%string)) THEN ALLOCATE(me%string(0)) END IF @@ -255,10 +252,14 @@ CALL MOVE_ALLOC(tmp_string_dt, me%string) ASSOCIATE (my_entry => UBOUND(me%string,DIM=1)) - ALLOCATE(me%string(my_entry)%text,source='"' // string // '"' // new_line('a')) + IF (add_quotes) THEN + ALLOCATE(me%string(my_entry)%text,source='"' // string // '"' // new_line('a')) + ELSE + ALLOCATE(me%string(my_entry)%text,source= string // new_line('a')) + END IF END ASSOCIATE - END PROCEDURE element_add_data + END PROCEDURE element_add_string MODULE PROCEDURE element_add_element IMPLICIT NONE @@ -302,7 +303,7 @@ CASE (ascii) WRITE(unit,'(a)',advance='no') prior_offset // '' // new_line('a') CASE (binary) - WRITE(unit) prior_offset // '' // new_line('a') + WRITE(unit) '' // new_line('a') END SELECT END PROCEDURE element_end @@ -324,20 +325,22 @@ CASE (ASCII) WRITE(unit,'(a)',advance='no') prior_offset // me%string(i)%text CASE (BINARY) - WRITE(unit) prior_offset // me%string(i)%text + WRITE(unit) me%string(i)%text END SELECT END DO ELSE IF (ALLOCATED(me%real32)) THEN DO i = 1, SIZE(me%real32) ASSOCIATE (n_vals => SIZE(me%real32(i)%val)) - WRITE(unit) prior_offset, (me%real32(i)%val(j),j=1,n_vals) + WRITE(unit) (me%real32(i)%val(j),j=1,n_vals) END ASSOCIATE END DO WRITE(unit) new_line('a') ELSE IF (ALLOCATED(me%real64)) THEN DO i = 1, SIZE(me%real64) ASSOCIATE (n_vals => SIZE(me%real64(i)%val)) - WRITE(unit) prior_offset, (me%real64(i)%val(j),j=1,n_vals) + DO j = 1, n_vals + WRITE(unit) me%real64(i)%val(j) + END DO END ASSOCIATE END DO WRITE(unit) new_line('a') From fc5a742fa766aa70db7d2541be76302eff893fe1 Mon Sep 17 00:00:00 2001 From: Ian Porter Date: Sat, 10 Aug 2019 19:18:09 -0400 Subject: [PATCH 6/6] Update README.md --- README.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index 0546ee6..294ab6d 100644 --- a/README.md +++ b/README.md @@ -13,7 +13,7 @@ Format support: * This code fully supports the legacy .vtk file format in ASCII - [X] XML Format - [ ] Serial Formats - - [ ] Image Data (.vti) + - [X] Image Data (.vti) - [ ] Poly Data (.vtp) - [X] Rectilinear Grid (.vtr) - [X] Structured Grid (.vts) @@ -37,7 +37,7 @@ Operating Systems: - MacOS Build System: - - [CMake][CMake link] 3.12.2 or newer + - [CMake][CMake link] 3.13.4 or newer Examples: # Structured Grid (2D)