diff --git a/code/Makefile b/code/Makefile index a9054310d..2d5551ca9 100644 --- a/code/Makefile +++ b/code/Makefile @@ -350,7 +350,7 @@ DAMASK_spectral.o: INTERFACENAME := spectral_interface.f90 SPECTRAL_SOLVER_FILES = spectral_mech_AL.o spectral_mech_Basic.o spectral_mech_Polarisation.o \ spectral_thermal.o spectral_damage.o -SPECTRAL_FILES = prec.o DAMASK_interface.o IO.o libs.o numerics.o debug.o math.o \ +SPECTRAL_FILES = prec.o DAMASK_interface.o IO.o numerics.o debug.o math.o \ FEsolving.o mesh.o material.o lattice.o \ $(SOURCE_FILES) $(KINEMATICS_FILES) $(PLASTIC_FILES) constitutive.o \ crystallite.o \ @@ -400,7 +400,7 @@ DAMASK_FEM.exe: INCLUDE_DIRS += -I./ FEM_SOLVER_FILES = FEM_mech.o FEM_thermal.o FEM_damage.o FEM_vacancyflux.o FEM_porosity.o FEM_hydrogenflux.o -FEM_FILES = prec.o DAMASK_interface.o FEZoo.o IO.o libs.o numerics.o debug.o math.o \ +FEM_FILES = prec.o DAMASK_interface.o FEZoo.o IO.o numerics.o debug.o math.o \ FEsolving.o mesh.o material.o lattice.o \ $(SOURCE_FILES) $(KINEMATICS_FILES) $(PLASTIC_FILES) constitutive.o \ crystallite.o \ @@ -614,9 +614,6 @@ debug.o: debug.f90 \ numerics.o numerics.o: numerics.f90 \ - libs.o - -libs.o: libs.f90 \ IO.o IO.o: IO.f90 \ diff --git a/code/commercialFEM_fileList.f90 b/code/commercialFEM_fileList.f90 index 7d02eadfc..0367de1c2 100644 --- a/code/commercialFEM_fileList.f90 +++ b/code/commercialFEM_fileList.f90 @@ -4,7 +4,6 @@ !> @details List of files needed by MSC.Marc, Abaqus/Explicit, and Abaqus/Standard !-------------------------------------------------------------------------------------------------- #include "IO.f90" -#include "libs.f90" #include "numerics.f90" #include "debug.f90" #include "math.f90" diff --git a/code/libs.f90 b/code/libs.f90 deleted file mode 100644 index 71f300512..000000000 --- a/code/libs.f90 +++ /dev/null @@ -1,12 +0,0 @@ -!-------------------------------------------------------------------------------------------------- -!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH -!> @brief dummy source for inclusion of Library files -!-------------------------------------------------------------------------------------------------- -module libs -!nothing in here -end module libs - -#include "../lib/IR_Precision.f90" -#include "../lib/Lib_Base64.f90" -#include "../lib/Lib_VTK_IO.f90" - diff --git a/code/mesh.f90 b/code/mesh.f90 index 29bb15aef..ada304d9e 100644 --- a/code/mesh.f90 +++ b/code/mesh.f90 @@ -116,12 +116,8 @@ module mesh #endif #ifdef Spectral -#ifdef PETSc #include include 'fftw3-mpi.f03' -#else - include 'fftw3.f03' -#endif #endif ! These definitions should actually reside in the FE-solver specific part (different for MARC/ABAQUS) @@ -413,18 +409,13 @@ module mesh mesh_build_ipVolumes, & mesh_build_ipCoordinates, & mesh_cellCenterCoordinates, & - mesh_init_postprocessing, & mesh_get_Ncellnodes, & mesh_get_unitlength, & mesh_get_nodeAtIP #ifdef Spectral public :: & mesh_spectral_getGrid, & - mesh_spectral_getSize, & - mesh_nodesAroundCentres, & - mesh_deformedCoordsFFT, & - mesh_volumeMismatch, & - mesh_shapeMismatch + mesh_spectral_getSize #endif private :: & @@ -436,8 +427,7 @@ module mesh mesh_spectral_build_nodes, & mesh_spectral_build_elements, & mesh_spectral_build_ipNeighborhood, & -#endif -#ifdef Marc4DAMASK +#elif defined Marc4DAMASK mesh_marc_get_tableStyles, & mesh_marc_count_nodesAndElements, & mesh_marc_count_elementSets, & @@ -448,8 +438,7 @@ module mesh mesh_marc_build_nodes, & mesh_marc_count_cpSizes, & mesh_marc_build_elements, & -#endif -#ifdef Abaqus +#elif defined Abaqus mesh_abaqus_count_nodesAndElements, & mesh_abaqus_count_elementSets, & mesh_abaqus_count_materials, & @@ -473,11 +462,7 @@ module mesh mesh_tell_statistics, & FE_mapElemtype, & mesh_faceMatch, & - mesh_build_FEdata, & - mesh_write_cellGeom, & - mesh_write_elemGeom, & - mesh_write_meshfile, & - mesh_read_meshfile + mesh_build_FEdata contains @@ -487,9 +472,7 @@ contains !! Order and routines strongly depend on type of solver !-------------------------------------------------------------------------------------------------- subroutine mesh_init(ip,el) -#ifdef Spectral use, intrinsic :: iso_c_binding -#endif use DAMASK_interface use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) use IO, only: & @@ -562,25 +545,18 @@ subroutine mesh_init(ip,el) myDebug = (iand(debug_level(debug_mesh),debug_levelBasic) /= 0_pInt) #ifdef Spectral -#ifdef PETSc call fftw_mpi_init() -#endif call IO_open_file(FILEUNIT,geometryFile) ! parse info from geometry file... if (myDebug) write(6,'(a)') ' Opened geometry file'; flush(6) grid = mesh_spectral_getGrid(fileUnit) geomSize = mesh_spectral_getSize(fileUnit) - -#ifdef PETSc gridMPI = int(grid,C_INTPTR_T) alloc_local = fftw_mpi_local_size_3d(gridMPI(3), gridMPI(2), gridMPI(1)/2 +1, & MPI_COMM_WORLD, local_K, local_K_offset) grid3 = int(local_K,pInt) grid3Offset = int(local_K_offset,pInt) - size3 = geomSize(3)*real(grid3,pReal) /real(grid(3),pReal) size3Offset = geomSize(3)*real(grid3Offset,pReal)/real(grid(3),pReal) -#endif - if (myDebug) write(6,'(a)') ' Grid partitioned'; flush(6) call mesh_spectral_count() if (myDebug) write(6,'(a)') ' Counted nodes/elements'; flush(6) @@ -592,8 +568,7 @@ subroutine mesh_init(ip,el) if (myDebug) write(6,'(a)') ' Built nodes'; flush(6) call mesh_spectral_build_elements(FILEUNIT) if (myDebug) write(6,'(a)') ' Built elements'; flush(6) -#endif -#ifdef Marc4DAMASK +#elif defined Marc4DAMASK call IO_open_inputFile(FILEUNIT,modelName) ! parse info from input file... if (myDebug) write(6,'(a)') ' Opened input file'; flush(6) call mesh_marc_get_tableStyles(FILEUNIT) @@ -616,8 +591,7 @@ subroutine mesh_init(ip,el) if (myDebug) write(6,'(a)') ' Counted CP sizes'; flush(6) call mesh_marc_build_elements(FILEUNIT) if (myDebug) write(6,'(a)') ' Built elements'; flush(6) -#endif -#ifdef Abaqus +#elif defined Abaqus call IO_open_inputFile(FILEUNIT,modelName) ! parse info from input file... if (myDebug) write(6,'(a)') ' Opened input file'; flush(6) noPart = IO_abaqus_hasNoPart(FILEUNIT) @@ -672,9 +646,6 @@ subroutine mesh_init(ip,el) if (worldrank == 0_pInt) then call mesh_tell_statistics - call mesh_write_meshfile - call mesh_write_cellGeom - call mesh_write_elemGeom endif if (usePingPong .and. (mesh_Nelems /= mesh_NcpElems)) & @@ -4511,228 +4482,6 @@ subroutine mesh_build_FEdata end subroutine mesh_build_FEdata -!-------------------------------------------------------------------------------------------------- -!> @brief writes out initial cell geometry -!-------------------------------------------------------------------------------------------------- -subroutine mesh_write_cellGeom - use DAMASK_interface, only: & - getSolverJobName, & - getSolverWorkingDirectoryName - use IR_Precision, only: & - I4P - use Lib_VTK_IO, only: & - VTK_ini, & - VTK_geo, & - VTK_con, & - VTK_end -#ifdef HDF - use IO, only: & - HDF5_mappingCells -#endif - implicit none - integer(I4P), dimension(1:mesh_Ncells) :: celltype - integer(I4P), dimension(mesh_Ncells*(1_pInt+FE_maxNcellnodesPerCell)) :: cellconnection -#ifdef HDF - integer(pInt), dimension(mesh_Ncells*FE_maxNcellnodesPerCell) :: cellconnectionHDF5 - integer(pInt) :: j2=0_pInt -#endif - integer(I4P):: error - integer(I4P):: g, c, e, CellID, i, j - - cellID = 0_pInt - j = 0_pInt - do e = 1_pInt, mesh_NcpElems ! loop over cpElems - g = FE_geomtype(mesh_element(2_pInt,e)) ! get geometry type - c = FE_celltype(g) ! get cell type - do i = 1_pInt,FE_Nips(g) ! loop over ips=cells in this element - cellID = cellID + 1_pInt - celltype(cellID) = MESH_VTKCELLTYPE(c) - cellconnection(j+1_pInt:j+FE_NcellnodesPerCell(c)+1_pInt) & - = [FE_NcellnodesPerCell(c),mesh_cell(1:FE_NcellnodesPerCell(c),i,e)-1_pInt] ! number of cellnodes per cell & list of global cellnode IDs belnging to this cell (cellnode counting starts at 0) - j = j + FE_NcellnodesPerCell(c) + 1_pInt -#ifdef HDF - cellconnectionHDF5(j2+1_pInt:j2+FE_NcellnodesPerCell(c)) & - = mesh_cell(1:FE_NcellnodesPerCell(c),i,e)-1_pInt - j2=j2 + FE_ncellnodesPerCell(c) -#endif - enddo - enddo -#ifdef HDF - call HDF5_mappingCells(cellconnectionHDF5(1:j2)) -#endif - - error=VTK_ini(output_format = 'ASCII', & - title=trim(getSolverJobName())//' cell mesh', & - filename = trim(getSolverWorkingDirectoryName())//trim(getSolverJobName())//'_ipbased.vtk', & - mesh_topology = 'UNSTRUCTURED_GRID') - !ToDo: check error here - error=VTK_geo(NN = int(mesh_Ncellnodes,I4P), & - X = mesh_cellnode(1,1:mesh_Ncellnodes), & - Y = mesh_cellnode(2,1:mesh_Ncellnodes), & - Z = mesh_cellnode(3,1:mesh_Ncellnodes)) - !ToDo: check error here - error=VTK_con(NC = int(mesh_Ncells,I4P), & - connect = cellconnection(1:j), & - !ToDo: check error here - cell_type = celltype) - error=VTK_end() - !ToDo: check error here - -end subroutine mesh_write_cellGeom - - -!-------------------------------------------------------------------------------------------------- -!> @brief writes out initial element geometry -!-------------------------------------------------------------------------------------------------- -subroutine mesh_write_elemGeom - use DAMASK_interface, only: & - getSolverJobName, & - getSolverWorkingDirectoryName - use IR_Precision, only: & - I4P - use Lib_VTK_IO, only: & - VTK_ini, & - VTK_geo, & - VTK_con, & - VTK_end - - implicit none - integer(I4P), dimension(1:mesh_NcpElems) :: elemtype - integer(I4P), dimension(mesh_NcpElems*(1_pInt+FE_maxNnodes)) :: elementconnection - integer(I4P):: error - integer(pInt):: e, t, n, i - - i = 0_pInt - do e = 1_pInt, mesh_NcpElems ! loop over cpElems - t = mesh_element(2,e) ! get element type - elemtype(e) = MESH_VTKELEMTYPE(t) - elementconnection(i+1_pInt) = FE_Nnodes(t) ! number of nodes per element - do n = 1_pInt,FE_Nnodes(t) - elementconnection(i+1_pInt+n) = mesh_element(4_pInt+n,e) - 1_pInt ! global node ID of node that belongs to this element (node counting starts at 0) - enddo - i = i + 1_pInt + FE_Nnodes(t) - enddo - - error=VTK_ini(output_format = 'ASCII', & - title=trim(getSolverJobName())//' element mesh', & - filename = trim(getSolverWorkingDirectoryName())//trim(getSolverJobName())//'_nodebased.vtk', & - mesh_topology = 'UNSTRUCTURED_GRID') - !ToDo: check error here - error=VTK_geo(NN = int(mesh_Nnodes,I4P), & - X = mesh_node0(1,1:mesh_Nnodes), & - Y = mesh_node0(2,1:mesh_Nnodes), & - Z = mesh_node0(3,1:mesh_Nnodes)) - !ToDo: check error here - error=VTK_con(NC = int(mesh_Nelems,I4P), & - connect = elementconnection(1:i), & - cell_type = elemtype) - !ToDo: check error here - error =VTK_end() - !ToDo: check error here - -end subroutine mesh_write_elemGeom - - -!-------------------------------------------------------------------------------------------------- -!> @brief writes description file for mesh -!-------------------------------------------------------------------------------------------------- -subroutine mesh_write_meshfile - use IO, only: & - IO_write_jobFile - - implicit none - integer(pInt), parameter :: fileUnit = 223_pInt - integer(pInt) :: e,i,t,g,c,n - - call IO_write_jobFile(fileUnit,'mesh') - write(fileUnit,'(A16,E10.3)') 'unitlength', mesh_unitlength - write(fileUnit,'(A16,I10)') 'maxNcellnodes', mesh_maxNcellnodes - write(fileUnit,'(A16,I10)') 'maxNips', mesh_maxNips - write(fileUnit,'(A16,I10)') 'maxNnodes', mesh_maxNnodes - write(fileUnit,'(A16,I10)') 'Nnodes', mesh_Nnodes - write(fileUnit,'(A16,I10)') 'NcpElems', mesh_NcpElems - do e = 1_pInt,mesh_NcpElems - t = mesh_element(2,e) - write(fileUnit,'(20(I10))') mesh_element(1_pInt:4_pInt+FE_Nnodes(t),e) - enddo - write(fileUnit,'(A16,I10)') 'Ncellnodes', mesh_Ncellnodes - do n = 1_pInt,mesh_Ncellnodes - write(fileUnit,'(2(I10))') mesh_cellnodeParent(1:2,n) - enddo - write(fileUnit,'(A16,I10)') 'Ncells', mesh_Ncells - do e = 1_pInt,mesh_NcpElems - t = mesh_element(2,e) - g = FE_geomtype(t) - c = FE_celltype(g) - do i = 1_pInt,FE_Nips(g) - write(fileUnit,'(8(I10))') & - mesh_cell(1_pInt:FE_NcellnodesPerCell(c),i,e) - enddo - enddo - close(fileUnit) - -end subroutine mesh_write_meshfile - - -!-------------------------------------------------------------------------------------------------- -!> @brief reads mesh description file -!-------------------------------------------------------------------------------------------------- -integer function mesh_read_meshfile(filepath) - - implicit none - character(len=*), intent(in) :: filepath - integer(pInt), parameter :: fileUnit = 223_pInt - integer(pInt) :: e,i,t,g,n - - open(fileUnit,status='old',err=100,iostat=mesh_read_meshfile,action='read',file=filepath) - read(fileUnit,'(TR16,E10.3)',err=100,iostat=mesh_read_meshfile) mesh_unitlength - read(fileUnit,'(TR16,I10)',err=100,iostat=mesh_read_meshfile) mesh_maxNcellnodes - read(fileUnit,'(TR16,I10)',err=100,iostat=mesh_read_meshfile) mesh_maxNips - read(fileUnit,'(TR16,I10)',err=100,iostat=mesh_read_meshfile) mesh_maxNnodes - read(fileUnit,'(TR16,I10)',err=100,iostat=mesh_read_meshfile) mesh_Nnodes - read(fileUnit,'(TR16,I10)',err=100,iostat=mesh_read_meshfile) mesh_NcpElems - if (.not. allocated(mesh_element)) allocate(mesh_element(4_pInt+mesh_maxNnodes,mesh_NcpElems)) - mesh_element = 0_pInt - do e = 1_pInt,mesh_NcpElems - read(fileUnit,'(20(I10))',err=100,iostat=mesh_read_meshfile) & - mesh_element(:,e) - enddo - read(fileUnit,'(TR16,I10)',err=100,iostat=mesh_read_meshfile) mesh_Ncellnodes - if (.not. allocated(mesh_cellnodeParent)) allocate(mesh_cellnodeParent(2_pInt,mesh_Ncellnodes)) - do n = 1_pInt,mesh_Ncellnodes - read(fileUnit,'(2(I10))',err=100,iostat=mesh_read_meshfile) mesh_cellnodeParent(1:2,n) - enddo - read(fileUnit,'(TR16,I10)',err=100,iostat=mesh_read_meshfile) mesh_Ncells - if (.not. allocated(mesh_cell)) allocate(mesh_cell(FE_maxNcellnodesPerCell,mesh_maxNips,mesh_NcpElems)) - do e = 1_pInt,mesh_NcpElems - t = mesh_element(2,e) - g = FE_geomtype(t) - do i = 1_pInt,FE_Nips(g) - read(fileUnit,'(8(I10))',err=100,iostat=mesh_read_meshfile) mesh_cell(:,i,e) - enddo - enddo - close(fileUnit) - - mesh_read_meshfile = 0 ! successfully read data - -100 continue -end function mesh_read_meshfile - - -!-------------------------------------------------------------------------------------------------- -!> @brief initializes mesh data for use in post processing -!-------------------------------------------------------------------------------------------------- -integer function mesh_init_postprocessing(filepath) - - implicit none - character(len=*), intent(in) :: filepath - - call mesh_build_FEdata - mesh_init_postprocessing = mesh_read_meshfile(filepath) - -end function mesh_init_postprocessing - - !-------------------------------------------------------------------------------------------------- !> @brief returns global variable mesh_Ncellnodes !-------------------------------------------------------------------------------------------------- diff --git a/configure b/configure index 017d28b04..4841dcf1a 100755 --- a/configure +++ b/configure @@ -22,19 +22,6 @@ class extendableOption(Option): Option.take_action(self, action, dest, opt, value, values, parser) - -# ----------------------------- -def filePresent(paths,files,warning=False): - - for path in paths: - for file in files: - if os.path.isfile(os.path.join(path,file)): return True - - if warning: print "Warning: %s not found in %s"%(','.join(files),','.join(paths)) - - return False - - ######################################################## # MAIN ######################################################## @@ -42,35 +29,15 @@ def filePresent(paths,files,warning=False): parser = OptionParser(option_class=extendableOption, usage='%prog options', description = """ Configures the compilation and installation of DAMASK -""" + string.replace('$Id$','\n','\\n') -) - -#--- determine default compiler ---------------------------------------------------------------------- -compiler = os.getenv('F90') -if compiler == None: - compiler = 'ifort' if subprocess.call(['which', 'ifort'], stdout=subprocess.PIPE, stderr=subprocess.PIPE) == 0 \ - else 'gfortran' - -#--- default option values -------------------------------------------------------------------------- -BLAS_order = ['IMKL','ACML','LAPACK','OPENBLAS'] - +""") defaults={'DAMASK_BIN':'depending on access rights', - 'F90':compiler, 'FFTW_ROOT':'/usr', 'MSC_ROOT' :'/msc', 'DAMASK_NUM_THREADS':4, 'MARC_VERSION':'2015', - 'blasType':'LAPACK', - 'blasRoot':{'LAPACK' :'/usr', - 'ACML' :'/opt/acml6.1.0', - 'IMKL' : os.getenv('MKLROOT') if os.getenv('MKLROOT') else '/opt/intel/composerxe/mkl', - 'OPENBLAS' :'/usr', - }, 'spectralOptions':{}, } - - #--- if local config file exists, read, otherwise assume global config file ------------------------ configFile = os.path.join(os.getenv('HOME'),'.damask/damask.conf') \ if os.path.isfile(os.path.join(os.getenv('HOME'),'.damask/damask.conf')) \ @@ -91,129 +58,25 @@ try: defaults['DAMASK_NUM_THREADS'] = int(value) if key == 'DAMASK_BIN': defaults['DAMASK_BIN'] = value - if key in ['F90','FFTW_ROOT','MSC_ROOT','spectralOptions','MARC_VERSION']: - defaults[key] = value - for theKey in reversed(BLAS_order): - if key == theKey+'_ROOT' and value != None and value != '': - defaults['blasType'] = theKey - defaults['blasRoot'][theKey] = value except IOError: pass parser.add_option('--prefix', dest='prefix', metavar='string', help='location of (links to) DAMASK executables [%default]') -parser.add_option('--with-FC','--with-fc', - dest='compiler', metavar='string', - help='F90 compiler [%default]') -parser.add_option('--with-FFTW-dir','--with-fftw-dir', - dest='fftwRoot', metavar='string', - help='root directory of FFTW [%default]') -parser.add_option('--with-MSC-dir','--with-msc-dir', - dest='mscRoot', metavar='string', - help='root directory of MSC.Marc/Mentat [%default]') -parser.add_option('--with-MARC-version','--with-marc-version', - dest='marcVersion', metavar='string', - help='version of MSC.Marc/Mentat [%default]') parser.add_option('--with-OMP-threads','--with-omp-threads', dest='threads', type='int', metavar='int', help='number of openMP threads [%default]') -parser.add_option('--with-BLAS-type','--with-blas-type', - dest='blasType', metavar='string', - help='type of BLAS/LAPACK library [%default] {{{}}}'.format(','.join(BLAS_order))) -parser.add_option('--with-BLAS-dir','--with-blas-dir', - dest='blasRoot',metavar='string', - help='root directory of BLAS/LAPACK library [%default]') parser.add_option('--with-spectral-options', dest='spectraloptions', action='extend', metavar='', help='options for compilation of spectral solver') parser.set_defaults(prefix = defaults['DAMASK_BIN']) -parser.set_defaults(compiler = defaults['F90']) -parser.set_defaults(fftwRoot = defaults['FFTW_ROOT']) parser.set_defaults(mscRoot = defaults['MSC_ROOT']) parser.set_defaults(marcVersion = defaults['MARC_VERSION']) parser.set_defaults(threads = defaults['DAMASK_NUM_THREADS']) -parser.set_defaults(blasType = defaults['blasType']) - -#--- set default for blasRoot depending on current option (or default) for blasType -------------------- -blasType = defaults['blasType'].upper() -for i, arg in enumerate(sys.argv): - if arg.lower().startswith('--with-blas-type'): - if arg.lower().endswith('--with-blas-type'): - blasType = sys.argv[i+1].upper() - else: - blasType = sys.argv[i][17:].upper() -if blasType not in BLAS_order: - blasType = defaults['blasType'].upper() - -parser.set_defaults(blasRoot = defaults['blasRoot'][blasType]) parser.set_defaults(spectraloptions = []) (options,filenames) = parser.parse_args() -#--- consistency checks -------------------------------------------------------------------------------- -options.compiler = options.compiler.lower() -options.blasType = options.blasType.upper() -options.fftwRoot = os.path.normpath(options.fftwRoot) -options.mscRoot = os.path.normpath(options.mscRoot) -options.blasRoot = os.path.normpath(options.blasRoot) - -locations = { - 'FFTW' : [os.path.join(options.fftwRoot,'lib64'),os.path.join(options.fftwRoot,'lib')], - 'LAPACK' : [os.path.join(options.blasRoot,'lib64'),os.path.join(options.blasRoot,'lib')], - 'OPENBLAS': [os.path.join(options.blasRoot,'lib64'),os.path.join(options.blasRoot,'lib')], - 'ACML' : [os.path.join(options.blasRoot,'%s64/lib'%options.compiler)], - 'ACML_mp' : [os.path.join(options.blasRoot,'%s64_mp/lib'%options.compiler)], - 'IMKL' : [os.path.join(options.blasRoot,'lib/intel64')], -} - -libraries = { - 'FFTW' : [ - 'libfftw3.so','libfftw3.a', - 'libfftw3_threads.so','libfftw3_threads.a', - ], - 'LAPACK' : [ - 'liblapack.so','liblapack.a','liblapack.dylib', - ], - 'OPENBLAS' : [ - 'libopenblas.so','libopenblas.a','libopenblas.dylib', - ], - 'ACML' : [ - 'libacml.so','libacml.a', - ], - 'ACML_mp' : [ - 'libacml_mp.so','libacml_mp.a', - ], - 'IMKL' : [ - 'libmkl_core.so','libmkl_core.a', - 'libmkl_sequential.so','libmkl_sequential.a', - 'libmkl_intel_thread.so','libmkl_intel_thread.a', - 'libmkl_intel_lp64.so','libmkl_intel_lp64.a', - 'libmkl_gnu_thread.so','libmkl_gnu_thread.a', - 'libmkl_gf_lp64.so','libmkl_gf_lp64.a', - ], - - } -if options.compiler not in ['ifort','gfortran']: - print('Error: Unknown compiler option: %s'%options.compiler) - sys.exit(1) - -if not subprocess.call(['which', options.compiler], stdout=subprocess.PIPE, stderr=subprocess.PIPE) == 0: - print('Compiler Warning: executable %s not found!'%options.compiler) - -if not os.path.isdir(options.mscRoot): - print('Warning: MSC root directory %s not found!'%options.mscRoot) - - -filePresent(locations['FFTW'],libraries['FFTW'],warning=True) - -if options.blasType in ['LAPACK','OPENBLAS','IMKL']: - filePresent(locations[options.blasType],libraries[options.blasType],warning=True) -elif options.blasType == 'ACML': - filePresent(locations[options.blasType],libraries[options.blasType],warning=True) - filePresent(locations[options.blasType+'_mp'],libraries[options.blasType+'_mp'],warning=True) -else: - print('Error: Unknown BLAS/LAPACK library: %s'%options.blasType) - sys.exit(1) #--- read config file if present to keep comments and order --------------------------------------- output = [] @@ -228,12 +91,6 @@ try: if items[0] == 'DAMASK_BIN': line = '%s=%s'%(items[0],options.prefix) options.prefix ='depending on access rights' - if items[0] == 'F90': - line = '%s=%s'%(items[0],options.compiler) - options.compiler ='' - if items[0] == 'FFTW_ROOT': - line = '%s=%s'%(items[0],options.fftwRoot) - options.fftwRoot ='' if items[0] == 'MSC_ROOT': line = '%s=%s'%(items[0],options.mscRoot) options.mscRoot ='' @@ -243,14 +100,6 @@ try: if items[0] == 'DAMASK_NUM_THREADS': line = '%s=%s'%(items[0],options.threads) options.threads ='' - for blasType in defaults['blasRoot'].keys(): - if items[0] == '%s_ROOT'%blasType and items[0] == '%s_ROOT'%options.blasType: - line = '%s=%s'%(items[0],options.blasRoot) - options.blasType='' - elif items[0] == '#%s_ROOT'%blasType and items[0] == '#%s_ROOT'%options.blasType: - line = '%s=%s'%(items[0][1:],options.blasRoot) - options.blasType='' - elif items[0] == '%s_ROOT'%blasType: line = '#'+line for spectralOption in options.spectraloptions: [key,value] = re.split('[= ]',spectralOption)[0:2] if key == items[0]: @@ -264,18 +113,12 @@ except IOError: for opt, value in options.__dict__.items(): if opt == 'prefix' and value != 'depending on access rights': output.append('DAMASK_BIN=%s'%value) - if opt == 'compiler' and value != '': - output.append('F90=%s'%value) - if opt == 'fftwRoot' and value != '': - output.append('FFTW_ROOT=%s'%value) if opt == 'mscRoot' and value != '': output.append('MSC_ROOT=%s'%value) if opt == 'marcVersion' and value != '': output.append('MARC_VERSION=%s'%value) if opt == 'threads' and value != '': output.append('DAMASK_NUM_THREADS=%s'%value) - if opt == 'blasType' and value != '': - output.append('%s_ROOT=%s'%(options.blasType,options.blasRoot)) for spectralOption in options.spectraloptions: output.append(spectralOption) diff --git a/lib/IR_Precision.f90 b/lib/IR_Precision.f90 deleted file mode 100644 index d80923fee..000000000 --- a/lib/IR_Precision.f90 +++ /dev/null @@ -1,1230 +0,0 @@ -!> @addtogroup GlobalVarPar Global Variables and Parameters -!> List of global variables and parameters. -!> @addtogroup Interface Interfaces -!> List of explicitly defined interface. -!> @addtogroup Library Modules Libraries -!> List of modules containing libraries of procedures. -!> @addtogroup PublicProcedure Public Procedures -!> List of public procedures. -!> @addtogroup PrivateProcedure Private Procedures -!> List of private procedures. - -!> @ingroup Library -!> @{ -!> @defgroup IR_PrecisionLibrary IR_Precision -!> Portable kind-parameters module -!> @} - -!> @ingroup Interface -!> @{ -!> @defgroup IR_PrecisionInterface IR_Precision -!> Portable kind-parameters module -!> @} - -!> @ingroup GlobalVarPar -!> @{ -!> @defgroup IR_PrecisionGlobalVarPar IR_Precision -!> Portable kind-parameters module -!> @} - -!> @ingroup PublicProcedure -!> @{ -!> @defgroup IR_PrecisionPublicProcedure IR_Precision -!> Portable kind-parameters module -!> @} - -!> @ingroup PrivateProcedure -!> @{ -!> @defgroup IR_PrecisionPrivateProcedure IR_Precision -!> Portable kind-parameters module -!> @} - -!> @brief Module IR_Precision makes available some portable kind-parameters and some useful procedures to deal with them. -!> @details It also provides variables that contain the minimum and maximum representable values, smallest real values and -!> smallest representable differences by the running calculator. -!> -!> Finally the module provides procedures to convert a string to number and vice versa, a function to check the endianism -!> of the running calculator and a procedure to print all the aboves values. -!> @note The \em quadruple precision R16P could be activated defining \b r16p pre-processor flag (e.g. -Dr16p). Furthermore if -!> compiling with Portland Group Compiler define the pre-processor flag \b pgf95 to avoid error in computing \em Zero variables: -!> pgf compiler doesn't accept \b nearest built-in function in variables initialization. -!> @author Stefano Zaghi -!> @version 1.0 -!> @date 2012-04-24 -!> @copyright GNU Public License version 3. -!> @todo \b g95_test: Test g95 compiler -!> @ingroup IR_PrecisionLibrary -module IR_Precision -!----------------------------------------------------------------------------------------------------------------------------------- -USE, intrinsic:: ISO_FORTRAN_ENV, only: stdout => OUTPUT_UNIT, stderr => ERROR_UNIT ! Standard output/error logical units. -!----------------------------------------------------------------------------------------------------------------------------------- - -!----------------------------------------------------------------------------------------------------------------------------------- -implicit none -private -public:: endianL,endianB,endian -public:: R16P, FR16P, DR16P, MinR16P, MaxR16P, BIR16P, BYR16P, smallR16P, ZeroR16 -public:: R8P, FR8P, DR8P, MinR8P, MaxR8P, BIR8P, BYR8P, smallR8P, ZeroR8 -public:: R4P, FR4P, DR4P, MinR4P, MaxR4P, BIR4P, BYR4P, smallR4P, ZeroR4 -public:: R_P, FR_P, DR_P, MinR_P, MaxR_P, BIR_P, BYR_P, smallR_P, Zero -public:: I8P, FI8P, DI8P, MinI8P, MaxI8P, BII8P, BYI8P -public:: I4P, FI4P, DI4P, MinI4P, MaxI4P, BII4P, BYI4P -public:: I2P, FI2P, DI2P, MinI2P, MaxI2P, BII2P, BYI2P -public:: I1P, FI1P, DI1P, MinI1P, MaxI1P, BII1P, BYI1P -public:: I_P, FI_P, DI_P, MinI_P, MaxI_P, BII_P, BYI_P -public:: NRknd, RPl, FRl -public:: NIknd, RIl, FIl -public:: check_endian -public:: bit_size,byte_size -public:: str, strz, cton, bstr, bcton -public:: ir_initialized,IR_Init -public:: IR_Print -!----------------------------------------------------------------------------------------------------------------------------------- - -!----------------------------------------------------------------------------------------------------------------------------------- -!> @ingroup IR_PrecisionGlobalVarPar -!> @{ -logical:: ir_initialized = .false. !< Flag for chcecking the initialization of some variables that must be initialized by IR_Init. -! Bit ordering of the running architecture: -integer, parameter:: endianL = 1 !< Little endian parameter. -integer, parameter:: endianB = 0 !< Big endian parameter. -integer:: endian = endianL !< Bit ordering: Little endian (endianL), or Big endian (endianB). - -! The following are the portable kind parameters available. -! Real precision definitions: -#ifdef r16p -integer, parameter:: R16P = selected_real_kind(33,4931) !< 33 digits, range \f$[10^{-4931}, 10^{+4931} - 1]\f$; 128 bits. -#else -integer, parameter:: R16P = selected_real_kind(15,307) !< Defined as R8P; 64 bits. -#endif -integer, parameter:: R8P = selected_real_kind(15,307) !< 15 digits, range \f$[10^{-307} , 10^{+307} - 1]\f$; 64 bits. -integer, parameter:: R4P = selected_real_kind(6,37) !< 6 digits, range \f$[10^{-37} , 10^{+37} - 1]\f$; 32 bits. -integer, parameter:: R_P = R8P !< Default real precision. -! Integer precision definitions: -integer, parameter:: I8P = selected_int_kind(18) !< Range \f$[-2^{63},+2^{63} - 1]\f$, 19 digits plus sign; 64 bits. -integer, parameter:: I4P = selected_int_kind(9) !< Range \f$[-2^{31},+2^{31} - 1]\f$, 10 digits plus sign; 32 bits. -integer, parameter:: I2P = selected_int_kind(4) !< Range \f$[-2^{15},+2^{15} - 1]\f$, 5 digits plus sign; 16 bits. -integer, parameter:: I1P = selected_int_kind(2) !< Range \f$[-2^{7} ,+2^{7} - 1]\f$, 3 digits plus sign; 8 bits. -integer, parameter:: I_P = I4P !< Default integer precision. - -! Format parameters useful for writing in a well-ascii-format numeric variables. -! Real output formats: -character(10), parameter:: FR16P = '(E42.33E4)' !< Output format for kind=R16P variable. -character(10), parameter:: FR8P = '(E23.15E3)' !< Output format for kind=R8P variable. -character(9), parameter:: FR4P = '(E13.6E2)' !< Output format for kind=R4P variable. -character(10), parameter:: FR_P = FR8P !< Output format for kind=R_P variable. -! Real number of digits of output formats: -integer, parameter:: DR16P = 42 !< Number of digits of output format FR16P. -integer, parameter:: DR8P = 23 !< Number of digits of output format FR8P. -integer, parameter:: DR4P = 13 !< Number of digits of output format FR4P. -integer, parameter:: DR_P = DR8P !< Number of digits of output format FR_P. -! Integer output formats: -character(5), parameter:: FI8P = '(I20)' !< Output format for kind=I8P variable. -character(8), parameter:: FI8PZP = '(I20.19)' !< Output format with zero prefixing for kind=I8P variable. -character(5), parameter:: FI4P = '(I11)' !< Output format for kind=I4P variable. -character(8), parameter:: FI4PZP = '(I11.10)' !< Output format with zero prefixing for kind=I4P variable. -character(4), parameter:: FI2P = '(I6)' !< Output format for kind=I2P variable. -character(6), parameter:: FI2PZP = '(I6.5)' !< Output format with zero prefixing for kind=I2P variable. -character(4), parameter:: FI1P = '(I4)' !< Output format for kind=I1P variable. -character(6), parameter:: FI1PZP = '(I4.3)' !< Output format with zero prefixing for kind=I1P variable. -character(5), parameter:: FI_P = FI4P !< Output format for kind=I_P variable. -character(8), parameter:: FI_PZP = FI4PZP !< Output format with zero prefixing for kind=I_P variable. -! Integer number of digits of output formats: -integer, parameter:: DI8P = 20 !< Number of digits of output format I8P. -integer, parameter:: DI4P = 11 !< Number of digits of output format I4P. -integer, parameter:: DI2P = 6 !< Number of digits of output format I2P. -integer, parameter:: DI1P = 4 !< Number of digits of output format I1P. -integer, parameter:: DI_P = DI4P !< Number of digits of output format I_P. -! List of kinds -integer, parameter:: NRknd=4 !< Number of defined real kinds. -integer, parameter:: RPl(1:NRknd)=[R16P,R8P,R4P,R_P] !< List of defined real kinds. -character(10), parameter:: FRl(1:NRknd)=[FR16P,FR8P,FR4P//' ',FR_P] !< List of defined real kinds output format. -integer, parameter:: NIknd=5 !< Number of defined integer kinds. -integer, parameter:: RIl(1:NIknd)=[I8P,I4P,I2P,I1P,I_P] !< List of defined integer kinds. -character(5), parameter:: FIl(1:NIknd)=[FI8P,FI4P,FI2P//' ',FI1P//' ',FI_P] !< List of defined integer kinds output format. - -! Useful parameters for handling numbers ranges. -! Real min and max values: -real(R16P), parameter:: MinR16P = -huge(1._R16P), MaxR16P = huge(1._R16P) !< Min and max values of kind=R16P variable. -real(R8P), parameter:: MinR8P = -huge(1._R8P ), MaxR8P = huge(1._R8P ) !< Min and max values of kind=R8P variable. -real(R4P), parameter:: MinR4P = -huge(1._R4P ), MaxR4P = huge(1._R4P ) !< Min and max values of kind=R4P variable. -real(R_P), parameter:: MinR_P = MinR8P, MaxR_P = MaxR8P !< Min and max values of kind=R_P variable. -! Real number of bits/bytes -integer(I2P):: BIR16P, BYR16P !< Number of bits/bytes of kind=R16P variable. -integer(I1P):: BIR8P, BYR8P !< Number of bits/bytes of kind=R8P variable. -integer(I1P):: BIR4P, BYR4P !< Number of bits/bytes of kind=R4P variable. -integer(I1P):: BIR_P, BYR_P !< Number of bits/bytes of kind=R_P variable. -! Real smallest values: -real(R16P), parameter:: smallR16P = tiny(1._R16P) !< Smallest representable value of kind=R16P variable. -real(R8P), parameter:: smallR8P = tiny(1._R8P ) !< Smallest representable value of kind=R8P variable. -real(R4P), parameter:: smallR4P = tiny(1._R4P ) !< Smallest representable value of kind=R4P variable. -real(R_P), parameter:: smallR_P = smallR8P !< Smallest representable value of kind=R_P variable. -! Integer min and max values: -integer(I8P), parameter:: MinI8P = -huge(1_I8P), MaxI8P = huge(1_I8P) !< Min and max values of kind=I8P variable. -integer(I4P), parameter:: MinI4P = -huge(1_I4P), MaxI4P = huge(1_I4P) !< Min and max values of kind=I4P variable. -integer(I2P), parameter:: MinI2P = -huge(1_I2P), MaxI2P = huge(1_I2P) !< Min and max values of kind=I2P variable. -integer(I1P), parameter:: MinI1P = -huge(1_I1P), MaxI1P = huge(1_I1P) !< Min and max values of kind=I1P variable. -integer(I_P), parameter:: MinI_P = MinI4P, MaxI_P = MaxI4P !< Min and max values of kind=I_P variable. -! Integer number of bits/bytes: -integer(I8P), parameter:: BII8P = bit_size(MaxI8P), BYI8P = bit_size(MaxI8P)/8_I8P !< Number of bits/bytes of kind=I8P variable. -integer(I4P), parameter:: BII4P = bit_size(MaxI4P), BYI4P = bit_size(MaxI4P)/8_I4P !< Number of bits/bytes of kind=I4P variable. -integer(I2P), parameter:: BII2P = bit_size(MaxI2P), BYI2P = bit_size(MaxI2P)/8_I2P !< Number of bits/bytes of kind=I2P variable. -integer(I1P), parameter:: BII1P = bit_size(MaxI1P), BYI1P = bit_size(MaxI1P)/8_I1P !< Number of bits/bytes of kind=I1P variable. -integer(I_P), parameter:: BII_P = bit_size(MaxI_P), BYI_P = bit_size(MaxI_P)/8_I_P !< Number of bits/bytes of kind=I_P variable. -! Smallest real representable difference by the running calculator. -#ifdef pgf95 -real(R16P), parameter:: ZeroR16 = 0._R16P -real(R8P), parameter:: ZeroR8 = 0._R8P -real(R4P), parameter:: ZeroR4 = 0._R4P -#else -real(R16P), parameter:: ZeroR16 = nearest(1._R16P, 1._R16P) - & - nearest(1._R16P,-1._R16P) !< Smallest representable difference of kind=R16P variable. -real(R8P), parameter:: ZeroR8 = nearest(1._R8P, 1._R8P) - & - nearest(1._R8P,-1._R8P) !< Smallest representable difference of kind=R8P variable. -real(R4P), parameter:: ZeroR4 = nearest(1._R4P, 1._R4P) - & - nearest(1._R4P,-1._R4P) !< Smallest representable difference of kind=R4P variable. -#endif -real(R_P), parameter:: Zero = ZeroR8 !< Smallest representable difference of kind=R_P variable. -!> @} -!----------------------------------------------------------------------------------------------------------------------------------- - -!----------------------------------------------------------------------------------------------------------------------------------- -!> @brief Overloading of the intrinsic "bit_size" function for computing the number of bits of (also) real and character variables; -!> variable, intent(\b IN):: \em n input; -!> integer(I1P), intent(\b OUT):: \em bits output number of bits of input number. -!> @ingroup IR_PrecisionInterface -interface bit_size - module procedure & -#ifdef r16p - bit_size_R16p, & -#endif - bit_size_R8P, & - bit_size_R4P, & - bit_size_chr -endinterface -!> @brief Overloading of the "byte_size" function for computing the number of bytes. -!> @ingroup IR_PrecisionInterface -interface byte_size - module procedure & - byte_size_I8P, & - byte_size_I4P, & - byte_size_I2P, & - byte_size_I1P, & -#ifdef r16p - byte_size_R16p, & -#endif - byte_size_R8P, & - byte_size_R4P, & - byte_size_chr -endinterface -!> @brief Procedure for converting number, real and integer, to string (number to string type casting); -!> logical, intent(\b IN), optional:: \em no_sign flag for do not write sign; -!> number, intent(\b IN):: \em n input number; -!> string, intent(\b OUT):: \em str output string. -!> @ingroup IR_PrecisionInterface -interface str - module procedure & -#ifdef r16p - strf_R16P,str_R16P,& -#endif - strf_R8P ,str_R8P, & - strf_R4P ,str_R4P, & - strf_I8P ,str_I8P, & - strf_I4P ,str_I4P, & - strf_I2P ,str_I2P, & - strf_I1P ,str_I1P -endinterface -!> @brief Procedure for converting number, integer, to string, prefixing with the right number of zeros (number to string type -!> casting with zero padding); -!> number, intent(\b IN), optional:: \em no_zpad number of padding zeros; -!> number, intent(\b IN):: \em n input number; -!> string, intent(\b OUT):: \em str output string. -!> @ingroup IR_PrecisionInterface -interface strz - module procedure strz_I8P, & - strz_I4P, & - strz_I2P, & - strz_I1P -endinterface -!> @brief Procedure for converting string to number, real or initeger, (string to number type casting); -!> string, intent(\b IN):: \em str input string; -!> number, intent(\b OUT):: \em n output number. -!> @ingroup IR_PrecisionInterface -interface cton - module procedure & -#ifdef r16p - ctor_R16P, & -#endif - ctor_R8P, & - ctor_R4P, & - ctoi_I8P, & - ctoi_I4P, & - ctoi_I2P, & - ctoi_I1P -endinterface -!> @brief Procedure for converting number, real and integer, to bit-string (number to bit-string type casting); -!> number, intent(\b IN):: \em n input number; -!> string, intent(\b OUT):: \em bstr output bit-string. -!> @ingroup IR_PrecisionInterface -interface bstr - module procedure & -#ifdef r16p - bstr_R16P,& -#endif - bstr_R8P, & - bstr_R4P, & - bstr_I8P, & - bstr_I4P, & - bstr_I2P, & - bstr_I1P -endinterface -!> @brief Procedure for converting bit-string to number, real or initeger, (bit-string to number type casting); -!> string, intent(\b IN):: \em bstr input bit-string; -!> number, intent(\b OUT):: \em n output number. -!> @ingroup IR_PrecisionInterface -interface bcton - module procedure & -#ifdef r16p - bctor_R16P, & -#endif - bctor_R8P, & - bctor_R4P, & - bctoi_I8P, & - bctoi_I4P, & - bctoi_I2P, & - bctoi_I1P -endinterface -!----------------------------------------------------------------------------------------------------------------------------------- -contains - !> @ingroup IR_PrecisionPublicProcedure - !> @{ - !> @brief Procedure for checking if the type of the bit ordering of the running architecture is little endian. - pure function is_little_endian() result(is_little) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - logical:: is_little !< Logical output: true is the running architecture uses little endian ordering, false otherwise. - integer(I1P):: int1(1:4) !< One byte integer array for casting 4 bytes integer. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - int1 = transfer(1_I4P,int1) - is_little = (int1(1)==1_I1P) - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction is_little_endian - - !> @brief Subroutine for checking the type of bit ordering (big or little endian) of the running architecture; the result is - !> stored into the "endian" global variable. - subroutine check_endian() - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - if (is_little_endian()) then - endian = endianL - else - endian = endianB - endif - return - !--------------------------------------------------------------------------------------------------------------------------------- - endsubroutine check_endian - !> @} - - !> @ingroup IR_PrecisionPrivateProcedure - !> @{ - !> @brief Procedure for computing the number of bits of a real variable. - elemental function bit_size_R16P(r) result(bits) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - real(R16P), intent(IN):: r !< Real variable whose number of bits must be computed. - integer(I2P):: bits !< Number of bits of r. - integer(I1P):: mold(1) !< "Molding" dummy variable for bits counting. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - bits = size(transfer(r,mold),dim=1,kind=I2P)*8_I2P - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction bit_size_R16P - - !> @brief Procedure for computing the number of bits of a real variable. - elemental function bit_size_R8P(r) result(bits) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - real(R8P), intent(IN):: r !< Real variable whose number of bits must be computed. - integer(I1P):: bits !< Number of bits of r. - integer(I1P):: mold(1) !< "Molding" dummy variable for bits counting. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - bits = size(transfer(r,mold),dim=1,kind=I1P)*8_I1P - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction bit_size_R8P - - !> @brief Procedure for computing the number of bits of a real variable. - elemental function bit_size_R4P(r) result(bits) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - real(R4P), intent(IN):: r !< Real variable whose number of bits must be computed. - integer(I1P):: bits !< Number of bits of r. - integer(I1P):: mold(1) !< "Molding" dummy variable for bits counting. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - bits = size(transfer(r,mold),dim=1,kind=I1P)*8_I1P - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction bit_size_R4P - - !> @brief Procedure for computing the number of bits of a character variable. - elemental function bit_size_chr(c) result(bits) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - character(*), intent(IN):: c !< Character variable whose number of bits must be computed. - integer(I4P):: bits !< Number of bits of c. - integer(I1P):: mold(1) !< "Molding" dummy variable for bits counting. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - bits = size(transfer(c,mold),dim=1,kind=I4P)*8_I4P - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction bit_size_chr - - !> @brief Procedure for computing the number of bytes of an integer variable. - elemental function byte_size_I8P(i) result(bytes) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I8P), intent(IN):: i !< Integer variable whose number of bytes must be computed. - integer(I1P):: bytes !< Number of bytes of i. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - bytes = bit_size(i)/8_I1P - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction byte_size_I8P - - !> @brief Procedure for computing the number of bytes of an integer variable. - elemental function byte_size_I4P(i) result(bytes) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: i !< Integer variable whose number of bytes must be computed. - integer(I1P):: bytes !< Number of bytes of i. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - bytes = bit_size(i)/8_I1P - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction byte_size_I4P - - !> @brief Procedure for computing the number of bytes of an integer variable. - elemental function byte_size_I2P(i) result(bytes) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I2P), intent(IN):: i !< Integer variable whose number of bytes must be computed. - integer(I1P):: bytes !< Number of bytes of i. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - bytes = bit_size(i)/8_I1P - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction byte_size_I2P - - !> @brief Procedure for computing the number of bytes of an integer variable. - elemental function byte_size_I1P(i) result(bytes) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I1P), intent(IN):: i !< Integer variable whose number of bytes must be computed. - integer(I1P):: bytes !< Number of bytes of i. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - bytes = bit_size(i)/8_I1P - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction byte_size_I1P - - !> @brief Procedure for computing the number of bytes of a real variable. - elemental function byte_size_R16P(r) result(bytes) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - real(R16P), intent(IN):: r !< Real variable whose number of bytes must be computed. - integer(I1P):: bytes !< Number of bytes of r. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - bytes = bit_size(r)/8_I1P - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction byte_size_R16P - - !> @brief Procedure for computing the number of bytes of a real variable. - elemental function byte_size_R8P(r) result(bytes) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - real(R8P), intent(IN):: r !< Real variable whose number of bytes must be computed. - integer(I1P):: bytes !< Number of bytes of r. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - bytes = bit_size(r)/8_I1P - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction byte_size_R8P - - !> @brief Procedure for computing the number of bytes of a real variable. - elemental function byte_size_R4P(r) result(bytes) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - real(R4P), intent(IN):: r !< Real variable whose number of bytes must be computed. - integer(I1P):: bytes !< Number of bytes of r. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - bytes = bit_size(r)/8_I1P - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction byte_size_R4P - - !> @brief Procedure for computing the number of bytes of a character variable. - elemental function byte_size_chr(c) result(bytes) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - character(*), intent(IN):: c !< Character variable whose number of bytes must be computed. - integer(I4P):: bytes !< Number of bytes of c. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - bytes = bit_size(c)/8_I4P - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction byte_size_chr - - !> @brief Procedure for converting real to string. This function achieves casting of real to string. - elemental function strf_R16P(fm,n) result(str) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - character(*), intent(IN):: fm !< Format different from the standard for the kind. - real(R16P), intent(IN):: n !< Real to be converted. - character(DR16P):: str !< Returned string containing input number. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - write(str,trim(fm)) n ! Casting of n to string. - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction strf_R16P - - !> @brief Procedure for converting real to string. This function achieves casting of real to string. - elemental function strf_R8P(fm,n) result(str) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - character(*), intent(IN):: fm !< Format different from the standard for the kind. - real(R8P), intent(IN):: n !< Real to be converted. - character(DR8P):: str !< Returned string containing input number. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - write(str,trim(fm)) n ! Casting of n to string. - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction strf_R8P - - !> @brief Procedure for converting real to string. This function achieves casting of real to string. - elemental function strf_R4P(fm,n) result(str) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - character(*), intent(IN):: fm !< Format different from the standard for the kind. - real(R4P), intent(IN):: n !< Real to be converted. - character(DR4P):: str !< Returned string containing input number. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - write(str,trim(fm)) n ! Casting of n to string. - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction strf_R4P - - !> @brief Procedure for converting integer to string. This function achieves casting of integer to string. - elemental function strf_I8P(fm,n) result(str) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - character(*), intent(IN):: fm !< Format different from the standard for the kind. - integer(I8P), intent(IN):: n !< Integer to be converted. - character(DI8P):: str !< Returned string containing input number. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - write(str,trim(fm)) n ! Casting of n to string. - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction strf_I8P - - !> @brief Procedure for converting integer to string. This function achieves casting of integer to string. - elemental function strf_I4P(fm,n) result(str) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - character(*), intent(IN):: fm !< Format different from the standard for the kind. - integer(I4P), intent(IN):: n !< Integer to be converted. - character(DI4P):: str !< Returned string containing input number. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - write(str,trim(fm)) n ! Casting of n to string. - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction strf_I4P - - !> @brief Procedure for converting integer to string. This function achieves casting of integer to string. - elemental function strf_I2P(fm,n) result(str) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - character(*), intent(IN):: fm !< Format different from the standard for the kind. - integer(I2P), intent(IN):: n !< Integer to be converted. - character(DI2P):: str !< Returned string containing input number. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - write(str,trim(fm)) n ! Casting of n to string. - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction strf_I2P - - !> @brief Procedure for converting integer to string. This function achieves casting of integer to string. - elemental function strf_I1P(fm,n) result(str) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - character(*), intent(IN):: fm !< Format different from the standard for the kind. - integer(I1P), intent(IN):: n !< Integer to be converted. - character(DI1P):: str !< Returned string containing input number. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - write(str,trim(fm)) n ! Casting of n to string. - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction strf_I1P - - !> @brief Procedure for converting real to string. This function achieves casting of real to string. - elemental function str_R16P(no_sign,n) result(str) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - logical, intent(IN), optional:: no_sign !< Flag for leaving out the sign. - real(R16P), intent(IN):: n !< Real to be converted. - character(DR16P):: str !< Returned string containing input number. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - write(str,FR16P) n ! Casting of n to string. - if (n>0._R16P) str(1:1)='+' ! Prefixing plus if n>0. - if (present(no_sign)) str=str(2:) ! Leaving out the sign. - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction str_R16P - - !> @brief Procedure for converting real to string. This function achieves casting of real to string. - elemental function str_R8P(no_sign,n) result(str) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - logical, intent(IN), optional:: no_sign !< Flag for leaving out the sign. - real(R8P), intent(IN):: n !< Real to be converted. - character(DR8P):: str !< Returned string containing input number. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - write(str,FR8P) n ! Casting of n to string. - if (n>0._R8P) str(1:1)='+' ! Prefixing plus if n>0. - if (present(no_sign)) str=str(2:) ! Leaving out the sign. - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction str_R8P - - !> @brief Procedure for converting real to string. This function achieves casting of real to string. - elemental function str_R4P(no_sign,n) result(str) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - logical, intent(IN), optional:: no_sign !< Flag for leaving out the sign. - real(R4P), intent(IN):: n !< Real to be converted. - character(DR4P):: str !< Returned string containing input number. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - write(str,FR4P) n ! Casting of n to string. - if (n>0._R4P) str(1:1)='+' ! Prefixing plus if n>0. - if (present(no_sign)) str=str(2:) ! Leaving out the sign. - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction str_R4P - - !> @brief Procedure for converting integer to string. This function achieves casting of integer to string. - elemental function str_I8P(no_sign,n) result(str) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - logical, intent(IN), optional:: no_sign !< Flag for leaving out the sign. - integer(I8P), intent(IN):: n !< Integer to be converted. - character(DI8P):: str !< Returned string containing input number plus padding zeros. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - write(str,FI8P) n ! Casting of n to string. - str = adjustl(trim(str)) ! Removing white spaces. - if (n>=0_I8P) str='+'//trim(str) ! Prefixing plus if n>0. - if (present(no_sign)) str=str(2:) ! Leaving out the sign. - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction str_I8P - - !> @brief Procedure for converting integer to string. This function achieves casting of integer to string. - elemental function str_I4P(no_sign,n) result(str) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - logical, intent(IN), optional:: no_sign !< Flag for leaving out the sign. - integer(I4P), intent(IN):: n !< Integer to be converted. - character(DI4P):: str !< Returned string containing input number plus padding zeros. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - write(str,FI4P) n ! Casting of n to string. - str = adjustl(trim(str)) ! Removing white spaces. - if (n>=0_I4P) str='+'//trim(str) ! Prefixing plus if n>0. - if (present(no_sign)) str=str(2:) ! Leaving out the sign. - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction str_I4P - - !> @brief Procedure for converting integer to string. This function achieves casting of integer to string. - elemental function str_I2P(no_sign,n) result(str) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - logical, intent(IN), optional:: no_sign !< Flag for leaving out the sign. - integer(I2P), intent(IN):: n !< Integer to be converted. - character(DI2P):: str !< Returned string containing input number plus padding zeros. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - write(str,FI2P) n ! Casting of n to string. - str = adjustl(trim(str)) ! Removing white spaces. - if (n>=0_I2P) str='+'//trim(str) ! Prefixing plus if n>0. - if (present(no_sign)) str=str(2:) ! Leaving out the sign. - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction str_I2P - - !> @brief Procedure for converting integer to string. This function achieves casting of integer to string. - elemental function str_I1P(no_sign,n) result(str) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - logical, intent(IN), optional:: no_sign !< Flag for leaving out the sign. - integer(I1P), intent(IN):: n !< Integer to be converted. - character(DI1P):: str !< Returned string containing input number plus padding zeros. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - write(str,FI1P) n ! Casting of n to string. - str = adjustl(trim(str)) ! Removing white spaces. - if (n>=0_I1P) str='+'//trim(str) ! Prefixing plus if n>0. - if (present(no_sign)) str=str(2:) ! Leaving out the sign. - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction str_I1P - - !> @brief Procedure for converting integer to string, prefixing with the right number of zeros. This function achieves casting of - !> integer to string. - elemental function strz_I8P(nz_pad,n) result(str) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN), optional:: nz_pad !< Number of zeros padding. - integer(I8P), intent(IN):: n !< Integer to be converted. - character(DI8P):: str !< Returned string containing input number plus padding zeros. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - write(str,FI8PZP) n ! Casting of n to string. - str=str(2:) ! Leaving out the sign. - if (present(nz_pad)) str=str(DI8P-nz_pad:DI8P-1) ! Leaving out the extra zeros padding - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction strz_I8P - - !> @brief Procedure for converting integer to string, prefixing with the right number of zeros. This function achieves casting of - !> integer to string. - elemental function strz_I4P(nz_pad,n) result(str) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN), optional:: nz_pad !< Number of zeros padding. - integer(I4P), intent(IN):: n !< Integer to be converted. - character(DI4P):: str !< Returned string containing input number plus padding zeros. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - write(str,FI4PZP) n ! Casting of n to string. - str=str(2:) ! Leaving out the sign. - if (present(nz_pad)) str=str(DI4P-nz_pad:DI4P-1) ! Leaving out the extra zeros padding - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction strz_I4P - - !> @brief Procedure for converting integer to string, prefixing with the right number of zeros. This function achieves casting of - !> integer to string. - elemental function strz_I2P(nz_pad,n) result(str) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN), optional:: nz_pad !< Number of zeros padding. - integer(I2P), intent(IN):: n !< Integer to be converted. - character(DI2P):: str !< Returned string containing input number plus padding zeros. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - write(str,FI2PZP) n ! Casting of n to string. - str=str(2:) ! Leaving out the sign. - if (present(nz_pad)) str=str(DI2P-nz_pad:DI2P-1) ! Leaving out the extra zeros padding - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction strz_I2P - - !> @brief Procedure for converting integer to string, prefixing with the right number of zeros. This function achieves casting of - !> integer to string. - elemental function strz_I1P(nz_pad,n) result(str) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN), optional:: nz_pad !< Number of zeros padding. - integer(I1P), intent(IN):: n !< Integer to be converted. - character(DI1P):: str !< Returned string containing input number plus padding zeros. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - write(str,FI1PZP) n ! Casting of n to string. - str=str(2:) ! Leaving out the sign. - if (present(nz_pad)) str=str(DI1P-nz_pad:DI1P-1) ! Leaving out the extra zeros padding - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction strz_I1P - - !> @brief Procedure for converting string to real. This function achieves casting of string to real. - function ctor_R16P(str,knd) result(n) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - character(*), intent(IN):: str !< String containing input number. - real(R16P), intent(IN):: knd !< Number kind. - real(R16P):: n !< Number returned. - integer(I4P):: err !< Error trapping flag: 0 no errors, >0 error occurs. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - read(str,*,iostat=err) n ! Casting of str to n. - if (err/=0) then - write(stderr,'(A)') 'Conversion of string "'//str//'" to real failed' - write(stderr,'(A,'//FR16P//')') 'Kind parameter ',knd - write(stderr,'(A)') 'Function used "ctor_R16P"' - endif - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction ctor_R16P - - !> @brief Procedure for converting string to real. This function achieves casting of string to real. - function ctor_R8P(str,knd) result(n) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - character(*), intent(IN):: str !< String containing input number. - real(R8P), intent(IN):: knd !< Number kind. - real(R8P):: n !< Number returned. - integer(I4P):: err !< Error trapping flag: 0 no errors, >0 error occurs. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - read(str,*,iostat=err) n ! Casting of str to n. - if (err/=0) then - write(stderr,'(A)') 'Conversion of string "'//str//'" to real failed' - write(stderr,'(A,'//FR8P//')') 'Kind parameter ',knd - write(stderr,'(A)') 'Function used "ctor_R8P"' - endif - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction ctor_R8P - - !> @brief Procedure for converting string to real. This function achieves casting of string to real. - function ctor_R4P(str,knd) result(n) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - character(*), intent(IN):: str !< String containing input number. - real(R4P), intent(IN):: knd !< Number kind. - real(R4P):: n !< Number returned. - integer(I4P):: err !< Error trapping flag: 0 no errors, >0 error occurs. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - read(str,*,iostat=err) n ! Casting of str to n. - if (err/=0) then - write(stderr,'(A)') 'Conversion of string "'//str//'" to real failed' - write(stderr,'(A,'//FR4P//')') 'Kind parameter ',knd - write(stderr,'(A)') 'Function used "ctor_R4P"' - endif - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction ctor_R4P - - !> @brief Procedure for converting string to integer. This function achieves casting of string to integer. - function ctoi_I8P(str,knd) result(n) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - character(*), intent(IN):: str !< String containing input number. - integer(I8P), intent(IN):: knd !< Number kind. - integer(I8P):: n !< Number returned. - integer(I4P):: err !< Error trapping flag: 0 no errors, >0 error occurs. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - read(str,*,iostat=err) n ! Casting of str to n. - if (err/=0) then - write(stderr,'(A)') 'Conversion of string "'//str//'" to integer failed' - write(stderr,'(A,'//FI8P//')') 'Kind parameter ',knd - write(stderr,'(A)') 'Function used "ctoi_I8P"' - endif - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction ctoi_I8P - - !> @brief Procedure for converting string to integer. This function achieves casting of string to integer. - function ctoi_I4P(str,knd) result(n) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - character(*), intent(IN):: str !< String containing input number. - integer(I4P), intent(IN):: knd !< Number kind. - integer(I4P):: n !< Number returned. - integer(I4P):: err !< Error trapping flag: 0 no errors, >0 error occurs. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - read(str,*,iostat=err) n ! Casting of str to n. - if (err/=0) then - write(stderr,'(A)') 'Conversion of string "'//str//'" to integer failed' - write(stderr,'(A,'//FI4P//')') 'Kind parameter ',knd - write(stderr,'(A)') 'Function used "ctoi_I4P"' - endif - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction ctoi_I4P - - !> @brief Procedure for converting string to integer. This function achieves casting of string to integer. - function ctoi_I2P(str,knd) result(n) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - character(*), intent(IN):: str !< String containing input number. - integer(I2P), intent(IN):: knd !< Number kind. - integer(I2P):: n !< Number returned. - integer(I4P):: err !< Error trapping flag: 0 no errors, >0 error occurs. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - read(str,*,iostat=err) n ! Casting of str to n. - if (err/=0) then - write(stderr,'(A)') 'Conversion of string "'//str//'" to integer failed' - write(stderr,'(A,'//FI2P//')') 'Kind parameter ',knd - write(stderr,'(A)') 'Function used "ctoi_I2P"' - endif - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction ctoi_I2P - - !> @brief Procedure for converting string to integer. This function achieves casting of string to integer. - function ctoi_I1P(str,knd) result(n) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - character(*), intent(IN):: str !< String containing input number. - integer(I1P), intent(IN):: knd !< Number kind. - integer(I1P):: n !< Number returned. - integer(I4P):: err !< Error trapping flag: 0 no errors, >0 error occurs. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - read(str,*,iostat=err) n ! Casting of str to n. - if (err/=0) then - write(stderr,'(A)') 'Conversion of string "'//str//'" to integer failed' - write(stderr,'(A,'//FI1P//')') 'Kind parameter ',knd - write(stderr,'(A)') 'Function used "ctoi_I1P"' - endif - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction ctoi_I1P - - !> @brief Procedure for converting real to string of bits. This function achieves casting of real to bit-string. - !> @note It is assumed that R16P is represented by means of 128 bits, but this is not ensured in all architectures. - elemental function bstr_R16P(n) result(bstr) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - real(R8P), intent(IN):: n !< Real to be converted. - character(128):: bstr !< Returned bit-string containing input number. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - write(bstr,'(B128.128)')n ! Casting of n to bit-string. - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction bstr_R16P - - !> @brief Procedure for converting real to string of bits. This function achieves casting of real to bit-string. - !> @note It is assumed that R8P is represented by means of 64 bits, but this is not ensured in all architectures. - elemental function bstr_R8P(n) result(bstr) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - real(R8P), intent(IN):: n !< Real to be converted. - character(64):: bstr !< Returned bit-string containing input number. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - write(bstr,'(B64.64)')n ! Casting of n to bit-string. - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction bstr_R8P - - !> @brief Procedure for converting real to string of bits. This function achieves casting of real to bit-string. - !> @note It is assumed that R4P is represented by means of 32 bits, but this is not ensured in all architectures. - elemental function bstr_R4P(n) result(bstr) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - real(R4P), intent(IN):: n !< Real to be converted. - character(32):: bstr !< Returned bit-string containing input number. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - write(bstr,'(B32.32)')n ! Casting of n to bit-string. - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction bstr_R4P - - !> @brief Procedure for converting integer to string of bits. This function achieves casting of integer to bit-string. - !> @note It is assumed that I8P is represented by means of 64 bits, but this is not ensured in all architectures. - elemental function bstr_I8P(n) result(bstr) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I8P), intent(IN):: n !< Real to be converted. - character(64):: bstr !< Returned bit-string containing input number. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - write(bstr,'(B64.64)')n ! Casting of n to bit-string. - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction bstr_I8P - - !> @brief Procedure for converting integer to string of bits. This function achieves casting of integer to bit-string. - !> @note It is assumed that I4P is represented by means of 32 bits, but this is not ensured in all architectures. - elemental function bstr_I4P(n) result(bstr) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: n !< Real to be converted. - character(32):: bstr !< Returned bit-string containing input number. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - write(bstr,'(B32.32)')n ! Casting of n to bit-string. - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction bstr_I4P - - !> @brief Procedure for converting integer to string of bits. This function achieves casting of integer to bit-string. - !> @note It is assumed that I2P is represented by means of 16 bits, but this is not ensured in all architectures. - elemental function bstr_I2P(n) result(bstr) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I2P), intent(IN):: n !< Real to be converted. - character(16):: bstr !< Returned bit-string containing input number. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - write(bstr,'(B16.16)')n ! Casting of n to bit-string. - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction bstr_I2P - - !> @brief Procedure for converting integer to string of bits. This function achieves casting of integer to bit-string. - !> @note It is assumed that I1P is represented by means of 8 bits, but this is not ensured in all architectures. - elemental function bstr_I1P(n) result(bstr) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I1P), intent(IN):: n !< Real to be converted. - character(8):: bstr !< Returned bit-string containing input number. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - write(bstr,'(B8.8)')n ! Casting of n to bit-string. - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction bstr_I1P - - !> @brief Procedure for converting bit-string to real. This function achieves casting of bit-string to real. - elemental function bctor_R8P(bstr,knd) result(n) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - character(*), intent(IN):: bstr !< String containing input number. - real(R8P), intent(IN):: knd !< Number kind. - real(R8P):: n !< Number returned. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - read(bstr,'(B'//trim(str(.true.,bit_size(knd)))//'.'//trim(str(.true.,bit_size(knd)))//')')n ! Casting of bstr to n. - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction bctor_R8P - - !> @brief Procedure for converting bit-string to real. This function achieves casting of bit-string to real. - elemental function bctor_R4P(bstr,knd) result(n) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - character(*), intent(IN):: bstr !< String containing input number. - real(R4P), intent(IN):: knd !< Number kind. - real(R4P):: n !< Number returned. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - read(bstr,'(B'//trim(str(.true.,bit_size(knd)))//'.'//trim(str(.true.,bit_size(knd)))//')')n ! Casting of bstr to n. - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction bctor_R4P - - !> @brief Procedure for converting bit-string to integer. This function achieves casting of bit-string to integer. - elemental function bctoi_I8P(bstr,knd) result(n) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - character(*), intent(IN):: bstr !< String containing input number. - integer(I8P), intent(IN):: knd !< Number kind. - integer(I8P):: n !< Number returned. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - read(bstr,'(B'//trim(str(.true.,bit_size(knd)))//'.'//trim(str(.true.,bit_size(knd)))//')')n ! Casting of bstr to n. - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction bctoi_I8P - - !> @brief Procedure for converting bit-string to integer. This function achieves casting of bit-string to integer. - elemental function bctoi_I4P(bstr,knd) result(n) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - character(*), intent(IN):: bstr !< String containing input number. - integer(I4P), intent(IN):: knd !< Number kind. - integer(I4P):: n !< Number returned. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - read(bstr,'(B'//trim(str(.true.,bit_size(knd)))//'.'//trim(str(.true.,bit_size(knd)))//')')n ! Casting of bstr to n. - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction bctoi_I4P - - !> @brief Procedure for converting bit-string to integer. This function achieves casting of bit-string to integer. - elemental function bctoi_I2P(bstr,knd) result(n) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - character(*), intent(IN):: bstr !< String containing input number. - integer(I2P), intent(IN):: knd !< Number kind. - integer(I2P):: n !< Number returned. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - read(bstr,'(B'//trim(str(.true.,bit_size(knd)))//'.'//trim(str(.true.,bit_size(knd)))//')')n ! Casting of bstr to n. - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction bctoi_I2P - - !> @brief Procedure for converting bit-string to integer. This function achieves casting of bit-string to integer. - elemental function bctoi_I1P(bstr,knd) result(n) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - character(*), intent(IN):: bstr !< String containing input number. - integer(I1P), intent(IN):: knd !< Number kind. - integer(I1P):: n !< Number returned. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - read(bstr,'(B'//trim(str(.true.,bit_size(knd)))//'.'//trim(str(.true.,bit_size(knd)))//')')n ! Casting of bstr to n. - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction bctoi_I1P - !> @} - - !> Subroutine for initilizing module's variables that are not initialized into the definition specification. - !> @ingroup IR_PrecisionPublicProcedure - subroutine IR_init() - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - ! checking the bit ordering architecture - call check_endian - ! computing the bits/bytes sizes of real variables - BIR8P = bit_size(r=MaxR8P) ; BYR8P = BIR8P/8_I1P - BIR4P = bit_size(r=MaxR4P) ; BYR4P = BIR4P/8_I1P - BIR_P = bit_size(r=MaxR_P) ; BYR_P = BIR_P/8_I1P -#ifdef r16p - BIR16P = bit_size(r=MaxR16P) ; BYR16P = BIR16P/8_I2P -#else - BIR16P = int(BIR8P,kind=I2P) ; BYR16P = BIR16P/8_I2P -#endif - ir_initialized = .true. - return - !--------------------------------------------------------------------------------------------------------------------------------- - endsubroutine IR_init - - !>Subroutine for printing to the standard output the kind definition of reals and integers and the utility variables. - !> @ingroup IR_PrecisionPublicProcedure - subroutine IR_Print(myrank,Nproc) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN), optional:: myrank !< Actual rank process necessary for concurrent multi-processes calls. - integer(I4P), intent(IN), optional:: Nproc !< Number of MPI processes used. - character(DI4P):: rks !< String containing myrank. - integer(I4P):: rank,Np !< Dummy temporary variables. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - if (.not.ir_initialized) call IR_init - rank = 0 ; if (present(myrank)) rank = myrank ; Np = 1 ; if (present(Nproc)) Np = Nproc ; rks = 'rank'//trim(strz(Np,rank)) - ! printing informations - if (endian==endianL) then - write(stdout,'(A)') trim(rks)//' This architecture has LITTLE Endian bit ordering' - else - write(stdout,'(A)') trim(rks)//' This architecture has BIG Endian bit ordering' - endif - write(stdout,'(A)') trim(rks)//' Reals kind precision definition' - write(stdout,'(A,I2,A,I2,A)')trim(rks)//' R16P Kind "',R16P,'" | FR16P format "'//FR16P//'" | DR16P chars "',DR16P,'"' - write(stdout,'(A,I2,A,I2,A)')trim(rks)//' R8P Kind "',R8P, '" | FR8P format "'//FR8P// '" | DR8P chars "',DR8P ,'"' - write(stdout,'(A,I2,A,I2,A)')trim(rks)//' R4P Kind "',R4P, '" | FR4P format "'//FR4P//'" | DR4P chars "',DR4P ,'"' - write(stdout,'(A)') trim(rks)//' Integers kind precision definition' - write(stdout,'(A,I2,A,I2,A)')trim(rks)//' I8P Kind "',I8P,'" | FI8P format "'//FI8P// '" | DI8P chars "',DI8P,'"' - write(stdout,'(A,I2,A,I2,A)')trim(rks)//' I4P Kind "',I4P,'" | FI4P format "'//FI4P// '" | DI4P chars "',DI4P,'"' - write(stdout,'(A,I2,A,I2,A)')trim(rks)//' I2P Kind "',I2P,'" | FI2P format "'//FI2P//'" | DI2P chars "',DI2P,'"' - write(stdout,'(A,I2,A,I2,A)')trim(rks)//' I1P Kind "',I1P,'" | FI1P format "'//FI1P//'" | DI1P chars "',DI1P,'"' - write(stdout,'(A)') trim(rks)//' Reals minimum and maximum values' - write(stdout,'(A)') trim(rks)//' MinR16P "'//trim(str(n=MinR16P))//'" | MaxR16P "'//trim(str(n=MaxR16P))//'"' - write(stdout,'(A)') trim(rks)//' MinR8P "'//trim(str(n=MinR8P))// '" | MaxR8P "'//trim(str(n=MaxR8P))// '"' - write(stdout,'(A)') trim(rks)//' MinR4P "'//trim(str(n=MinR4P))// '" | MaxR4P "'//trim(str(n=MaxR4P))// '"' - write(stdout,'(A)') trim(rks)//' Reals bits/bytes sizes' - write(stdout,'(A,I2,A,I2,A)')trim(rks)//' R16P bits "',BIR16P,'", bytes "',BYR16P,'"' - write(stdout,'(A,I2,A,I2,A)')trim(rks)//' R8P bits "', BIR8P, '", bytes "',BYR8P, '"' - write(stdout,'(A,I2,A,I2,A)')trim(rks)//' R4P bits "', BIR4P, '", bytes "',BYR4P, '"' - write(stdout,'(A,I2,A,I2,A)')trim(rks)//' R_P bits "', BIR_P, '", bytes "',BYR_P, '"' - write(stdout,'(A)') trim(rks)//' Integers minimum and maximum values' - write(stdout,'(A)') trim(rks)//' MinI8P "'//trim(str(n=MinI8P))//'" | MaxI8P "'//trim(str(n=MaxI8P))//'"' - write(stdout,'(A)') trim(rks)//' MinI4P "'//trim(str(n=MinI4P))//'" | MaxI4P "'//trim(str(n=MaxI4P))//'"' - write(stdout,'(A)') trim(rks)//' MinI2P "'//trim(str(n=MinI2P))//'" | MaxI2P "'//trim(str(n=MaxI2P))//'"' - write(stdout,'(A)') trim(rks)//' MinI1P "'//trim(str(n=MinI1P))//'" | MaxI1P "'//trim(str(n=MaxI1P))//'"' - write(stdout,'(A)') trim(rks)//' Integers bits/bytes sizes' - write(stdout,'(A,I2,A,I2,A)')trim(rks)//' I8P bits "',BII8P,'", bytes "',BYI8P,'"' - write(stdout,'(A,I2,A,I2,A)')trim(rks)//' I4P bits "',BII4P,'", bytes "',BYI4P,'"' - write(stdout,'(A,I2,A,I2,A)')trim(rks)//' I2P bits "',BII2P,'", bytes "',BYI2P,'"' - write(stdout,'(A,I2,A,I2,A)')trim(rks)//' I1P bits "',BII1P,'", bytes "',BYI1P,'"' - write(stdout,'(A,I2,A,I2,A)')trim(rks)//' I_P bits "',BII_P,'", bytes "',BYI_P,'"' - write(stdout,'(A)') trim(rks)//' Machine precisions' - write(stdout,'(A)') trim(rks)//' ZeroR16 "'//trim(str(.true.,ZeroR16))//'"' - write(stdout,'(A)') trim(rks)//' ZeroR8 "'//trim(str(.true.,ZeroR8 ))//'"' - write(stdout,'(A)') trim(rks)//' ZeroR4 "'//trim(str(.true.,ZeroR4 ))//'"' - !--------------------------------------------------------------------------------------------------------------------------------- - endsubroutine IR_Print -endmodule IR_Precision diff --git a/lib/Lib_Base64.f90 b/lib/Lib_Base64.f90 deleted file mode 100644 index f1a5754eb..000000000 --- a/lib/Lib_Base64.f90 +++ /dev/null @@ -1,909 +0,0 @@ -!> @ingroup Library -!> @{ -!> @defgroup Lib_Base64Library Lib_Base64 -!> base64 encoding/decoding library -!> @} - -!> @ingroup Interface -!> @{ -!> @defgroup Lib_Base64Interface Lib_Base64 -!> base64 encoding/decoding library -!> @} - -!> @ingroup PublicProcedure -!> @{ -!> @defgroup Lib_Base64PublicProcedure Lib_Base64 -!> base64 encoding/decoding library -!> @} - -!> @ingroup PrivateProcedure -!> @{ -!> @defgroup Lib_Base64PrivateProcedure Lib_Base64 -!> base64 encoding/decoding library -!> @} - -!> @ingroup GlobalVarPar -!> @{ -!> @defgroup Lib_Base64GlobalVarPar Lib_Base64 -!> base64 encoding/decoding library -!> @} - -!> @ingroup PrivateVarPar -!> @{ -!> @defgroup Lib_Base64PrivateVarPar Lib_Base64 -!> base64 encoding/decoding library -!> @} - -!> This module contains base64 encoding/decoding procedures. -!> @todo \b Decoding: Implement decoding functions. -!> @todo \b DocComplete: Complete the documentation. -!> @ingroup Lib_Base64Library -module Lib_Base64 -!----------------------------------------------------------------------------------------------------------------------------------- -USE IR_Precision ! Integers and reals precision definition. -!----------------------------------------------------------------------------------------------------------------------------------- - -!----------------------------------------------------------------------------------------------------------------------------------- -implicit none -private -public:: b64_encode -!public:: b64_decode -public:: pack_data -!----------------------------------------------------------------------------------------------------------------------------------- - -!----------------------------------------------------------------------------------------------------------------------------------- -!> @ingroup Lib_Base64GlobalVarPar -!> @{ -!> @} -!> @ingroup Lib_Base64PrivateVarPar -!> @{ -character(64):: base64="ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" !< Base64 alphabet. -!> @} -!----------------------------------------------------------------------------------------------------------------------------------- - -!----------------------------------------------------------------------------------------------------------------------------------- -!> @brief Subroutine for encoding numbers (integer and real) to base64. -!> @ingroup Lib_Base64Interface -interface b64_encode - module procedure b64_encode_R8_a, & - b64_encode_R4_a, & - b64_encode_I8_a, & - b64_encode_I4_a, & - b64_encode_I2_a, & - b64_encode_I1_a -endinterface -!!> @brief Subroutine for decoding numbers (integer and real) from base64. -!!> @ingroup Lib_Base64Interface -!interface b64_decode -! module procedure b64_decode_R8_a, & -! b64_decode_R4_a, & -! b64_decode_I8_a, & -! b64_decode_I4_a, & -! b64_decode_I2_a, & -! b64_decode_I1_a -!endinterface -!> @brief Subroutine for packing different kinds of data into single I1P array. This is useful for encoding different kinds -!> variables into a single stream of bits. -!> @ingroup Lib_Base64Interface -interface pack_data - module procedure pack_data_R8_R4,pack_data_R8_I8,pack_data_R8_I4,pack_data_R8_I2,pack_data_R8_I1, & - pack_data_R4_R8,pack_data_R4_I8,pack_data_R4_I4,pack_data_R4_I2,pack_data_R4_I1, & - pack_data_I8_R8,pack_data_I8_R4,pack_data_I8_I4,pack_data_I8_I2,pack_data_I8_I1, & - pack_data_I4_R8,pack_data_I4_R4,pack_data_I4_I8,pack_data_I4_I2,pack_data_I4_I1, & - pack_data_I2_R8,pack_data_I2_R4,pack_data_I2_I8,pack_data_I2_I4,pack_data_I2_I1, & - pack_data_I1_R8,pack_data_I1_R4,pack_data_I1_I8,pack_data_I1_I4,pack_data_I1_I2 -endinterface -!----------------------------------------------------------------------------------------------------------------------------------- -contains - !> @ingroup Lib_Base64PrivateProcedure - !> @{ - !> @brief Subroutine for packing different kinds of data into single I1P array. - pure subroutine pack_data_R8_R4(a1,a2,packed) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - real(R8P), intent(IN):: a1(1:) !< Firs data stream. - real(R4P), intent(IN):: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. - integer(I4P):: np !< Size of temporary packed data. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) - np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) - if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] - deallocate(p1,p2) - return - !--------------------------------------------------------------------------------------------------------------------------------- - endsubroutine pack_data_R8_R4 - - !> @brief Subroutine for packing different kinds of data into single I1P array. - pure subroutine pack_data_R8_I8(a1,a2,packed) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - real(R8P), intent(IN):: a1(1:) !< First data stream. - integer(I8P), intent(IN):: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. - integer(I4P):: np !< Size of temporary packed data. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) - np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) - if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] - deallocate(p1,p2) - return - !--------------------------------------------------------------------------------------------------------------------------------- - endsubroutine pack_data_R8_I8 - - !> @brief Subroutine for packing different kinds of data into single I1P array. - pure subroutine pack_data_R8_I4(a1,a2,packed) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - real(R8P), intent(IN):: a1(1:) !< First data stream. - integer(I4P), intent(IN):: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. - integer(I4P):: np !< Size of temporary packed data. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) - np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) - if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] - deallocate(p1,p2) - return - !--------------------------------------------------------------------------------------------------------------------------------- - endsubroutine pack_data_R8_I4 - - !> @brief Subroutine for packing different kinds of data into single I1P array. - pure subroutine pack_data_R8_I2(a1,a2,packed) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - real(R8P), intent(IN):: a1(1:) !< First data stream. - integer(I2P), intent(IN):: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. - integer(I4P):: np !< Size of temporary packed data. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) - np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) - if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] - deallocate(p1,p2) - return - !--------------------------------------------------------------------------------------------------------------------------------- - endsubroutine pack_data_R8_I2 - - !> @brief Subroutine for packing different kinds of data into single I1P array. - pure subroutine pack_data_R8_I1(a1,a2,packed) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - real(R8P), intent(IN):: a1(1:) !< First data stream. - integer(I1P), intent(IN):: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. - integer(I4P):: np !< Size of temporary packed data. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) - np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) - if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] - deallocate(p1,p2) - return - !--------------------------------------------------------------------------------------------------------------------------------- - endsubroutine pack_data_R8_I1 - - !> @brief Subroutine for packing different kinds of data into single I1P array. - pure subroutine pack_data_R4_R8(a1,a2,packed) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - real(R4P), intent(IN):: a1(1:) !< Firs data stream. - real(R8P), intent(IN):: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. - integer(I4P):: np !< Size of temporary packed data. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) - np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) - if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] - deallocate(p1,p2) - return - !--------------------------------------------------------------------------------------------------------------------------------- - endsubroutine pack_data_R4_R8 - - !> @brief Subroutine for packing different kinds of data into single I1P array. - pure subroutine pack_data_R4_I8(a1,a2,packed) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - real(R4P), intent(IN):: a1(1:) !< First data stream. - integer(I8P), intent(IN):: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. - integer(I4P):: np !< Size of temporary packed data. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) - np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) - if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] - deallocate(p1,p2) - return - !--------------------------------------------------------------------------------------------------------------------------------- - endsubroutine pack_data_R4_I8 - - !> @brief Subroutine for packing different kinds of data into single I1P array. - pure subroutine pack_data_R4_I4(a1,a2,packed) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - real(R4P), intent(IN):: a1(1:) !< First data stream. - integer(I4P), intent(IN):: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. - integer(I4P):: np !< Size of temporary packed data. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) - np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) - if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] - deallocate(p1,p2) - return - !--------------------------------------------------------------------------------------------------------------------------------- - endsubroutine pack_data_R4_I4 - - !> @brief Subroutine for packing different kinds of data into single I1P array. - pure subroutine pack_data_R4_I2(a1,a2,packed) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - real(R4P), intent(IN):: a1(1:) !< First data stream. - integer(I2P), intent(IN):: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. - integer(I4P):: np !< Size of temporary packed data. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) - np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) - if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] - deallocate(p1,p2) - return - !--------------------------------------------------------------------------------------------------------------------------------- - endsubroutine pack_data_R4_I2 - - !> @brief Subroutine for packing different kinds of data into single I1P array. - pure subroutine pack_data_R4_I1(a1,a2,packed) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - real(R4P), intent(IN):: a1(1:) !< First data stream. - integer(I1P), intent(IN):: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. - integer(I4P):: np !< Size of temporary packed data. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) - np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) - if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] - deallocate(p1,p2) - return - !--------------------------------------------------------------------------------------------------------------------------------- - endsubroutine pack_data_R4_I1 - - !> @brief Subroutine for packing different kinds of data into single I1P array. - pure subroutine pack_data_I8_R8(a1,a2,packed) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I8P), intent(IN):: a1(1:) !< First data stream. - real(R8P), intent(IN):: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. - integer(I4P):: np !< Size of temporary packed data. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) - np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) - if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] - deallocate(p1,p2) - return - !--------------------------------------------------------------------------------------------------------------------------------- - endsubroutine pack_data_I8_R8 - - !> @brief Subroutine for packing different kinds of data into single I1P array. - pure subroutine pack_data_I8_R4(a1,a2,packed) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I8P), intent(IN):: a1(1:) !< First data stream. - real(R4P), intent(IN):: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. - integer(I4P):: np !< Size of temporary packed data. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) - np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) - if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] - deallocate(p1,p2) - return - !--------------------------------------------------------------------------------------------------------------------------------- - endsubroutine pack_data_I8_R4 - - !> @brief Subroutine for packing different kinds of data into single I1P array. - pure subroutine pack_data_I8_I4(a1,a2,packed) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I8P), intent(IN):: a1(1:) !< First data stream. - integer(I4P), intent(IN):: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. - integer(I4P):: np !< Size of temporary packed data. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) - np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) - if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] - deallocate(p1,p2) - return - !--------------------------------------------------------------------------------------------------------------------------------- - endsubroutine pack_data_I8_I4 - - !> @brief Subroutine for packing different kinds of data into single I1P array. - pure subroutine pack_data_I8_I2(a1,a2,packed) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I8P), intent(IN):: a1(1:) !< First data stream. - integer(I2P), intent(IN):: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. - integer(I4P):: np !< Size of temporary packed data. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) - np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) - if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] - deallocate(p1,p2) - return - !--------------------------------------------------------------------------------------------------------------------------------- - endsubroutine pack_data_I8_I2 - - !> @brief Subroutine for packing different kinds of data into single I1P array. - pure subroutine pack_data_I8_I1(a1,a2,packed) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I8P), intent(IN):: a1(1:) !< First data stream. - integer(I1P), intent(IN):: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. - integer(I4P):: np !< Size of temporary packed data. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) - np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) - if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] - deallocate(p1,p2) - return - !--------------------------------------------------------------------------------------------------------------------------------- - endsubroutine pack_data_I8_I1 - - !> @brief Subroutine for packing different kinds of data into single I1P array. - pure subroutine pack_data_I4_R8(a1,a2,packed) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: a1(1:) !< First data stream. - real(R8P), intent(IN):: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. - integer(I4P):: np !< Size of temporary packed data. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) - np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) - if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] - deallocate(p1,p2) - return - !--------------------------------------------------------------------------------------------------------------------------------- - endsubroutine pack_data_I4_R8 - - !> @brief Subroutine for packing different kinds of data into single I1P array. - pure subroutine pack_data_I4_R4(a1,a2,packed) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: a1(1:) !< First data stream. - real(R4P), intent(IN):: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. - integer(I4P):: np !< Size of temporary packed data. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) - np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) - if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] - deallocate(p1,p2) - return - !--------------------------------------------------------------------------------------------------------------------------------- - endsubroutine pack_data_I4_R4 - - !> @brief Subroutine for packing different kinds of data into single I1P array. - pure subroutine pack_data_I4_I8(a1,a2,packed) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: a1(1:) !< First data stream. - integer(I8P), intent(IN):: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. - integer(I4P):: np !< Size of temporary packed data. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) - np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) - if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] - deallocate(p1,p2) - return - !--------------------------------------------------------------------------------------------------------------------------------- - endsubroutine pack_data_I4_I8 - - !> @brief Subroutine for packing different kinds of data into single I1P array. - pure subroutine pack_data_I4_I2(a1,a2,packed) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: a1(1:) !< First data stream. - integer(I2P), intent(IN):: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. - integer(I4P):: np !< Size of temporary packed data. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) - np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) - if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] - deallocate(p1,p2) - return - !--------------------------------------------------------------------------------------------------------------------------------- - endsubroutine pack_data_I4_I2 - - !> @brief Subroutine for packing different kinds of data into single I1P array. - pure subroutine pack_data_I4_I1(a1,a2,packed) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: a1(1:) !< First data stream. - integer(I1P), intent(IN):: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. - integer(I4P):: np !< Size of temporary packed data. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) - np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) - if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] - deallocate(p1,p2) - return - !--------------------------------------------------------------------------------------------------------------------------------- - endsubroutine pack_data_I4_I1 - - !> @brief Subroutine for packing different kinds of data into single I1P array. - pure subroutine pack_data_I2_R8(a1,a2,packed) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I2P), intent(IN):: a1(1:) !< First data stream. - real(R8P), intent(IN):: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. - integer(I4P):: np !< Size of temporary packed data. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) - np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) - if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] - deallocate(p1,p2) - return - !--------------------------------------------------------------------------------------------------------------------------------- - endsubroutine pack_data_I2_R8 - - !> @brief Subroutine for packing different kinds of data into single I1P array. - pure subroutine pack_data_I2_R4(a1,a2,packed) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I2P), intent(IN):: a1(1:) !< First data stream. - real(R4P), intent(IN):: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. - integer(I4P):: np !< Size of temporary packed data. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) - np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) - if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] - deallocate(p1,p2) - return - !--------------------------------------------------------------------------------------------------------------------------------- - endsubroutine pack_data_I2_R4 - - !> @brief Subroutine for packing different kinds of data into single I1P array. - pure subroutine pack_data_I2_I8(a1,a2,packed) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I2P), intent(IN):: a1(1:) !< First data stream. - integer(I8P), intent(IN):: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. - integer(I4P):: np !< Size of temporary packed data. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) - np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) - if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] - deallocate(p1,p2) - return - !--------------------------------------------------------------------------------------------------------------------------------- - endsubroutine pack_data_I2_I8 - - !> @brief Subroutine for packing different kinds of data into single I1P array. - pure subroutine pack_data_I2_I4(a1,a2,packed) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I2P), intent(IN):: a1(1:) !< First data stream. - integer(I4P), intent(IN):: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. - integer(I4P):: np !< Size of temporary packed data. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) - np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) - if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] - deallocate(p1,p2) - return - !--------------------------------------------------------------------------------------------------------------------------------- - endsubroutine pack_data_I2_I4 - - !> @brief Subroutine for packing different kinds of data into single I1P array. - pure subroutine pack_data_I2_I1(a1,a2,packed) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I2P), intent(IN):: a1(1:) !< First data stream. - integer(I1P), intent(IN):: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. - integer(I4P):: np !< Size of temporary packed data. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) - np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) - if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] - deallocate(p1,p2) - return - !--------------------------------------------------------------------------------------------------------------------------------- - endsubroutine pack_data_I2_I1 - - !> @brief Subroutine for packing different kinds of data into single I1P array. - pure subroutine pack_data_I1_R8(a1,a2,packed) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I1P), intent(IN):: a1(1:) !< First data stream. - real(R8P), intent(IN):: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. - integer(I4P):: np !< Size of temporary packed data. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) - np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) - if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] - deallocate(p1,p2) - return - !--------------------------------------------------------------------------------------------------------------------------------- - endsubroutine pack_data_I1_R8 - - !> @brief Subroutine for packing different kinds of data into single I1P array. - pure subroutine pack_data_I1_R4(a1,a2,packed) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I1P), intent(IN):: a1(1:) !< First data stream. - real(R4P), intent(IN):: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. - integer(I4P):: np !< Size of temporary packed data. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) - np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) - if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] - deallocate(p1,p2) - return - !--------------------------------------------------------------------------------------------------------------------------------- - endsubroutine pack_data_I1_R4 - - !> @brief Subroutine for packing different kinds of data into single I1P array. - pure subroutine pack_data_I1_I8(a1,a2,packed) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I1P), intent(IN):: a1(1:) !< First data stream. - integer(I8P), intent(IN):: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. - integer(I4P):: np !< Size of temporary packed data. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) - np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) - if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] - deallocate(p1,p2) - return - !--------------------------------------------------------------------------------------------------------------------------------- - endsubroutine pack_data_I1_I8 - - !> @brief Subroutine for packing different kinds of data into single I1P array. - pure subroutine pack_data_I1_I4(a1,a2,packed) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I1P), intent(IN):: a1(1:) !< First data stream. - integer(I4P), intent(IN):: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. - integer(I4P):: np !< Size of temporary packed data. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) - np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) - if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] - deallocate(p1,p2) - return - !--------------------------------------------------------------------------------------------------------------------------------- - endsubroutine pack_data_I1_I4 - - !> @brief Subroutine for packing different kinds of data into single I1P array. - pure subroutine pack_data_I1_I2(a1,a2,packed) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I1P), intent(IN):: a1(1:) !< First data stream. - integer(I2P), intent(IN):: a2(1:) !< Second data stream. - integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. - integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. - integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. - integer(I4P):: np !< Size of temporary packed data. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) - np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) - if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] - deallocate(p1,p2) - return - !--------------------------------------------------------------------------------------------------------------------------------- - endsubroutine pack_data_I1_I2 - - !> @brief Subroutine for encoding bits (must be multiple of 24 bits) into base64 charcaters code (of length multiple of 4). - !> @note The bits stream are encoded in chunks of 24 bits as the following example (in little endian order): - !> @code - !> +--first octet--+-second octet--+--third octet--+ - !> |7 6 5 4 3 2 1 0|7 6 5 4 3 2 1 0|7 6 5 4 3 2 1 0| - !> +-----------+---+-------+-------+---+-----------+ - !> |5 4 3 2 1 0|5 4 3 2 1 0|5 4 3 2 1 0|5 4 3 2 1 0| - !> +--1.index--+--2.index--+--3.index--+--4.index--+ - !> @endcode - !> The 4 indexes are stored into 4 elements 8 bits array, thus 2 bits of each array element are not used. - pure subroutine encode_bits(bits,padd,code) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I1P), intent(IN):: bits(1:) !< Bits to be encoded. - integer(I4P), intent(IN):: padd !< Number of padding characters ('='). - character(1), intent(OUT):: code(1:) !< Characters code. - integer(I1P):: sixb(1:4) !< 6 bits slices (stored into 8 bits integer) of 24 bits input. - integer(I8P):: c,e !< Counters. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - c = 1_I8P - do e=1_I8P,size(bits,dim=1,kind=I8P),3_I8P ! loop over array elements: 3 bytes (24 bits) scanning - sixb = 0_I1P - call mvbits(bits(e ),2,6,sixb(1),0) - call mvbits(bits(e ),0,2,sixb(2),4) ; call mvbits(bits(e+1),4,4,sixb(2),0) - call mvbits(bits(e+1),0,4,sixb(3),2) ; call mvbits(bits(e+2),6,2,sixb(3),0) - call mvbits(bits(e+2),0,6,sixb(4),0) - sixb = sixb + 1_I1P - code(c :c )(1:1) = base64(sixb(1):sixb(1)) - code(c+1:c+1)(1:1) = base64(sixb(2):sixb(2)) - code(c+2:c+2)(1:1) = base64(sixb(3):sixb(3)) - code(c+3:c+3)(1:1) = base64(sixb(4):sixb(4)) - c = c + 4_I8P - enddo - if (padd>0) code(size(code,dim=1)-padd+1:)(1:1)='=' - return - !--------------------------------------------------------------------------------------------------------------------------------- - endsubroutine encode_bits - - !> @brief Subroutine for encoding array numbers to base64 (R8P). - pure subroutine b64_encode_R8_a(nB,n,code) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: nB !< Number of bytes of single element of n. - real(R8P), intent(IN):: n(1:) !< Array of numbers to be encoded. - character(1), allocatable, intent(OUT):: code(:) !< Encoded array. - integer(I1P):: nI1P(1:((size(n,dim=1)*nB+2)/3)*3) !< One byte integer array containing n. - integer(I4P):: padd !< Number of padding characters ('='). - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - if (allocated(code)) deallocate(code) ; allocate(code(1:((size(n,dim=1)*nB+2)/3)*4)) ! allocating code chars - nI1P = transfer(n,nI1P) ! casting n to integer array of 1 byte elem - padd = mod((size(n,dim=1)*nB),3_I4P) ; if (padd>0_I4P) padd = 3_I4P - padd ! computing the number of padding characters - call encode_bits(bits=nI1P,padd=padd,code=code) ! encoding bits - return - !--------------------------------------------------------------------------------------------------------------------------------- - endsubroutine b64_encode_R8_a - - !> @brief Subroutine for encoding array numbers to base64 (R4P). - pure subroutine b64_encode_R4_a(nB,n,code) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: nB !< Number of bytes of single element of n. - real(R4P), intent(IN):: n(1:) !< Array of numbers to be encoded. - character(1), allocatable, intent(OUT):: code(:) !< Encoded array. - integer(I1P):: nI1P(1:((size(n,dim=1)*nB+2)/3)*3) !< One byte integer array containing n. - integer(I4P):: padd !< Number of padding characters ('='). - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - if (allocated(code)) deallocate(code) ; allocate(code(1:((size(n,dim=1)*nB+2)/3)*4)) ! allocating code chars - nI1P = transfer(n,nI1P) ! casting n to integer array of 1 byte elem - padd = mod((size(n,dim=1)*nB),3_I4P) ; if (padd>0_I4P) padd = 3_I4P - padd ! computing the number of padding characters - call encode_bits(bits=nI1P,padd=padd,code=code) ! encoding bits - return - !--------------------------------------------------------------------------------------------------------------------------------- - endsubroutine b64_encode_R4_a - - !> @brief Subroutine for encoding array numbers to base64 (I8P). - pure subroutine b64_encode_I8_a(nB,n,code) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: nB !< Number of bytes of single element of n. - integer(I8P), intent(IN):: n(1:) !< Array of numbers to be encoded. - character(1), allocatable, intent(OUT):: code(:) !< Encoded array. - integer(I1P):: nI1P(1:((size(n,dim=1)*nB+2)/3)*3) !< One byte integer array containing n. - integer(I4P):: padd !< Number of padding characters ('='). - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - if (allocated(code)) deallocate(code) ; allocate(code(1:((size(n,dim=1)*nB+2)/3)*4)) ! allocating code chars - nI1P = transfer(n,nI1P) ! casting n to integer array of 1 byte elem - padd = mod((size(n,dim=1)*nB),3_I4P) ; if (padd>0_I4P) padd = 3_I4P - padd ! computing the number of padding characters - call encode_bits(bits=nI1P,padd=padd,code=code) ! encoding bits - return - !--------------------------------------------------------------------------------------------------------------------------------- - endsubroutine b64_encode_I8_a - - !> @brief Subroutine for encoding array numbers to base64 (I4P). - pure subroutine b64_encode_I4_a(nB,n,code) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: nB !< Number of bytes of single element of n. - integer(I4P), intent(IN):: n(1:) !< Array of numbers to be encoded. - character(1), allocatable, intent(OUT):: code(:) !< Encoded array. - integer(I1P):: nI1P(1:((size(n,dim=1)*nB+2)/3)*3) !< One byte integer array containing n. - integer(I4P):: padd !< Number of padding characters ('='). - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - if (allocated(code)) deallocate(code) ; allocate(code(1:((size(n,dim=1)*nB+2)/3)*4)) ! allocating code chars - nI1P = transfer(n,nI1P) ! casting n to integer array of 1 byte elem - padd = mod((size(n,dim=1)*nB),3_I4P) ; if (padd>0_I4P) padd = 3_I4P - padd ! computing the number of padding characters - call encode_bits(bits=nI1P,padd=padd,code=code) ! encoding bits - return - !--------------------------------------------------------------------------------------------------------------------------------- - endsubroutine b64_encode_I4_a - - !> @brief Subroutine for encoding array numbers to base64 (I2P). - pure subroutine b64_encode_I2_a(nB,n,code) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: nB !< Number of bytes of single element of n. - integer(I2P), intent(IN):: n(1:) !< Array of numbers to be encoded. - character(1), allocatable, intent(OUT):: code(:) !< Encoded array. - integer(I1P):: nI1P(1:((size(n,dim=1)*nB+2)/3)*3) !< One byte integer array containing n. - integer(I4P):: padd !< Number of padding characters ('='). - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - if (allocated(code)) deallocate(code) ; allocate(code(1:((size(n,dim=1)*nB+2)/3)*4)) ! allocating code chars - nI1P = transfer(n,nI1P) ! casting n to integer array of 1 byte elem - padd = mod((size(n,dim=1)*nB),3_I4P) ; if (padd>0_I4P) padd = 3_I4P - padd ! computing the number of padding characters - call encode_bits(bits=nI1P,padd=padd,code=code) ! encoding bits - return - !--------------------------------------------------------------------------------------------------------------------------------- - endsubroutine b64_encode_I2_a - - !> @brief Subroutine for encoding array numbers to base64 (I1P). - pure subroutine b64_encode_I1_a(nB,n,code) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: nB !< Number of bytes of single element of n. - integer(I1P), intent(IN):: n(1:) !< Array of numbers to be encoded. - character(1), allocatable, intent(OUT):: code(:) !< Encoded array. - integer(I1P):: nI1P(1:((size(n,dim=1)*nB+2)/3)*3) !< One byte integer array containing n. - integer(I4P):: padd !< Number of padding characters ('='). - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - if (allocated(code)) deallocate(code) ; allocate(code(1:((size(n,dim=1)*nB+2)/3)*4)) ! allocating code chars - nI1P = transfer(n,nI1P) ! casting n to integer array of 1 byte elem - padd = mod((size(n,dim=1)*nB),3_I4P) ; if (padd>0_I4P) padd = 3_I4P - padd ! computing the number of padding characters - call encode_bits(bits=nI1P,padd=padd,code=code) ! encoding bits - return - !--------------------------------------------------------------------------------------------------------------------------------- - endsubroutine b64_encode_I1_a - - !!> @brief Subroutine for decoding array numbers from base64 (R8P). - !pure subroutine b64_decode_R8_a(code,n) - !!-------------------------------------------------------------------------------------------------------------------------------- - !implicit none - !real(R8P), intent(OUT):: n(1:) !< Number to be decoded. - !character(ncR8P*size(n,dim=1)), intent(IN):: code !< Encoded number. - !integer(I4P):: c,d !< Counters. - !!-------------------------------------------------------------------------------------------------------------------------------- - - !!-------------------------------------------------------------------------------------------------------------------------------- - !d = 1_I4P - !do c=1,len(code),ncR8P - ! call b64_decode_R8_s(code=code(c:c+ncR8P-1),n=n(d)) - ! d = d + 1_I4P - !enddo - !return - !!-------------------------------------------------------------------------------------------------------------------------------- - !endsubroutine b64_decode_R8_a - !> @} -endmodule Lib_Base64 diff --git a/lib/Lib_VTK_IO.f90 b/lib/Lib_VTK_IO.f90 deleted file mode 100644 index 62a838189..000000000 --- a/lib/Lib_VTK_IO.f90 +++ /dev/null @@ -1,6070 +0,0 @@ -!> @addtogroup PrivateVarPar Private Variables and Parameters -!> List of private variables and parameters. -!> @addtogroup Interface Interfaces -!> List of explicitly defined interface. -!> @addtogroup Library Modules Libraries -!> List of modules containing libraries of procedures. -!> @addtogroup PublicProcedure Public Procedures -!> List of public procedures. -!> @addtogroup PrivateProcedure Private Procedures -!> List of private procedures. - -!> @ingroup Library -!> @{ -!> @defgroup Lib_VTK_IOLibrary Lib_VTK_IO -!> @} - -!> @ingroup Interface -!> @{ -!> @defgroup Lib_VTK_IOInterface Lib_VTK_IO -!> @} - -!> @ingroup PrivateVarPar -!> @{ -!> @defgroup Lib_VTK_IOPrivateVarPar Lib_VTK_IO -!> @} - -!> @ingroup PublicProcedure -!> @{ -!> @defgroup Lib_VTK_IOPublicProcedure Lib_VTK_IO -!> @} - -!> @ingroup PrivateProcedure -!> @{ -!> @defgroup Lib_VTK_IOPrivateProcedure Lib_VTK_IO -!> @} - -!> @brief This is a library of functions for Input and Output pure Fortran data in VTK format. -!> @details It is useful for Paraview visualization tool. Even though there are many wrappers/porting of the VTK source -!> code (C++ code), there is not a Fortran one. This library is not a porting or a wrapper of the VTK code, -!> but it only an exporter/importer of the VTK data format written in pure Fortran language (standard Fortran 2003 or -!> higher) that can be used by Fortran coders (yes, there are still a lot of these brave coders...) without mixing Fortran -!> with C++ language. Fortran is still the best language for high performance computing for scientific purpose, like CFD -!> computing. It is necessary a tool to deal with VTK standard directly by Fortran code. The library was made to fill -!> this empty: it is a simple Fortran module able to export native Fortran data into VTK data format and to import VTK -!> data into a Fortran code, both in ascii and binary file format. -!> -!> The library provides an automatic way to deal with VTK data format: all the formatting processes is nested into the -!> library and users communicate with it by a simple API passing only native Fortran data (Fortran scalars and arrays). -!> -!> The library is still in developing and testing, this is first usable release, but there are not all the features of -!> the stable release (the importer is totally absent and the exporter is not complete). Surely there are a lot of bugs -!> and the programming style is not the best, but the exporters are far-complete. -!> -!> The supported VTK features are: -!> - Exporters: -!> - Legacy standard: -!> - Structured Points; -!> - Structured Grid; -!> - Unstructured Grid; -!> - Polydata (\b missing); -!> - Rectilinear Grid; -!> - Field (\b missing); -!> - XML standard: -!> - serial dataset: -!> - Image Data (\b missing); -!> - Polydata (\b missing); -!> - Rectilinear Grid; -!> - Structured Grid; -!> - Unstructured Grid; -!> - parallel (partitioned) dataset: -!> - Image Data (\b missing); -!> - Polydata (\b missing); -!> - Rectilinear Grid; -!> - Structured Grid; -!> - Unstructured Grid; -!> - composite dataset: -!> - vtkMultiBlockDataSet; -!> - Importers are \b missing. -!> -!> @libvtk can handle multiple concurrent files and it is \b thread/processor-safe (meaning that can be safely used into -!> parallel frameworks as OpenMP or MPI, see \ref SpeedUP "Parallel Frameworks Benchmarks"). -!> -!> The library is an open source project, it is distributed under the GPL v3. Anyone is interest to use, to develop or -!> to contribute to @libvtk is welcome. -!> -!> It can be found at: https://github.com/szaghi/Lib_VTK_IO -!> -!> @par VTK_Standard -!> VTK, Visualization Toolkit, is an open source software that provides a powerful framework for the computer graphic, for -!> the images processing and for 3D rendering. It is widely used in the world and so it has a very large community of users, -!> besides the Kitware (The Kitware homepage can be found here: http://public.kitware.com) company provides professional -!> support. The toolkit is written in C++ and a lot of porting/wrappers for Tcl/Tk, Java and Python are provided, unlucky -!> there aren't wrappers for Fortran. -!> -!> Because of its good features the VTK toolkit has been used to develop a large set of open source programs. For my work -!> the most important family of programs is the scientific visualization programs. A lot of high-quality scientific -!> visualization tool are available on the web but for me the best is ParaView: I think that it is one of the best -!> scientific visualization program in the world and it is open source! Paraview is based on VTK. -!> @par Paraview -!> ParaView (The ParaView homepage can be found here: http://www.paraview.org) is an open source software voted to scientific -!> visualization and able to use the power of parallel architectures. It has an architecture client-server in order to make -!> easy the remote visualization of very large set of data. Because it is based on VTK it inherits all VTK features. ParaView -!> is very useful for Computational Fluid Dynamics visualizations because it provides powerful post-processing tools, it -!> provides a very large set of importers for the most used format like Plot3D and HDF (the list is very large). It is easy to -!> extend ParaView because it supports all the scripting language supported by VTK. -!> @note All the @libvtk functions are I4P integer functions: the returned integer output is 0 if the function calling has -!> been completed right while it is >0 if some errors occur (the error handling is only at its embryonic phase). Therefore the -!> functions calling must be done in the following way: \n -!> @code -!> ... -!> integer(I4P):: E_IO -!> ... -!> E_IO = VTK_INI(.... -!> ... @endcode -!> @libvtk programming style is based on two main principles: portable kind-precision of reals and integers -!> variables and dynamic dispatching. Using dynamic dispatching @libvtk has a simple API. The user calls -!> a generic procedure (VTK_INI, VTK_GEO,...) and the library, depending on the type and number of the inputs passed, calls the -!> correct internal function (i.e. VTK_GEO for R8P real type if the input passed is R8P real type). By this interface only few -!> functions are used without the necessity of calling a different function for each different input type. -!> Dynamic dispatching is based on the internal kind-precision/rank selecting convention: Fortran 90/95 standard has introduced some -!> useful functions to achieve the portability of reals and integers precision and @libvtk uses these functions to define portable -!> kind-precision; to this aim @libvtk uses IR_Precision module. -!> @author Stefano Zaghi -!> @version 1.1 -!> @date 2013-05-23 -!> @par News -!> - Added packed API and 3D(or higher) arrays for VTK_VAR_XML function: this avoids the necessity of explicit reshape of -!> multi-dimensional arrays containing saved variables in VAR callings; the following inputs are now available: -!> - scalar input: -!> - input is 1D-rank array: var[1:NC_NN]; -!> - input is 3D-rank array: var[nx1:nx2,ny1:ny2,nz1:nz2]; -!> - vectorial inputs: -!> - inputs are 1D-rank arrays: varX[1:NC_NN],varY[1:NC_NN],varZ[1:NC_NN]; -!> - inputs are 3D-rank arrays: varX[nx1:nx2,ny1:ny2,nz1:nz2],varY[nx1:nx2,ny1:ny2,nz1:nz2],varX[nx1:nx2,ny1:ny2,nz1:nz2]; -!> - 3D(or higher) vectorial inputs: -!> - input is 1D-rank (packed API): var[1:N_COL,1:NC_NN]; -!> - input is 3D-rank (packed API): var[1:N_COL,nx1:nx2,ny1:ny2,nz1:nz2]. -!> - Added packed API and 3D arrays for VTK_GEO and VTK_GEO_XML function: this avoids the necessity of explicit reshape of -!> multi-dimensional arrays containing X, Y and Z coordinates in GEO callings; the following inputs are now available: -!> - StructuredGrid (NN is the number of grid points, n\#1-n\#2, \#x,y,z are the domain extents): -!> - 1D arrays of size NN: X[1:NN],Y[1:NN],Z[1:NN]; -!> - 3D arrays of size NN: X[nx1:nx2,ny1:ny2,nz1:nz2],Y[nx1:nx2,ny1:ny2,nz1:nz2],Z[nx1:nx2,ny1:ny2,nz1:nz2]; -!> - 1D array of size 3*NN (packed API): XYZ[1:3,1:NN]; -!> - 3D array of size 3*NN (packed API): XYZ[1:3,nx1:nx2,ny1:ny2,nz1:nz2]. -!> - UnStructuredGrid (NN is the number of grid points): -!> - 1D arrays of size NN: X[1:NN],Y[1:NN],Z[1:NN]; -!> - 1D array of size 3*NN (packed API): XYZ[1:3,1:NN]. -!> - Added base64 encoding format: the output format specifier of VTK_INI_XML has been changed: -!> - output_format = 'ascii' means \b ascii data, the same as the previous version; -!> - output_format = 'binary' means \b base64 encoded data, different from the previous version where it meant appended -!> raw-binary data; base64 encoding was missing in the previous version; -!> - output_format = 'raw' means \b appended \b raw-binary data, as 'binary' of the previous version; -!> - Added support for OpenMP multi-threads framework; -!> - Correct bug affecting binary output; -!> - implement concurrent multiple files IO capability; -!> - implement FieldData tag for XML files, useful for tagging dataset with global auxiliary data, e.g. time, time step, ecc; -!> - implement Parallel (Partitioned) XML files support (.pvtu,.pvts,.pvtr); -!> - implement Driver testing program for providing practical examples of @libvtk usage; -!> - added support for parallel framework, namely OpenMP (thread-safe) and MPI (process-safe). -!> @copyright GNU Public License version 3. -!> @note The supported compilers are GNU gfortran 4.7.x (or higher) and Intel Fortran 12.x (or higher). @libvtk needs a modern -!> compiler providing support for some Fortran standard 2003 features. -!> @todo \b CompleteExporter: Complete the exporters -!> @todo \b CompleteImporter: Complete the importers -!> @todo \b DocExamples: Complete the documentation of examples -!> @todo \b g95_test: Test g95 compiler -!> @bug XML-Efficiency: \n This is not properly a bug. There is an inefficiency when saving XML raw (binary) file. To write -!> raw data into XML file @libvtk uses a temporary scratch file to save binary data while saving all -!> formatting data to the final XML file. Only when all XML formatting data have been written the -!> scratch file is rewind and the binary data is saved in the final tag of XML file as \b raw -!> \b appended data. This approach is not efficient. -!> @ingroup Lib_VTK_IOLibrary -module Lib_VTK_IO -!----------------------------------------------------------------------------------------------------------------------------------- -USE IR_Precision ! Integers and reals precision definition. -USE Lib_Base64 ! Base64 encoding/decoding procedures. -USE, intrinsic:: ISO_FORTRAN_ENV, only: stdout=>OUTPUT_UNIT, stderr=>ERROR_UNIT ! Standard output/error logical units. -!----------------------------------------------------------------------------------------------------------------------------------- - -!----------------------------------------------------------------------------------------------------------------------------------- -implicit none -private -save -! functions for VTK XML -public:: VTK_INI_XML -public:: VTK_FLD_XML -public:: VTK_GEO_XML -public:: VTK_CON_XML -public:: VTK_DAT_XML -public:: VTK_VAR_XML -public:: VTK_END_XML -! functions for VTM XML -public:: VTM_INI_XML -public:: VTM_BLK_XML -public:: VTM_WRF_XML -public:: VTM_END_XML -! functions for PVTK XML -public:: PVTK_INI_XML -public:: PVTK_GEO_XML -public:: PVTK_DAT_XML -public:: PVTK_VAR_XML -public:: PVTK_END_XML -! functions for VTK LEGACY -public:: VTK_INI -public:: VTK_GEO -public:: VTK_CON -public:: VTK_DAT -public:: VTK_VAR -public:: VTK_END -!----------------------------------------------------------------------------------------------------------------------------------- - -!----------------------------------------------------------------------------------------------------------------------------------- -!> @brief Function for saving field data (global auxiliary data, eg time, step number, dataset name, etc). -!> VTK_FLD_XML is an interface to 7 different functions, there are 2 functions for real field data, 4 functions for integer one -!> and one function for open and close field data tag. -!> @remark VTK_FLD_XML must be called after VTK_INI_XML and befor VTK_GEO_XML. It must always called three times at least: 1) for -!> opening the FieldData tag, 2) for saving at least one FieldData entry and 3) for closing the FieldData tag. -!> Examples of usage are: \n -!> \b saving the time and step cicle counter of current dataset: \n -!> @code ... -!> real(R8P):: time -!> integer(I4P):: step -!> ... -!> E_IO=VTK_FLD_XML(fld_action='open') -!> E_IO=VTK_FLD_XML(fld=time,fname='TIME') -!> E_IO=VTK_FLD_XML(fld=step,fname='CYCLE') -!> E_IO=VTK_FLD_XML(fld_action='close') -!> ... @endcode -!> @ingroup Lib_VTK_IOInterface -interface VTK_FLD_XML - module procedure VTK_FLD_XML_OC, & ! open/close field data tag - VTK_FLD_XML_R8, & ! real(R8P) scalar - VTK_FLD_XML_R4, & ! real(R4P) scalar - VTK_FLD_XML_I8, & ! integer(I8P) scalar - VTK_FLD_XML_I4, & ! integer(I4P) scalar - VTK_FLD_XML_I2, & ! integer(I2P) scalar - VTK_FLD_XML_I1 ! integer(I1P) scalar -endinterface -!> @brief Function for saving mesh with different topologies in VTK-XML standard. -!> VTK_GEO_XML is an interface to 15 different functions; there are 2 functions for each of 3 topologies supported and a function -!> for closing XML pieces: one function for mesh coordinates with R8P precision and one for mesh coordinates with R4P precision. -!> @remark 1D/3D-rank arrays and packed API for any kinds \n -!> - For StructuredGrid there are 4 functions for each real kinds: -!> - inputs are 1D-rank arrays: X[1:NN],Y[1:NN],Z[1:NN]; -!> - inputs are 3D-rank arrays: X[nx1:nx2,ny1:ny2,nz1:nz2],Y[nx1:nx2,ny1:ny2,nz1:nz2],Z[nx1:nx2,ny1:ny2,nz1:nz2]; -!> - input is 1D-rank array (packed API): XYZ[1:3,1:NN]; -!> - input is 3D-rank array (packed API): XYZ[1:3,nx1:nx2,ny1:ny2,nz1:nz2]. -!> - For UnStructuredGrid there are 2 functions for each real kinds: -!> - inputs are 1D arrays: X[1:NN],Y[1:NN],Z[1:NN]; -!> - input is 1D array (packed API): XYZ[1:3,1:NN]. -!> -!> @remark VTK_GEO_XML must be called after VTK_INI_XML. It saves the mesh geometry. The inputs that must be passed -!> change depending on the topologies chosen. Not all VTK topologies have been implemented (\em polydata topologies are absent). -!> @note The XML standard is more powerful than legacy. XML file can contain more than 1 mesh with its -!> associated variables. Thus there is the necessity to close each \em pieces that compose the data-set saved in the -!> XML file. The VTK_GEO_XML called in the close piece format is used just to close the -!> current piece before saving another piece or closing the file. \n -!> Examples of usage are: \n -!> \b Structured grid calling: \n -!> @code ... -!> integer(I4P):: nx1,nx2,ny1,ny2,nz1,nz2,NN -!> real(R8P):: X(1:NN),Y(1:NN),Z(1:NN) -!> ... -!> E_IO=VTK_GEO_XML(nx1,nx2,ny1,ny2,nz1,nz2,Nn,X,Y,Z) -!> ... @endcode -!> \b Rectilinear grid calling: \n -!> @code ... -!> integer(I4P):: nx1,nx2,ny1,ny2,nz1,nz2 -!> real(R8P):: X(nx1:nx2),Y(ny1:ny2),Z(nz1:nz2) -!> ... -!> E_IO=VTK_GEO_XML(nx1,nx2,ny1,ny2,nz1,nz2,X,Y,Z) -!> ... @endcode -!> \b Unstructured grid calling: \n -!> @code ... -!> integer(I4P):: Nn,Nc -!> real(R8P):: X(1:Nn),Y(1:Nn),Z(1:Nn) -!> ... -!> E_IO=VTK_GEO_XML(Nn,Nc,X,Y,Z) -!> ... @endcode -!> \b Closing piece calling: 1n -!> @code ... -!> E_IO=VTK_GEO_XML() -!> ... @endcode -!> @ingroup Lib_VTK_IOInterface -interface VTK_GEO_XML - module procedure VTK_GEO_XML_STRG_1DA_R8, VTK_GEO_XML_STRG_3DA_R8, & ! real(R8P) StructuredGrid, 1D/3D Arrays - VTK_GEO_XML_STRG_1DAP_R8,VTK_GEO_XML_STRG_3DAP_R8, & ! real(R8P) StructuredGrid, 1D/3D Arrays packed API - VTK_GEO_XML_STRG_1DA_R4, VTK_GEO_XML_STRG_3DA_R4, & ! real(R4P) StructuredGrid, 1D/3D Arrays - VTK_GEO_XML_STRG_1DAP_R4,VTK_GEO_XML_STRG_3DAP_R4, & ! real(R4P) StructuredGrid, 1D/3D Arrays packed API - VTK_GEO_XML_RECT_R8, & ! real(R8P) RectilinearGrid - VTK_GEO_XML_RECT_R4, & ! real(R4P) RectilinearGrid - VTK_GEO_XML_UNST_R8,VTK_GEO_XML_UNST_PACK_R4, & ! real(R8P) UnstructuredGrid, standard and packed API - VTK_GEO_XML_UNST_R4,VTK_GEO_XML_UNST_PACK_R8, & ! real(R4P) UnstructuredGrid, standard and packed API - VTK_GEO_XML_CLOSEP ! closing tag "Piece" function -endinterface -!> @brief Function for saving data variable(s) in VTK-XML standard. -!> VTK_VAR_XML is an interface to 36 different functions, there are 6 functions for scalar variables, 6 functions for vectorial -!> variables and 6 functions for 3D(or higher) vectorial variables: for all of types the precision can be R8P, R4P, I8P, I4P, I2P -!> and I1P. This function saves the data variables related (cell-centered or node-centered) to geometric mesh. -!> @remark 1D/3D-rank arrays and packed API for any kinds \n -!> The inputs arrays can be passed as 1D-rank or 3D-rank and the vectorial variables can be component-separated (one for each of -!> the 3 components) or packed into one multidimensional array: -!> - scalar input: -!> - input is 1D-rank array: var[1:NC_NN]; -!> - input is 3D-rank array: var[nx1:nx2,ny1:ny2,nz1:nz2]; -!> - vectorial inputs: -!> - inputs are 1D-rank arrays: varX[1:NC_NN],varY[1:NC_NN],varZ[1:NC_NN]; -!> - inputs are 3D-rank arrays: varX[nx1:nx2,ny1:ny2,nz1:nz2],varY[nx1:nx2,ny1:ny2,nz1:nz2],varX[nx1:nx2,ny1:ny2,nz1:nz2]; -!> - 3D(or higher) vectorial inputs: -!> - input is 1D-rank (packed API): var[1:N_COL,1:NC_NN]; -!> - input is 3D-rank (packed API): var[1:N_COL,nx1:nx2,ny1:ny2,nz1:nz2]. -!> -!> @remark Note that the inputs that must be passed change depending on the data variables type. -!> -!> @note Examples of usage are: \n -!> \b Scalar data calling: \n -!> @code ... -!> integer(I4P):: NN -!> real(R8P):: var(1:NN) -!> ... -!> E_IO=VTK_VAR_XML(NN,'Sca',var) -!> ... @endcode -!> \b Vectorial data calling: \n -!> @code ... -!> integer(I4P):: NN -!> real(R8P):: varX(1:NN),varY(1:NN),varZ(1:NN), -!> ... -!> E_IO=VTK_VAR_XML(NN,'Vec',varX,varY,varZ) -!> ... @endcode -!> @ingroup Lib_VTK_IOInterface -interface VTK_VAR_XML - module procedure VTK_VAR_XML_SCAL_1DA_R8,VTK_VAR_XML_SCAL_3DA_R8, & ! real(R8P) scalar 1D/3D array - VTK_VAR_XML_SCAL_1DA_R4,VTK_VAR_XML_SCAL_3DA_R4, & ! real(R4P) scalar 1D/3D array - VTK_VAR_XML_SCAL_1DA_I8,VTK_VAR_XML_SCAL_3DA_I8, & ! integer(I8P) scalar 1D/3D array - VTK_VAR_XML_SCAL_1DA_I4,VTK_VAR_XML_SCAL_3DA_I4, & ! integer(I4P) scalar 1D/3D array - VTK_VAR_XML_SCAL_1DA_I2,VTK_VAR_XML_SCAL_3DA_I2, & ! integer(I2P) scalar 1D/3D array - VTK_VAR_XML_SCAL_1DA_I1,VTK_VAR_XML_SCAL_3DA_I1, & ! integer(I1P) scalar 1D/3D array - VTK_VAR_XML_VECT_1DA_R8,VTK_VAR_XML_VECT_3DA_R8, & ! real(R8P) vectorial 1D/3D arrays - VTK_VAR_XML_VECT_1DA_R4,VTK_VAR_XML_VECT_3DA_R4, & ! real(R4P) vectorial 1D/3D arrays - VTK_VAR_XML_VECT_1DA_I8,VTK_VAR_XML_VECT_3DA_I8, & ! integer(I8P) vectorial 1D/3D arrays - VTK_VAR_XML_VECT_1DA_I4,VTK_VAR_XML_VECT_3DA_I4, & ! integer(I4P) vectorial 1D/3D arrays - VTK_VAR_XML_VECT_1DA_I2,VTK_VAR_XML_VECT_3DA_I2, & ! integer(I2P) vectorial 1D/3D arrays - VTK_VAR_XML_VECT_1DA_I1,VTK_VAR_XML_VECT_3DA_I1, & ! integer(I1P) vectorial 1D/3D arrays - VTK_VAR_XML_LIST_1DA_R8,VTK_VAR_XML_LIST_3DA_R8, & ! real(R8P) list 1D/3D array - VTK_VAR_XML_LIST_1DA_R4,VTK_VAR_XML_LIST_3DA_R4, & ! real(R4P) list 1D/3D array - VTK_VAR_XML_LIST_1DA_I8,VTK_VAR_XML_LIST_3DA_I8, & ! integer(I4P) list 1D/3D array - VTK_VAR_XML_LIST_1DA_I4,VTK_VAR_XML_LIST_3DA_I4, & ! integer(I4P) list 1D/3D array - VTK_VAR_XML_LIST_1DA_I2,VTK_VAR_XML_LIST_3DA_I2, & ! integer(I2P) list 1D/3D array - VTK_VAR_XML_LIST_1DA_I1,VTK_VAR_XML_LIST_3DA_I1 ! integer(I1P) list 1D/3D array -endinterface -!> @brief Function for saving mesh with different topologies in VTK-legacy standard. -!> VTK_GEO is an interface to 16 different functions, there are 2 functions for each of 4 different topologies actually supported: -!> one function for mesh coordinates with R8P precision and one for mesh coordinates with R4P precision. -!> @remark This function must be called after VTK_INI. It saves the mesh geometry. The inputs that must be passed change depending -!> on the topologies chosen. Not all VTK topologies have been implemented (\em polydata topologies are absent). -!> @note Examples of usage are: \n -!> \b Structured points calling: \n -!> @code ... -!> integer(I4P):: Nx,Ny,Nz -!> real(I8P):: X0,Y0,Z0,Dx,Dy,Dz -!> ... -!> E_IO=VTK_GEO(Nx,Ny,Nz,X0,Y0,Z0,Dx,Dy,Dz) -!> ... @endcode -!> \b Structured grid calling: \n -!> @code ... -!> integer(I4P):: Nx,Ny,Nz,Nnodes -!> real(R8P):: X(1:Nnodes),Y(1:Nnodes),Z(1:Nnodes) -!> ... -!> E_IO=VTK_GEO(Nx,Ny,Nz,Nnodes,X,Y,Z) -!> ... @endcode -!> \b Rectilinear grid calling: \n -!> @code ... -!> integer(I4P):: Nx,Ny,Nz -!> real(R8P):: X(1:Nx),Y(1:Ny),Z(1:Nz) -!> ... -!> E_IO=VTK_GEO(Nx,Ny,Nz,X,Y,Z) -!> ... @endcode -!> \b Unstructured grid calling: \n -!> @code ... -!> integer(I4P):: NN -!> real(R4P):: X(1:NN),Y(1:NN),Z(1:NN) -!> ... -!> E_IO=VTK_GEO(NN,X,Y,Z) -!> ... @endcode -!> @ingroup Lib_VTK_IOInterface -interface VTK_GEO - module procedure VTK_GEO_UNST_R8,VTK_GEO_UNST_P_R8, & ! real(R8P) UNSTRUCTURED_GRID, standard and packed API - VTK_GEO_UNST_R4,VTK_GEO_UNST_P_R4, & ! real(R4P) UNSTRUCTURED_GRID, standard and packed API - VTK_GEO_STRP_R8, & ! real(R8P) STRUCTURED_POINTS - VTK_GEO_STRP_R4, & ! real(R4P) STRUCTURED_POINTS - VTK_GEO_STRG_1DA_R8, VTK_GEO_STRG_3DA_R8, & ! real(R8P) STRUCTURED_GRID 1D/3D arrays - VTK_GEO_STRG_1DAP_R8,VTK_GEO_STRG_3DAP_R8, & ! real(R8P) STRUCTURED_GRID 1D/3D arrays, packed API - VTK_GEO_STRG_1DA_R4, VTK_GEO_STRG_3DA_R4, & ! real(R4P) STRUCTURED_GRID 1D/3D arrays - VTK_GEO_STRG_1DAP_R4,VTK_GEO_STRG_3DAP_R4, & ! real(R4P) STRUCTURED_GRID 1D/3D arrays, packed API - VTK_GEO_RECT_R8, & ! real(R8P) RECTILINEAR_GRID - VTK_GEO_RECT_R4 ! real(R4P) RECTILINEAR_GRID -endinterface -!> @brief Function for saving data variable(s) in VTK-legacy standard. -!> VTK_VAR is an interface to 8 different functions, there are 3 functions for scalar variables, 3 functions for vectorial -!> variables and 2 functions texture variables: scalar and vectorial data can be R8P, R4P and I4P data while texture variables can -!> be only R8P or R4P. -!> This function saves the data variables related to geometric mesh. -!> @remark The inputs that must be passed change depending on the data -!> variables type. -!> @note Examples of usage are: \n -!> \b Scalar data calling: \n -!> @code ... -!> integer(I4P):: NN -!> real(R4P):: var(1:NN) -!> ... -!> E_IO=VTK_VAR(NN,'Sca',var) -!> ... @endcode -!> \b Vectorial data calling: \n -!> @code ... -!> integer(I4P):: NN -!> real(R4P):: varX(1:NN),varY(1:NN),varZ(1:NN) -!> ... -!> E_IO=VTK_VAR('vect',NN,'Vec',varX,varY,varZ) -!> ... @endcode -!> @ingroup Lib_VTK_IOInterface -interface VTK_VAR - module procedure VTK_VAR_SCAL_R8, & ! real(R8P) scalar - VTK_VAR_SCAL_R4, & ! real(R4P) scalar - VTK_VAR_SCAL_I4, & ! integer(I4P) scalar - VTK_VAR_VECT_R8, & ! real(R8P) vectorial - VTK_VAR_VECT_R4, & ! real(R4P) vectorial - VTK_VAR_VECT_I4, & ! integer(I4P) vectorial - VTK_VAR_TEXT_R8, & ! real(R8P) vectorial (texture) - VTK_VAR_TEXT_R4 ! real(R4P) vectorial (texture) -endinterface -!----------------------------------------------------------------------------------------------------------------------------------- - -!----------------------------------------------------------------------------------------------------------------------------------- -!> @ingroup Lib_VTK_IOPrivateVarPar -!> @{ -! The library uses a small set of internal variables that are private (not accessible from the outside). The following are -! private variables. -! Parameters: -integer(I4P), parameter:: maxlen = 500 !< Max number of characters of static string. -character(1), parameter:: end_rec = char(10) !< End-character for binary-record finalize. -integer(I4P), parameter:: ascii = 0 !< Ascii-output-format parameter identifier. -integer(I4P), parameter:: binary = 1 !< Base64-output-format parameter identifier. -integer(I4P), parameter:: raw = 2 !< Raw-appended-binary-output-format parameter identifier. -integer(I4P), parameter:: bin_app = 3 !< Base64-appended-output-format parameter identifier. -! VTK file data: -type:: Type_VTK_File - integer(I4P):: f = ascii !< Current output-format (initialized to ascii format). - character(len=maxlen):: topology = '' !< Mesh topology. - integer(I4P):: u = 0_I4P !< Logical unit. - integer(I4P):: ua = 0_I4P !< Logical unit for raw binary XML append file. -#ifdef HUGE - integer(I8P):: N_Byte = 0_I8P !< Number of byte to be written/read. -#else - integer(I4P):: N_Byte = 0_I4P !< Number of byte to be written/read. -#endif - integer(I8P):: ioffset = 0_I8P !< Offset pointer. - integer(I4P):: indent = 0_I4P !< Indent pointer. - contains - procedure:: byte_update ! Procedure for updating N_Byte and ioffset pointer. -endtype Type_VTK_File -type(Type_VTK_File), allocatable:: vtk(:) !< Global data of VTK files [1:Nvtk]. -integer(I4P):: Nvtk = 0_I4P !< Number of (concurrent) VTK files. -integer(I4P):: f = 0_I4P !< Current VTK file index. -! VTM file data: -type:: Type_VTM_File - integer(I4P):: u = 0_I4P !< Logical unit. - integer(I4P):: blk = 0_I4P !< Block index. - integer(I4P):: indent = 0_I4P !< Indent pointer. -endtype Type_VTM_File -type(Type_VTM_File):: vtm !< Global data of VTM files. -!> @} -!----------------------------------------------------------------------------------------------------------------------------------- -contains - ! The library uses five auxiliary procedures that are private thus they cannot be called outside the library. - !> @ingroup Lib_VTK_IOPrivateProcedure - !> @{ - !> @brief Function for getting a free logic unit. The users of @libvtk does not know which is the logical - !> unit: @libvtk uses this information without boring the users. The logical unit used is safe-free: if the program - !> calling @libvtk has others logical units used @libvtk will never use these units, but will choice one that is free. - !>@return Free_Unit - integer function Get_Unit(Free_Unit) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(OUT), optional:: Free_Unit !< Free logic unit. - integer:: n1 !< Counter. - integer:: ios !< Inquiring flag. - logical:: lopen !< Inquiring flag. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - Get_Unit = -1 - n1=1 - do - if ((n1/=stdout).AND.(n1/=stderr)) then - inquire(unit=n1,opened=lopen,iostat=ios) - if (ios==0) then - if (.NOT.lopen) then - Get_Unit = n1 ; if (present(Free_Unit)) Free_Unit = Get_Unit - return - endif - endif - endif - n1=n1+1 - enddo - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction Get_Unit - - !> @brief Function for converting lower case characters of a string to upper case ones. @libvtk uses this function in - !> order to achieve case-insensitive: all character variables used within @libvtk functions are pre-processed by - !> Uppper_Case function before these variables are used. So the users can call @libvtk functions without pay attention of - !> the case of the keywords passed to the functions: calling the function VTK_INI with the string - !> E_IO = VTK_INI('Ascii',...) is equivalent to E_IO = VTK_INI('ASCII',...). - !>@return Upper_Case - elemental function Upper_Case(string) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - character(len=*), intent(IN):: string !< String to be converted. - character(len=len(string)):: Upper_Case !< Converted string. - integer:: n1 !< Characters counter. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - Upper_Case = string - do n1=1,len(string) - select case(ichar(string(n1:n1))) - case(97:122) - Upper_Case(n1:n1)=char(ichar(string(n1:n1))-32) ! Upper case conversion - endselect - enddo - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction Upper_Case - - !> @brief Subroutine for updating N_Byte and ioffset pointer. - elemental subroutine byte_update(vtk,N_Byte) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - class(Type_VTK_File), intent(INOUT):: vtk !< Global data of VTK file. -#ifdef HUGE - integer(I8P), intent(IN):: N_Byte !< Number of bytes saved. -#else - integer(I4P), intent(IN):: N_Byte !< Number of bytes saved. -#endif - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - vtk%N_Byte = N_Byte - if (vtk%f==raw) then -#ifdef HUGE - vtk%ioffset = vtk%ioffset + BYI8P + N_Byte -#else - vtk%ioffset = vtk%ioffset + BYI4P + N_Byte -#endif - else -#ifdef HUGE - vtk%ioffset = vtk%ioffset + ((N_Byte + BYI8P + 2_I8P)/3_I8P)*4_I8P -#else - vtk%ioffset = vtk%ioffset + ((N_Byte + BYI4P + 2_I4P)/3_I4P)*4_I4P -#endif - endif - return - !--------------------------------------------------------------------------------------------------------------------------------- - endsubroutine byte_update - - !> @brief Subroutine for updating (adding and removing elements into) vtk array. - pure subroutine vtk_update(act,cf,Nvtk,vtk) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - character(*), intent(IN):: act !< Action: 'ADD' one more element, 'REMOVE' current element file. - integer(I4P), intent(INOUT):: cf !< Current file index (for concurrent files IO). - integer(I4P), intent(INOUT):: Nvtk !< Number of (concurrent) VTK files. - type(Type_VTK_File), allocatable, intent(INOUT):: vtk(:) !< VTK files data. - type(Type_VTK_File), allocatable:: vtk_tmp(:) !< Temporary array of VTK files data. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - select case(Upper_Case(trim(act))) - case('ADD') - if (Nvtk>0_I4P) then - allocate(vtk_tmp(1:Nvtk)) - vtk_tmp = vtk - deallocate(vtk) - Nvtk = Nvtk + 1 - allocate(vtk(1:Nvtk)) - vtk(1:Nvtk-1) = vtk_tmp - deallocate(vtk_tmp) - cf = Nvtk - else - Nvtk = 1_I4P - allocate(vtk(1:Nvtk)) - cf = Nvtk - endif - case default - if (Nvtk>1_I4P) then - allocate(vtk_tmp(1:Nvtk-1)) - if (cf==Nvtk) then - vtk_tmp = vtk(1:Nvtk-1) - else - vtk_tmp(1 :cf-1) = vtk(1 :cf-1) - vtk_tmp(cf: ) = vtk(cf+1: ) - endif - deallocate(vtk) - Nvtk = Nvtk - 1 - allocate(vtk(1:Nvtk)) - vtk = vtk_tmp - deallocate(vtk_tmp) - cf = 1_I4P - else - Nvtk = 0_I4P - if (allocated(vtk)) deallocate(vtk) - cf = Nvtk - endif - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endsubroutine vtk_update - - !> @brief Function for converting array of 1 character to a string of characters. It is used for writing the stream of base64 - !> encoded data. - pure function tochar(string) result (char_string) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - character(1), intent(IN):: string(1:) !< Array of 1 character. - character(size(string,dim=1)):: char_string !< String of characters. - integer(I4P):: i !< Counter. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - forall(i = 1:size(string,dim=1)) - char_string(i:i) = string(i) - endforall - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction tochar - !> @} - - !> @brief Function for initializing VTK-XML file. - !> The XML standard is more powerful than legacy one. It is flexible but on the other hand is (but not so more using a library - !> like @libvtk...) complex than legacy standard. The output of XML functions is a well-formated valid XML file, at least for the - !> ascii, binary and binary appended formats (in the raw-binary format @libvtk uses raw-binary-appended format that is not a valid - !> XML file). - !> Note that the XML functions have the same name of legacy functions with the suffix \em XML. - !> @remark This function must be the first to be called. - !> @note Supported output formats are (the passed specifier value is case insensitive): - !> - ASCII: data are saved in ASCII format; - !> - BINARY: data are saved in base64 encoded format; - !> - RAW: data are saved in raw-binary format in the appended tag of the XML file; - !> - BINARY-APPENDED: data are saved in base64 encoded format in the appended tag of the XML file. - !> @note Supported topologies are: - !> - RectilinearGrid; - !> - StructuredGrid; - !> - UnstructuredGrid. - !> @note An example of usage is: \n - !> @code ... - !> integer(I4P):: nx1,nx2,ny1,ny2,nz1,nz2 - !> ... - !> E_IO = VTK_INI_XML('BINARY','XML_RECT_BINARY.vtr','RectilinearGrid',nx1=nx1,nx2=nx2,ny1=ny1,ny2=ny2,nz1=nz1,nz2=nz2) - !> ... @endcode - !> Note that the file extension is necessary in the file name. The XML standard has different extensions for each - !> different topologies (e.g. \em vtr for rectilinear topology). See the VTK-standard file for more information. - !> @return E_IO: integer(I4P) error flag - function VTK_INI_XML(output_format,filename,mesh_topology,cf,nx1,nx2,ny1,ny2,nz1,nz2) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - character(*), intent(IN):: output_format !< Output format: ASCII, BINARY, RAW or BINARY-APPENDED. - character(*), intent(IN):: filename !< File name. - character(*), intent(IN):: mesh_topology !< Mesh topology. - integer(I4P), intent(OUT), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P), intent(IN), optional:: nx1 !< Initial node of x axis. - integer(I4P), intent(IN), optional:: nx2 !< Final node of x axis. - integer(I4P), intent(IN), optional:: ny1 !< Initial node of y axis. - integer(I4P), intent(IN), optional:: ny2 !< Final node of y axis. - integer(I4P), intent(IN), optional:: nz1 !< Initial node of z axis. - integer(I4P), intent(IN), optional:: nz2 !< Final node of z axis. - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I4P):: rf !< Real file index. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - if (.not.ir_initialized) call IR_Init - call vtk_update(act='add',cf=rf,Nvtk=Nvtk,vtk=vtk) - f = rf - if (present(cf)) cf = rf - vtk(rf)%topology = trim(mesh_topology) - select case(trim(Upper_Case(output_format))) - case('ASCII') - vtk(rf)%f = ascii - open(unit=Get_Unit(vtk(rf)%u),file=trim(filename),form='FORMATTED',& - access='SEQUENTIAL',action='WRITE',status='REPLACE',iostat=E_IO) - ! writing header of file - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)'' - if (endian==endianL) then - s_buffer = '' - else - s_buffer = '' - endif - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(rf)%indent = 2 - select case(trim(vtk(rf)%topology)) - case('RectilinearGrid','StructuredGrid') - s_buffer = repeat(' ',vtk(rf)%indent)//'<'//trim(vtk(rf)%topology)//' WholeExtent="'//& - trim(str(n=nx1))//' '//trim(str(n=nx2))//' '// & - trim(str(n=ny1))//' '//trim(str(n=ny2))//' '// & - trim(str(n=nz1))//' '//trim(str(n=nz2))//'">' - case('UnstructuredGrid') - s_buffer = repeat(' ',vtk(rf)%indent)//'<'//trim(vtk(rf)%topology)//'>' - endselect - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(rf)%indent = vtk(rf)%indent + 2 - case('RAW','BINARY-APPENDED') - vtk(rf)%f = raw - if (trim(Upper_Case(output_format))=='BINARY-APPENDED') vtk(rf)%f = bin_app - open(unit=Get_Unit(vtk(rf)%u),file=trim(filename),& - form='UNFORMATTED',access='STREAM',action='WRITE',status='REPLACE',iostat=E_IO) - ! writing header of file - write(unit=vtk(rf)%u,iostat=E_IO)''//end_rec - if (endian==endianL) then - s_buffer = '' - else - s_buffer = '' - endif - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = 2 - select case(trim(vtk(rf)%topology)) - case('RectilinearGrid','StructuredGrid') - s_buffer = repeat(' ',vtk(rf)%indent)//'<'//trim(vtk(rf)%topology)//' WholeExtent="'//& - trim(str(n=nx1))//' '//trim(str(n=nx2))//' '// & - trim(str(n=ny1))//' '//trim(str(n=ny2))//' '// & - trim(str(n=nz1))//' '//trim(str(n=nz2))//'">' - case('UnstructuredGrid') - s_buffer = repeat(' ',vtk(rf)%indent)//'<'//trim(vtk(rf)%topology)//'>' - endselect - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - ! opening the SCRATCH file used for appending raw binary data - open(unit=Get_Unit(vtk(rf)%ua), form='UNFORMATTED', access='STREAM', action='READWRITE', status='SCRATCH', iostat=E_IO) - vtk(rf)%ioffset = 0 ! initializing offset pointer - case('BINARY') - vtk(rf)%f = binary - open(unit=Get_Unit(vtk(rf)%u),file=trim(filename),& - form='UNFORMATTED',access='STREAM',action='WRITE',status='REPLACE',iostat=E_IO) - ! writing header of file - write(unit=vtk(rf)%u,iostat=E_IO)''//end_rec - if (endian==endianL) then - s_buffer = '' - else - s_buffer = '' - endif - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = 2 - select case(trim(vtk(rf)%topology)) - case('RectilinearGrid','StructuredGrid') - s_buffer = repeat(' ',vtk(rf)%indent)//'<'//trim(vtk(rf)%topology)//' WholeExtent="'//& - trim(str(n=nx1))//' '//trim(str(n=nx2))//' '// & - trim(str(n=ny1))//' '//trim(str(n=ny2))//' '// & - trim(str(n=nz1))//' '//trim(str(n=nz2))//'">' - case('UnstructuredGrid') - s_buffer = repeat(' ',vtk(rf)%indent)//'<'//trim(vtk(rf)%topology)//'>' - endselect - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_INI_XML - - !> @ingroup Lib_VTK_IOPrivateProcedure - !> @{ - !> Function for open/close field data tag. - !> @return E_IO: integer(I4P) error flag - function VTK_FLD_XML_OC(fld_action,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - character(*), intent(IN):: fld_action !< Field data tag action: OPEN or CLOSE tag. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - integer(I4P):: rf !< Real file index. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(trim(Upper_Case(fld_action))) - case('OPEN') - select case(vtk(rf)%f) - case(ascii) - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent + 2 - case(raw,binary,bin_app) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - endselect - case('CLOSE') - select case(vtk(rf)%f) - case(ascii) - vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,binary,bin_app) - vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_FLD_XML_OC - - !> Function for saving field data (global auxiliary data, e.g. time, step number, data set name...) (R8P). - !> @return E_IO: integer(I4P) error flag - function VTK_FLD_XML_R8(fld,fname,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - real(R8P), intent(IN):: fld !< Field data value. - character(*), intent(IN):: fname !< Field data name. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I1P), allocatable:: fldp(:) !< Packed field data. - character(1), allocatable:: fld64(:) !< Field data encoded in base64. - integer(I4P):: rf !< Real file index. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer=repeat(' ',vtk(rf)%indent)//''//& - trim(str(n=fld))//'' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) - case(raw,bin_app) - s_buffer=repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = int(BYR8P,I4P)) - write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R8',1_I4P - write(unit=vtk(rf)%ua,iostat=E_IO)fld - case(binary) - s_buffer=repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call pack_data(a1=[int(BYR8P,I4P)],a2=[fld],packed=fldp) - call b64_encode(nB=int(BYI1P,I4P),n=fldp,code=fld64) ; deallocate(fldp) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(fld64)//end_rec ; deallocate(fld64) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_FLD_XML_R8 - - !> Function for saving field data (global auxiliary data, e.g. time, step number, data set name...) (R4P). - !> @return E_IO: integer(I4P) error flag - function VTK_FLD_XML_R4(fld,fname,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - real(R4P), intent(IN):: fld !< Field data value. - character(*), intent(IN):: fname !< Field data name. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I1P), allocatable:: fldp(:) !< Packed field data. - character(1), allocatable:: fld64(:) !< Field data encoded in base64. - integer(I4P):: rf !< Real file index. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer=repeat(' ',vtk(rf)%indent)//''//& - trim(str(n=fld))//'' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) - case(raw,bin_app) - s_buffer=repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = int(BYR4P,I4P)) - write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R4',1_I4P - write(unit=vtk(rf)%ua,iostat=E_IO)fld - case(binary) - s_buffer=repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call pack_data(a1=[int(BYR4P,I4P)],a2=[fld],packed=fldp) - call b64_encode(nB=int(BYI1P,I4P),n=fldp,code=fld64) ; deallocate(fldp) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(fld64)//end_rec ; deallocate(fld64) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_FLD_XML_R4 - - !> Function for saving field data (global auxiliary data, e.g. time, step number, data set name...) (I8P). - !> @return E_IO: integer(I4P) error flag - function VTK_FLD_XML_I8(fld,fname,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I8P), intent(IN):: fld !< Field data value. - character(*), intent(IN):: fname !< Field data name. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I1P), allocatable:: fldp(:) !< Packed field data. - character(1), allocatable:: fld64(:) !< Field data encoded in base64. - integer(I4P):: rf !< Real file index. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//''// & - trim(str(n=fld))//'' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = int(BYI8P,I4P)) - write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I8',1_I4P - write(unit=vtk(rf)%ua,iostat=E_IO)fld - case(binary) - s_buffer=repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call pack_data(a1=[int(BYI8P,I4P)],a2=[fld],packed=fldp) - call b64_encode(nB=int(BYI1P,I4P),n=fldp,code=fld64) ; deallocate(fldp) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(fld64)//end_rec ; deallocate(fld64) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_FLD_XML_I8 - - !> Function for saving field data (global auxiliary data, e.g. time, step number, data set name...) (I4P). - !> @return E_IO: integer(I4P) error flag - function VTK_FLD_XML_I4(fld,fname,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: fld !< Field data value. - character(*), intent(IN):: fname !< Field data name. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I1P), allocatable:: fldp(:) !< Packed field data. - character(1), allocatable:: fld64(:) !< Field data encoded in base64. - integer(I4P):: rf !< Real file index. - integer(I8P):: Nfldp !< Dimension of fldp, packed data. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//''// & - trim(str(n=fld))//'' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = int(BYI4P,I4P)) - write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I4',1_I4P - write(unit=vtk(rf)%ua,iostat=E_IO)fld - case(binary) - s_buffer=repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - Nfldp=size(transfer([int(BYI4P,I4P),fld],fldp),kind=I8P) ; if (allocated(fldp)) deallocate(fldp) ; allocate(fldp(1:Nfldp)) - fldp = transfer([int(BYI4P,I4P),fld],fldp) - call b64_encode(nB=int(BYI1P,I4P),n=fldp,code=fld64) ; deallocate(fldp) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(fld64)//end_rec ; deallocate(fld64) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_FLD_XML_I4 - - !> Function for saving field data (global auxiliary data, e.g. time, step number, data set name...) (I2P). - !> @return E_IO: integer(I4P) error flag - function VTK_FLD_XML_I2(fld,fname,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I2P), intent(IN):: fld !< Field data value. - character(*), intent(IN):: fname !< Field data name. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I1P), allocatable:: fldp(:) !< Packed field data. - character(1), allocatable:: fld64(:) !< Field data encoded in base64. - integer(I4P):: rf !< Real file index. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//''// & - trim(str(n=fld))//'' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = int(BYI2P,I4P)) - write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I2',1_I4P - write(unit=vtk(rf)%ua,iostat=E_IO)fld - case(binary) - s_buffer=repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call pack_data(a1=[int(BYI2P,I4P)],a2=[fld],packed=fldp) - call b64_encode(nB=int(BYI1P,I4P),n=fldp,code=fld64) ; deallocate(fldp) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(fld64)//end_rec ; deallocate(fld64) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_FLD_XML_I2 - - !> Function for saving field data (global auxiliary data, e.g. time, step number, data set name...) (I1P). - !> @return E_IO: integer(I4P) error flag - function VTK_FLD_XML_I1(fld,fname,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I1P), intent(IN):: fld !< Field data value. - character(*), intent(IN):: fname !< Field data name. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I1P), allocatable:: fldp(:) !< Packed field data. - character(1), allocatable:: fld64(:) !< Field data encoded in base64. - integer(I4P):: rf !< Real file index. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//''// & - trim(str(n=fld))//'' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = int(BYI1P,I4P)) - write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I1',1_I4P - write(unit=vtk(rf)%ua,iostat=E_IO)fld - case(binary) - s_buffer=repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call pack_data(a1=[int(BYI1P,I4P)],a2=[fld],packed=fldp) - call b64_encode(nB=int(BYI1P,I4P),n=fldp,code=fld64) ; deallocate(fldp) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(fld64)//end_rec ; deallocate(fld64) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_FLD_XML_I1 - - !> Function for saving mesh with \b StructuredGrid topology (R8P, 1D Arrays). - !> @return E_IO: integer(I4P) error flag - function VTK_GEO_XML_STRG_1DA_R8(nx1,nx2,ny1,ny2,nz1,nz2,NN,X,Y,Z,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: nx1 !< Initial node of x axis. - integer(I4P), intent(IN):: nx2 !< Final node of x axis. - integer(I4P), intent(IN):: ny1 !< Initial node of y axis. - integer(I4P), intent(IN):: ny2 !< Final node of y axis. - integer(I4P), intent(IN):: nz1 !< Initial node of z axis. - integer(I4P), intent(IN):: nz2 !< Final node of z axis. - integer(I4P), intent(IN):: NN !< Number of all nodes. - real(R8P), intent(IN):: X(1:) !< X coordinates [1:NN]. - real(R8P), intent(IN):: Y(1:) !< Y coordinates [1:NN]. - real(R8P), intent(IN):: Z(1:) !< Z coordinates [1:NN]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - integer(I1P), allocatable:: XYZp(:) !< Packed coordinates data. - character(1), allocatable:: XYZ64(:) !< X, Y, Z coordinates encoded in base64. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I4P):: rf !< Real file index. - integer(I4P):: n1 !< Counter. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(rf)%indent = vtk(rf)%indent + 2 - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent + 2 - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) - do n1=1,NN - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//str(n=X(n1))//' '//str(n=Y(n1))//' '//str(n=Z(n1)) - enddo - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent - 2 - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - s_buffer = repeat(' ',vtk(rf)%indent)// & - '' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = 3*NN*BYR8P) - write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R8',3*NN - write(unit=vtk(rf)%ua,iostat=E_IO)(X(n1),Y(n1),Z(n1),n1=1,NN) - vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - case(binary) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call pack_data(a1=[int(3*NN*BYR8P,I4P)],a2=[(X(n1),Y(n1),Z(n1),n1=1,NN)],packed=XYZp) - call b64_encode(nB=int(BYI1P,I4P),n=XYZp,code=XYZ64) ; deallocate(XYZp) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(XYZ64)//end_rec ; deallocate(XYZ64) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_GEO_XML_STRG_1DA_R8 - - !> Function for saving mesh with \b StructuredGrid topology (R8P, 3D Arrays). - !> @return E_IO: integer(I4P) error flag - function VTK_GEO_XML_STRG_3DA_R8(nx1,nx2,ny1,ny2,nz1,nz2,NN,X,Y,Z,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: nx1 !< Initial node of x axis. - integer(I4P), intent(IN):: nx2 !< Final node of x axis. - integer(I4P), intent(IN):: ny1 !< Initial node of y axis. - integer(I4P), intent(IN):: ny2 !< Final node of y axis. - integer(I4P), intent(IN):: nz1 !< Initial node of z axis. - integer(I4P), intent(IN):: nz2 !< Final node of z axis. - integer(I4P), intent(IN):: NN !< Number of all nodes. - real(R8P), intent(IN):: X(nx1:,ny1:,nz1:) !< X coordinates [nx1:nx2,ny1:ny2,nz1:nz2]. - real(R8P), intent(IN):: Y(nx1:,ny1:,nz1:) !< Y coordinates [nx1:nx2,ny1:ny2,nz1:nz2]. - real(R8P), intent(IN):: Z(nx1:,ny1:,nz1:) !< Z coordinates [nx1:nx2,ny1:ny2,nz1:nz2]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - integer(I1P), allocatable:: XYZp(:) !< Packed coordinates data. - character(1), allocatable:: XYZ64(:) !< X, Y, Z coordinates encoded in base64. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I4P):: rf !< Real file index. - integer(I4P):: nx,ny,nz !< Counters. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(rf)%indent = vtk(rf)%indent + 2 - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent + 2 - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) - do nz=nz1,nz2 - do ny=ny1,ny2 - do nx=nx1,nx2 - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//& - str(n=X(nx,ny,nz))//' '//str(n=Y(nx,ny,nz))//' '//str(n=Z(nx,ny,nz)) - enddo - enddo - enddo - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent - 2 - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - s_buffer = repeat(' ',vtk(rf)%indent)// & - '' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = 3*NN*BYR8P) - write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R8',3*NN - write(unit=vtk(rf)%ua,iostat=E_IO)(((X(nx,ny,nz),Y(nx,ny,nz),Z(nx,ny,nz),nx=nx1,nx2),ny=ny1,ny2),nz=nz1,nz2) - vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - case(binary) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call pack_data(a1=[int(3*NN*BYR8P,I4P)],a2=[(((X(nx,ny,nz),Y(nx,ny,nz),Z(nx,ny,nz),nx=nx1,nx2),ny=ny1,ny2),nz=nz1,nz2)],& - packed=XYZp) - call b64_encode(nB=int(BYI1P,I4P),n=XYZp,code=XYZ64) ; deallocate(XYZp) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(XYZ64)//end_rec ; deallocate(XYZ64) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_GEO_XML_STRG_3DA_R8 - - !> Function for saving mesh with \b StructuredGrid topology (R8P, 1D Arrays, packed API). - !> @return E_IO: integer(I4P) error flag - function VTK_GEO_XML_STRG_1DAP_R8(nx1,nx2,ny1,ny2,nz1,nz2,NN,XYZ,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: nx1 !< Initial node of x axis. - integer(I4P), intent(IN):: nx2 !< Final node of x axis. - integer(I4P), intent(IN):: ny1 !< Initial node of y axis. - integer(I4P), intent(IN):: ny2 !< Final node of y axis. - integer(I4P), intent(IN):: nz1 !< Initial node of z axis. - integer(I4P), intent(IN):: nz2 !< Final node of z axis. - integer(I4P), intent(IN):: NN !< Number of all nodes. - real(R8P), intent(IN):: XYZ(1:,1:) !< X, Y, Z coordinates (packed API) [1:3,1:NN]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - integer(I1P), allocatable:: XYZp(:) !< Packed coordinates data. - character(1), allocatable:: XYZ64(:) !< X, Y, Z coordinates encoded in base64. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I4P):: rf !< Real file index. - integer(I4P):: n1 !< Counter. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(rf)%indent = vtk(rf)%indent + 2 - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent + 2 - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) - do n1=1,NN - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//& - str(n=XYZ(1,n1))//' '//str(n=XYZ(2,n1))//' '//str(n=XYZ(3,n1)) - enddo - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent - 2 - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - s_buffer = repeat(' ',vtk(rf)%indent)// & - '' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = 3*NN*BYR8P) - write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R8',3*NN - write(unit=vtk(rf)%ua,iostat=E_IO)XYZ - vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - case(binary) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call pack_data(a1=[int(3*NN*BYR8P,I4P)],a2=reshape(XYZ,[3*NN]),packed=XYZp) - call b64_encode(nB=int(BYI1P,I4P),n=XYZp,code=XYZ64) ; deallocate(XYZp) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(XYZ64)//end_rec ; deallocate(XYZ64) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_GEO_XML_STRG_1DAP_R8 - - !> Function for saving mesh with \b StructuredGrid topology (R8P, 3D Arrays, packed API). - !> @return E_IO: integer(I4P) error flag - function VTK_GEO_XML_STRG_3DAP_R8(nx1,nx2,ny1,ny2,nz1,nz2,NN,XYZ,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: nx1 !< Initial node of x axis. - integer(I4P), intent(IN):: nx2 !< Final node of x axis. - integer(I4P), intent(IN):: ny1 !< Initial node of y axis. - integer(I4P), intent(IN):: ny2 !< Final node of y axis. - integer(I4P), intent(IN):: nz1 !< Initial node of z axis. - integer(I4P), intent(IN):: nz2 !< Final node of z axis. - integer(I4P), intent(IN):: NN !< Number of all nodes. - real(R8P), intent(IN):: XYZ(1:,nx1:,ny1:,nz1:) !< X, Y, Z coordinates (packed API). - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - integer(I1P), allocatable:: XYZp(:) !< Packed coordinates data. - character(1), allocatable:: XYZ64(:) !< X, Y, Z coordinates encoded in base64. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I4P):: rf !< Real file index. - integer(I4P):: nx,ny,nz !< Counters. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(rf)%indent = vtk(rf)%indent + 2 - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent + 2 - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) - do nz=nz1,nz2 - do ny=ny1,ny2 - do nx=nx1,nx2 - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//& - str(n=XYZ(1,nx,ny,nz))//' '//str(n=XYZ(2,nx,ny,nz))//' '//str(n=XYZ(3,nx,ny,nz)) - enddo - enddo - enddo - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent - 2 - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - s_buffer = repeat(' ',vtk(rf)%indent)// & - '' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = 3*NN*BYR8P) - write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R8',3*NN - write(unit=vtk(rf)%ua,iostat=E_IO)XYZ - vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - case(binary) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call pack_data(a1=[int(3*NN*BYR8P,I4P)],a2=reshape(XYZ,[3*NN]),packed=XYZp) - call b64_encode(nB=int(BYI1P,I4P),n=XYZp,code=XYZ64) ; deallocate(XYZp) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(XYZ64)//end_rec ; deallocate(XYZ64) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_GEO_XML_STRG_3DAP_R8 - - !> Function for saving mesh with \b StructuredGrid topology (R4P, 1D Arrays). - !> @return E_IO: integer(I4P) error flag - function VTK_GEO_XML_STRG_1DA_R4(nx1,nx2,ny1,ny2,nz1,nz2,NN,X,Y,Z,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: nx1 !< Initial node of x axis. - integer(I4P), intent(IN):: nx2 !< Final node of x axis. - integer(I4P), intent(IN):: ny1 !< Initial node of y axis. - integer(I4P), intent(IN):: ny2 !< Final node of y axis. - integer(I4P), intent(IN):: nz1 !< Initial node of z axis. - integer(I4P), intent(IN):: nz2 !< Final node of z axis. - integer(I4P), intent(IN):: NN !< Number of all nodes. - real(R4P), intent(IN):: X(1:) !< X coordinates [1:NN]. - real(R4P), intent(IN):: Y(1:) !< Y coordinates [1:NN]. - real(R4P), intent(IN):: Z(1:) !< Z coordinates [1:NN]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I1P), allocatable:: XYZp(:) !< Packed data. - character(1), allocatable:: XYZ64(:) !< X, Y, Z coordinates encoded in base64. - integer(I4P):: rf !< Real file index. - integer(I4P):: n1 !< Counter. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(rf)%indent = vtk(rf)%indent + 2 - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent + 2 - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) - do n1=1,NN - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//str(n=X(n1))//' '//str(n=Y(n1))//' '//str(n=Z(n1)) - enddo - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent - 2 - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - s_buffer = repeat(' ',vtk(rf)%indent)// & - '' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = 3*NN*BYR4P) - write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R4',3*NN - write(unit=vtk(rf)%ua,iostat=E_IO)(X(n1),Y(n1),Z(n1),n1=1,NN) - vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - case(binary) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call pack_data(a1=[int(3*NN*BYR4P,I4P)],a2=[(X(n1),Y(n1),Z(n1),n1=1,NN)],packed=XYZp) - call b64_encode(nB=int(BYI1P,I4P),n=XYZp,code=XYZ64) ; deallocate(XYZp) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(XYZ64)//end_rec ; deallocate(XYZ64) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_GEO_XML_STRG_1DA_R4 - - !> Function for saving mesh with \b StructuredGrid topology (R4P, 3D Arrays). - !> @return E_IO: integer(I4P) error flag - function VTK_GEO_XML_STRG_3DA_R4(nx1,nx2,ny1,ny2,nz1,nz2,NN,X,Y,Z,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: nx1 !< Initial node of x axis. - integer(I4P), intent(IN):: nx2 !< Final node of x axis. - integer(I4P), intent(IN):: ny1 !< Initial node of y axis. - integer(I4P), intent(IN):: ny2 !< Final node of y axis. - integer(I4P), intent(IN):: nz1 !< Initial node of z axis. - integer(I4P), intent(IN):: nz2 !< Final node of z axis. - integer(I4P), intent(IN):: NN !< Number of all nodes. - real(R4P), intent(IN):: X(nx1:,ny1:,nz1:) !< X coordinates [nx1:nx2,ny1:ny2,nz1:nz2]. - real(R4P), intent(IN):: Y(nx1:,ny1:,nz1:) !< Y coordinates [nx1:nx2,ny1:ny2,nz1:nz2]. - real(R4P), intent(IN):: Z(nx1:,ny1:,nz1:) !< Z coordinates [nx1:nx2,ny1:ny2,nz1:nz2]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I1P), allocatable:: XYZp(:) !< Packed data. - character(1), allocatable:: XYZ64(:) !< X, Y, Z coordinates encoded in base64. - integer(I4P):: rf !< Real file index. - integer(I4P):: nx,ny,nz !< Counters. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(rf)%indent = vtk(rf)%indent + 2 - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent + 2 - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) - do nz=nz1,nz2 - do ny=ny1,ny2 - do nx=nx1,nx2 - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//& - str(n=X(nx,ny,nz))//' '//str(n=Y(nx,ny,nz))//' '//str(n=Z(nx,ny,nz)) - enddo - enddo - enddo - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent - 2 - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - s_buffer = repeat(' ',vtk(rf)%indent)// & - '' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = 3*NN*BYR4P) - write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R4',3*NN - write(unit=vtk(rf)%ua,iostat=E_IO)(((X(nx,ny,nz),Y(nx,ny,nz),Z(nx,ny,nz),nx=nx1,nx2),ny=ny1,ny2),nz=nz1,nz2) - vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - case(binary) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call pack_data(a1=[int(3*NN*BYR4P,I4P)],a2=[(((X(nx,ny,nz),Y(nx,ny,nz),Z(nx,ny,nz),nx=nx1,nx2),ny=ny1,ny2),nz=nz1,nz2)], & - packed=XYZp) - call b64_encode(nB=int(BYI1P,I4P),n=XYZp,code=XYZ64) ; deallocate(XYZp) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(XYZ64)//end_rec ; deallocate(XYZ64) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_GEO_XML_STRG_3DA_R4 - - !> Function for saving mesh with \b StructuredGrid topology (R4P, 1D Arrays, packed API). - !> @return E_IO: integer(I4P) error flag - function VTK_GEO_XML_STRG_1DAP_R4(nx1,nx2,ny1,ny2,nz1,nz2,NN,XYZ,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: nx1 !< Initial node of x axis. - integer(I4P), intent(IN):: nx2 !< Final node of x axis. - integer(I4P), intent(IN):: ny1 !< Initial node of y axis. - integer(I4P), intent(IN):: ny2 !< Final node of y axis. - integer(I4P), intent(IN):: nz1 !< Initial node of z axis. - integer(I4P), intent(IN):: nz2 !< Final node of z axis. - integer(I4P), intent(IN):: NN !< Number of all nodes. - real(R4P), intent(IN):: XYZ(1:,1:) !< X, Y, Z coordinates (packed API) [1:3,1:NN]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I1P), allocatable:: XYZp(:) !< Packed data. - character(1), allocatable:: XYZ64(:) !< X, Y, Z coordinates encoded in base64. - integer(I4P):: rf !< Real file index. - integer(I4P):: n1 !< Counter. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(rf)%indent = vtk(rf)%indent + 2 - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent + 2 - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) - do n1=1,NN - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//& - str(n=XYZ(1,n1))//' '//str(n=XYZ(2,n1))//' '//str(n=XYZ(3,n1)) - enddo - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent - 2 - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - s_buffer = repeat(' ',vtk(rf)%indent)// & - '' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = 3*NN*BYR4P) - write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R4',3*NN - write(unit=vtk(rf)%ua,iostat=E_IO)XYZ - vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - case(binary) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call pack_data(a1=[int(3*NN*BYR4P,I4P)],a2=reshape(XYZ,[3*NN]),packed=XYZp) - call b64_encode(nB=int(BYI1P,I4P),n=XYZp,code=XYZ64) ; deallocate(XYZp) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(XYZ64)//end_rec ; deallocate(XYZ64) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_GEO_XML_STRG_1DAP_R4 - - !> Function for saving mesh with \b StructuredGrid topology (R4P, 3D Arrays, packed API). - !> @return E_IO: integer(I4P) error flag - function VTK_GEO_XML_STRG_3DAP_R4(nx1,nx2,ny1,ny2,nz1,nz2,NN,XYZ,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: nx1 !< Initial node of x axis. - integer(I4P), intent(IN):: nx2 !< Final node of x axis. - integer(I4P), intent(IN):: ny1 !< Initial node of y axis. - integer(I4P), intent(IN):: ny2 !< Final node of y axis. - integer(I4P), intent(IN):: nz1 !< Initial node of z axis. - integer(I4P), intent(IN):: nz2 !< Final node of z axis. - integer(I4P), intent(IN):: NN !< Number of all nodes. - real(R4P), intent(IN):: XYZ(1:,nx1:,ny1:,nz1:) !< X, Y, Z coordinates (packed API) [1:3,nx1:nx2,ny1:ny2,nz1:nz2]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I1P), allocatable:: XYZp(:) !< Packed data. - character(1), allocatable:: XYZ64(:) !< X, Y, Z coordinates encoded in base64. - integer(I4P):: rf !< Real file index. - integer(I4P):: nx,ny,nz !< Counters. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(rf)%indent = vtk(rf)%indent + 2 - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent + 2 - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) - do nz=nz1,nz2 - do ny=ny1,ny2 - do nx=nx1,nx2 - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//& - str(n=XYZ(1,nx,ny,nz))//' '//str(n=XYZ(2,nx,ny,nz))//' '//str(n=XYZ(3,nx,ny,nz)) - enddo - enddo - enddo - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent - 2 - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - s_buffer = repeat(' ',vtk(rf)%indent)// & - '' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = 3*NN*BYR4P) - write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R4',3*NN - write(unit=vtk(rf)%ua,iostat=E_IO)XYZ - vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - case(binary) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call pack_data(a1=[int(3*NN*BYR4P,I4P)],a2=reshape(XYZ,[3*NN]),packed=XYZp) - call b64_encode(nB=int(BYI1P,I4P),n=XYZp,code=XYZ64) ; deallocate(XYZp) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(XYZ64)//end_rec ; deallocate(XYZ64) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_GEO_XML_STRG_3DAP_R4 - - !> Function for saving mesh with \b RectilinearGrid topology (R8P). - !> @return E_IO: integer(I4P) error flag - function VTK_GEO_XML_RECT_R8(nx1,nx2,ny1,ny2,nz1,nz2,X,Y,Z,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: nx1 !< Initial node of x axis. - integer(I4P), intent(IN):: nx2 !< Final node of x axis. - integer(I4P), intent(IN):: ny1 !< Initial node of y axis. - integer(I4P), intent(IN):: ny2 !< Final node of y axis. - integer(I4P), intent(IN):: nz1 !< Initial node of z axis. - integer(I4P), intent(IN):: nz2 !< Final node of z axis. - real(R8P), intent(IN):: X(nx1:nx2) !< X coordinates. - real(R8P), intent(IN):: Y(ny1:ny2) !< Y coordinates. - real(R8P), intent(IN):: Z(nz1:nz2) !< Z coordinates. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I1P), allocatable:: XYZp(:) !< Packed data. - character(1), allocatable:: XYZ64(:) !< X, Y, Z coordinates encoded in base64. - integer(I4P):: rf !< Real file index. - integer(I4P):: n1 !< Counter. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(rf)%indent = vtk(rf)%indent + 2 - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent + 2 - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,fmt=FR8P, iostat=E_IO)(X(n1),n1=nx1,nx2) - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,fmt=FR8P, iostat=E_IO)(Y(n1),n1=ny1,ny2) - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,fmt=FR8P, iostat=E_IO)(Z(n1),n1=nz1,nz2) - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent - 2 - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = (nx2-nx1+1)*BYR8P) - write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R8',(nx2-nx1+1) - write(unit=vtk(rf)%ua,iostat=E_IO)(X(n1),n1=nx1,nx2) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = (ny2-ny1+1)*BYR8P) - write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R8',(ny2-ny1+1) - write(unit=vtk(rf)%ua,iostat=E_IO)(Y(n1),n1=ny1,ny2) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = (nz2-nz1+1)*BYR8P) - write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R8',(nz2-nz1+1) - write(unit=vtk(rf)%ua,iostat=E_IO)(Z(n1),n1=nz1,nz2) - vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - case(binary) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call pack_data(a1=[int((nx2-nx1+1)*BYR8P,I4P)],a2=X,packed=XYZp) - call b64_encode(nB=int(BYI1P,I4P),n=XYZp,code=XYZ64) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(XYZ64)//end_rec - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call pack_data(a1=[int((ny2-ny1+1)*BYR8P,I4P)],a2=Y,packed=XYZp) - call b64_encode(nB=int(BYI1P,I4P),n=XYZp,code=XYZ64) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(XYZ64)//end_rec - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call pack_data(a1=[int((nz2-nz1+1)*BYR8P,I4P)],a2=Z,packed=XYZp) - call b64_encode(nB=int(BYI1P,I4P),n=XYZp,code=XYZ64) ; deallocate(XYZp) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(XYZ64)//end_rec ; deallocate(XYZ64) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - vtk(rf)%indent = vtk(rf)%indent - 2 - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_GEO_XML_RECT_R8 - - !> Function for saving mesh with \b RectilinearGrid topology (R4P). - !> @return E_IO: integer(I4P) error flag - function VTK_GEO_XML_RECT_R4(nx1,nx2,ny1,ny2,nz1,nz2,X,Y,Z,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: nx1 !< Initial node of x axis. - integer(I4P), intent(IN):: nx2 !< Final node of x axis. - integer(I4P), intent(IN):: ny1 !< Initial node of y axis. - integer(I4P), intent(IN):: ny2 !< Final node of y axis. - integer(I4P), intent(IN):: nz1 !< Initial node of z axis. - integer(I4P), intent(IN):: nz2 !< Final node of z axis. - real(R4P), intent(IN):: X(nx1:nx2) !< X coordinates. - real(R4P), intent(IN):: Y(ny1:ny2) !< Y coordinates. - real(R4P), intent(IN):: Z(nz1:nz2) !< Z coordinates. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I1P), allocatable:: XYZp(:) !< Packed data. - character(1), allocatable:: XYZ64(:) !< X, Y, Z coordinates encoded in base64. - integer(I4P):: rf !< Real file index. - integer(I4P):: n1 !< Counter. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(rf)%indent = vtk(rf)%indent + 2 - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent + 2 - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,fmt=FR4P, iostat=E_IO)(X(n1),n1=nx1,nx2) - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,fmt=FR4P, iostat=E_IO)(Y(n1),n1=ny1,ny2) - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,fmt=FR4P, iostat=E_IO)(Z(n1),n1=nz1,nz2) - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent - 2 - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = (nx2-nx1+1)*BYR4P) - write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R4',(nx2-nx1+1) - write(unit=vtk(rf)%ua,iostat=E_IO)(X(n1),n1=nx1,nx2) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = (ny2-ny1+1)*BYR4P) - write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R4',(ny2-ny1+1) - write(unit=vtk(rf)%ua,iostat=E_IO)(Y(n1),n1=ny1,ny2) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = (nz2-nz1+1)*BYR4P) - write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R4',(nz2-nz1+1) - write(unit=vtk(rf)%ua,iostat=E_IO)(Z(n1),n1=nz1,nz2) - vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - case(binary) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call pack_data(a1=[int((nx2-nx1+1)*BYR4P,I4P)],a2=X,packed=XYZp) - call b64_encode(nB=int(BYI1P,I4P),n=XYZp,code=XYZ64) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(XYZ64)//end_rec - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call pack_data(a1=[int((ny2-ny1+1)*BYR4P,I4P)],a2=Y,packed=XYZp) - call b64_encode(nB=int(BYI1P,I4P),n=XYZp,code=XYZ64) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(XYZ64)//end_rec - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call pack_data(a1=[int((nz2-nz1+1)*BYR4P,I4P)],a2=Z,packed=XYZp) - call b64_encode(nB=int(BYI1P,I4P),n=XYZp,code=XYZ64) ; deallocate(XYZp) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(XYZ64)//end_rec ; deallocate(XYZ64) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - vtk(rf)%indent = vtk(rf)%indent - 2 - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_GEO_XML_RECT_R4 - - !> Function for saving mesh with \b UnstructuredGrid topology (R8P). - !> @return E_IO: integer(I4P) error flag - function VTK_GEO_XML_UNST_R8(NN,NC,X,Y,Z,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NN !< Number of nodes. - integer(I4P), intent(IN):: NC !< Number of cells. - real(R8P), intent(IN):: X(1:NN) !< X coordinates. - real(R8P), intent(IN):: Y(1:NN) !< Y coordinates. - real(R8P), intent(IN):: Z(1:NN) !< Z coordinates. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - real(R8P), allocatable:: XYZa(:) !< X, Y, Z coordinates. - integer(I1P), allocatable:: XYZp(:) !< Packed data. - character(1), allocatable:: XYZ64(:) !< X, Y, Z coordinates encoded in base64. - integer(I4P):: rf !< Real file index. - integer(I4P):: n1 !< Counter. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(rf)%indent = vtk(rf)%indent + 2 - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent + 2 - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) - do n1=1,NN - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//str(n=X(n1))//' '//str(n=Y(n1))//' '//str(n=Z(n1)) - enddo - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent - 2 - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - s_buffer = repeat(' ',vtk(rf)%indent)// & - '' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = 3*NN*BYR8P) - write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R8',3*NN - write(unit=vtk(rf)%ua,iostat=E_IO)(X(n1),Y(n1),Z(n1),n1=1,NN) - vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - case(binary) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - allocate(XYZa(1:3*NN)) - do n1 = 1,NN - XYZa(1+(n1-1)*3:1+(n1-1)*3+2)=[X(n1),Y(n1),Z(n1)] - enddo - call pack_data(a1=[int(3*NN*BYR8P,I4P)],a2=XYZa,packed=XYZp) ; deallocate(XYZa) - call b64_encode(nB=int(BYI1P,I4P),n=XYZp,code=XYZ64) ; deallocate(XYZp) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(XYZ64)//end_rec ; deallocate(XYZ64) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_GEO_XML_UNST_R8 - - !> Function for saving mesh with \b UnstructuredGrid topology (R8P, packed API). - !> @return E_IO: integer(I4P) error flag - function VTK_GEO_XML_UNST_PACK_R8(NN,NC,XYZ,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NN !< Number of nodes. - integer(I4P), intent(IN):: NC !< Number of cells. - real(R8P), intent(IN):: XYZ(1:3,1:NN) !< X, Y, Z coordinates (packed API). - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - real(R8P), allocatable:: XYZa(:) !< X, Y, Z coordinates. - integer(I1P), allocatable:: XYZp(:) !< Packed data. - character(1), allocatable:: XYZ64(:) !< X, Y, Z coordinates encoded in base64. - integer(I4P):: rf !< Real file index. - integer(I4P):: n1 !< Counter. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(rf)%indent = vtk(rf)%indent + 2 - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent + 2 - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) - do n1=1,NN - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//& - str(n=XYZ(1,n1))//' '//str(n=XYZ(2,n1))//' '//str(n=XYZ(3,n1)) - enddo - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent - 2 - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - s_buffer = repeat(' ',vtk(rf)%indent)// & - '' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = 3*NN*BYR8P) - write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R8',3*NN - write(unit=vtk(rf)%ua,iostat=E_IO)XYZ - vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - case(binary) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - allocate(XYZa(1:3*NN)) - do n1 = 1,NN - XYZa(1+(n1-1)*3:1+(n1-1)*3+2)=XYZ(1:3,n1) - enddo - call pack_data(a1=[int(3*NN*BYR8P,I4P)],a2=XYZa,packed=XYZp) ; deallocate(XYZa) - call b64_encode(nB=int(BYI1P,I4P),n=XYZp,code=XYZ64) ; deallocate(XYZp) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(XYZ64)//end_rec ; deallocate(XYZ64) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_GEO_XML_UNST_PACK_R8 - - !> Function for saving mesh with \b UnstructuredGrid topology (R4P). - !> @return E_IO: integer(I4P) error flag - function VTK_GEO_XML_UNST_R4(NN,NC,X,Y,Z,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NN !< Number of nodes. - integer(I4P), intent(IN):: NC !< Number of cells. - real(R4P), intent(IN):: X(1:NN) !< X coordinates. - real(R4P), intent(IN):: Y(1:NN) !< Y coordinates. - real(R4P), intent(IN):: Z(1:NN) !< Z coordinates. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - real(R4P), allocatable:: XYZa(:) !< X, Y, Z coordinates. - integer(I1P), allocatable:: XYZp(:) !< Packed data. - character(1), allocatable:: XYZ64(:) !< X, Y, Z coordinates encoded in base64. - integer(I4P):: rf !< Real file index. - integer(I4P):: n1 !< Counter. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(rf)%indent = vtk(rf)%indent + 2 - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent + 2 - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) - do n1=1,NN - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//str(n=X(n1))//' '//str(n=Y(n1))//' '//str(n=Z(n1)) - enddo - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent - 2 - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - s_buffer = repeat(' ',vtk(rf)%indent)// & - '' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = 3*NN*BYR4P) - write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R4',3*NN - write(unit=vtk(rf)%ua,iostat=E_IO)(X(n1),Y(n1),Z(n1),n1=1,NN) - vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - case(binary) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - allocate(XYZa(1:3*NN)) - do n1 = 1,NN - XYZa(1+(n1-1)*3:1+(n1-1)*3+2)=[X(n1),Y(n1),Z(n1)] - enddo - call pack_data(a1=[int(3*NN*BYR4P,I4P)],a2=XYZa,packed=XYZp) ; deallocate(XYZa) - call b64_encode(nB=int(BYI1P,I4P),n=XYZp,code=XYZ64) ; deallocate(XYZp) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(XYZ64)//end_rec ; deallocate(XYZ64) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_GEO_XML_UNST_R4 - - !> Function for saving mesh with \b UnstructuredGrid topology (R4P, packed API). - !> @return E_IO: integer(I4P) error flag - function VTK_GEO_XML_UNST_PACK_R4(NN,NC,XYZ,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NN !< Number of nodes. - integer(I4P), intent(IN):: NC !< Number of cells. - real(R4P), intent(IN):: XYZ(1:3,1:NN) !< X, Y, Z coordinates (packed API). - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - real(R4P), allocatable:: XYZa(:) !< X, Y, Z coordinates. - integer(I1P), allocatable:: XYZp(:) !< Packed data. - character(1), allocatable:: XYZ64(:) !< X, Y, Z coordinates encoded in base64. - integer(I4P):: rf !< Real file index. - integer(I4P):: n1 !< Counter. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(rf)%indent = vtk(rf)%indent + 2 - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent + 2 - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) - do n1=1,NN - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//& - str(n=XYZ(1,n1))//' '//str(n=XYZ(2,n1))//' '//str(n=XYZ(3,n1)) - enddo - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent - 2 - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - s_buffer = repeat(' ',vtk(rf)%indent)// & - '' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = 3*NN*BYR4P) - write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R4',3*NN - write(unit=vtk(rf)%ua,iostat=E_IO)XYZ - vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - case(binary) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - allocate(XYZa(1:3*NN)) - do n1 = 1,NN - XYZa(1+(n1-1)*3:1+(n1-1)*3+2)=XYZ(1:3,n1) - enddo - call pack_data(a1=[int(3*NN*BYR4P,I4P)],a2=XYZa,packed=XYZp) ; deallocate(XYZa) - call b64_encode(nB=int(BYI1P,I4P),n=XYZp,code=XYZ64) ; deallocate(XYZp) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(XYZ64)//end_rec ; deallocate(XYZ64) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_GEO_XML_UNST_PACK_R4 - - !> @brief Function for closing mesh block data. - !> @return E_IO: integer(I4P) error flag - function VTK_GEO_XML_CLOSEP(cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - integer(I4P):: rf !< Real file index. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - vtk(rf)%indent = vtk(rf)%indent - 2 - select case(vtk(rf)%f) - case(ascii) - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,binary,bin_app) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_GEO_XML_CLOSEP - !> @} - - !> Function that \b must be used when unstructured grid is used, it saves the connectivity of the unstructured gird. - !> @note The vector \b connect must follow the VTK-legacy standard. It is passed as \em assumed-shape array - !> because its dimensions is related to the mesh dimensions in a complex way. Its dimensions can be calculated by the following - !> equation: \f$dc = dc = \sum\limits_{i = 1}^{NC} {nvertex_i }\f$. - !> Note that this equation is different from the legacy one. The XML connectivity convention is quite different from the - !> legacy standard. As an example suppose we have a mesh composed by 2 cells, one hexahedron (8 vertices) and one pyramid with - !> square basis (5 vertices) and suppose that the basis of pyramid is constitute by a face of the hexahedron and so the two cells - !> share 4 vertices. The above equation gives \f$dc=8+5=13\f$. The connectivity vector for this mesh can be: \n - !> first cell \n - !> connect(1) = 0 identification flag of \f$1^\circ\f$ vertex of 1° cell \n - !> connect(2) = 1 identification flag of \f$2^\circ\f$ vertex of 1° cell \n - !> connect(3) = 2 identification flag of \f$3^\circ\f$ vertex of 1° cell \n - !> connect(4) = 3 identification flag of \f$4^\circ\f$ vertex of 1° cell \n - !> connect(5) = 4 identification flag of \f$5^\circ\f$ vertex of 1° cell \n - !> connect(6) = 5 identification flag of \f$6^\circ\f$ vertex of 1° cell \n - !> connect(7) = 6 identification flag of \f$7^\circ\f$ vertex of 1° cell \n - !> connect(8) = 7 identification flag of \f$8^\circ\f$ vertex of 1° cell \n - !> second cell \n - !> connect(9 ) = 0 identification flag of \f$1^\circ\f$ vertex of 2° cell \n - !> connect(10) = 1 identification flag of \f$2^\circ\f$ vertex of 2° cell \n - !> connect(11) = 2 identification flag of \f$3^\circ\f$ vertex of 2° cell \n - !> connect(12) = 3 identification flag of \f$4^\circ\f$ vertex of 2° cell \n - !> connect(13) = 8 identification flag of \f$5^\circ\f$ vertex of 2° cell \n - !> Therefore this connectivity vector convention is more simple than the legacy convention, now we must create also the - !> \em offset vector that contains the data now missing in the \em connect vector. The offset - !> vector for this mesh can be: \n - !> first cell \n - !> offset(1) = 8 => summ of nodes of \f$1^\circ\f$ cell \n - !> second cell \n - !> offset(2) = 13 => summ of nodes of \f$1^\circ\f$ and \f$2^\circ\f$ cells \n - !> The value of every cell-offset can be calculated by the following equation: \f$offset_c=\sum\limits_{i=1}^{c}{nvertex_i}\f$ - !> where \f$offset_c\f$ is the value of \f$c^{th}\f$ cell and \f$nvertex_i\f$ is the number of vertices of \f$i^{th}\f$ cell. - !> The function VTK_CON_XML does not calculate the connectivity and offset vectors: it writes the connectivity and offset - !> vectors conforming the VTK-XML standard, but does not calculate them. - !> The vector variable \em cell_type must conform the VTK-XML standard (see the file VTK-Standard at the - !> Kitware homepage) that is the same of the legacy standard. It contains the - !> \em type of each cells. For the above example this vector is: \n - !> first cell \n - !> cell_type(1) = 12 hexahedron type of \f$1^\circ\f$ cell \n - !> second cell \n - !> cell_type(2) = 14 pyramid type of \f$2^\circ\f$ cell \n - !> @return E_IO: integer(I4P) error flag - function VTK_CON_XML(NC,connect,offset,cell_type,idx,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NC !< Number of cells. - integer(I4P), intent(IN):: connect(1:) !< Mesh connectivity. - integer(I4P), intent(IN):: offset(1:NC) !< Cell offset. - integer(I1P), intent(IN):: cell_type(1:) !< VTK cell type. - integer(I1P), intent(IN), optional:: idx !< Id offset to convert Fortran (first id 1) to C (first id 0) standards. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I1P), allocatable:: cocp(:) !< Packed data. - character(1), allocatable:: coc64(:) !< Data encoded in base64. - integer(I1P):: incr !< Actual id offset increment. - integer(I4P):: rf !< Real file index. - integer(I4P):: n1 !< Counter. - integer(I8P):: Ncocp !< Dimension of cocp, packed data. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - incr = 0_I1P - if (present(idx)) then - incr = idx - endif - select case(vtk(rf)%f) - case(ascii) - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent + 2 - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//& - '' - write(unit=vtk(rf)%u,fmt=FI4P, iostat=E_IO)(connect(n1)+incr,n1=1,offset(NC)) - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,fmt=FI4P, iostat=E_IO)(offset(n1),n1=1,NC) - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - if (lbound(cell_type,dim=1)==ubound(cell_type,dim=1)) then - write(unit=vtk(rf)%u,fmt=FI1P, iostat=E_IO)(cell_type(1),n1=1,NC) - else - write(unit=vtk(rf)%u,fmt=FI1P, iostat=E_IO)(cell_type(n1),n1=1,NC) - endif - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent - 2 - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,bin_app) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = offset(NC)*BYI4P) - write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I4',offset(NC) - write(unit=vtk(rf)%ua,iostat=E_IO)(connect(n1)+incr,n1=1,offset(NC)) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = NC*BYI4P) - write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I4',NC - write(unit=vtk(rf)%ua,iostat=E_IO)(offset(n1),n1=1,NC) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = NC*BYI1P) - write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I1',NC - if (lbound(cell_type,dim=1)==ubound(cell_type,dim=1)) then - write(unit=vtk(rf)%ua,iostat=E_IO)(cell_type(1),n1=1,NC) - else - write(unit=vtk(rf)%ua,iostat=E_IO)(cell_type(n1),n1=1,NC) - endif - vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - case(binary) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//& - ''//end_rec - Ncocp=size(transfer([int(offset(NC)*BYI4P,I4P),connect],cocp),kind=I8P) - if (allocated(cocp)) deallocate(cocp) ; allocate(cocp(1:Ncocp)) - cocp = transfer([int(offset(NC)*BYI4P,I4P),connect],cocp) - call b64_encode(nB=int(BYI1P,I4P),n=cocp,code=coc64) - deallocate(cocp) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(coc64)//end_rec - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - Ncocp=size(transfer([int(NC*BYI4P,I4P),offset],cocp),kind=I8P) ; if (allocated(cocp)) deallocate(cocp) ; allocate(cocp(1:Ncocp)) - cocp = transfer([int(NC*BYI4P,I4P),offset],cocp) - call b64_encode(nB=int(BYI1P,I4P),n=cocp,code=coc64) - deallocate(cocp) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(coc64)//end_rec - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - if (lbound(cell_type,dim=1)==ubound(cell_type,dim=1)) then - call pack_data(a1=[int(NC*BYI1P,I4P)],a2=[(cell_type(1),n1=1,NC)],packed=cocp) - else - call pack_data(a1=[int(NC*BYI1P,I4P)],a2=cell_type,packed=cocp) - endif - call b64_encode(nB=int(BYI1P,I4P),n=cocp,code=coc64) ; deallocate(cocp) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(coc64)//end_rec ; deallocate(coc64) - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent - 2 - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_CON_XML - - !> Function that \b must be called before saving the data related to geometric mesh, this function initializes the - !> saving of data variables indicating the \em type (node or cell centered) of variables that will be saved. - !> @note A single file can contain both cell and node centered variables. In this case the VTK_DAT_XML function must be - !> called two times, before saving cell-centered variables and before saving node-centered variables. - !> Examples of usage are: \n - !> \b Opening node piece: \n - !> @code ... - !> E_IO=VTK_DAT_XML('node','OPEN') - !> ... @endcode - !> \b Closing node piece: \n - !> @code ... - !> E_IO=VTK_DAT_XML('node','CLOSE') - !> ... @endcode - !> @return E_IO: integer(I4P) error flag - !> @ingroup Lib_VTK_IOPublicProcedure - function VTK_DAT_XML(var_location,var_block_action,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - character(*), intent(IN):: var_location !< Location of saving variables: CELL or NODE centered. - character(*), intent(IN):: var_block_action !< Variables block action: OPEN or CLOSE block. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - integer(I4P):: rf !< Real file index. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - select case(trim(Upper_Case(var_location))) - case('CELL') - select case(trim(Upper_Case(var_block_action))) - case('OPEN') - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent + 2 - case('CLOSE') - vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - endselect - case('NODE') - select case(trim(Upper_Case(var_block_action))) - case('OPEN') - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent + 2 - case('CLOSE') - vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - endselect - endselect - case(raw,binary,bin_app) - select case(trim(Upper_Case(var_location))) - case('CELL') - select case(trim(Upper_Case(var_block_action))) - case('OPEN') - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - case('CLOSE') - vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - case('NODE') - select case(trim(Upper_Case(var_block_action))) - case('OPEN') - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 - case('CLOSE') - vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - endselect - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_DAT_XML - - !> @ingroup Lib_VTK_IOPrivateProcedure - !> @{ - - !> Function for saving field of scalar variable (R8P, 1D array). - !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_SCAL_1DA_R8(NC_NN,varname,var,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. - character(*), intent(IN):: varname !< Variable name. - real(R8P), intent(IN):: var(1:) !< Variable to be saved [1:NC_NN]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I1P), allocatable:: varp(:) !< Packed data. - character(1), allocatable:: var64(:) !< Variable encoded in base64. - integer(I4P):: rf !< Real file index. - integer(I4P):: n1 !< Counter. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) - write(vtk(rf)%u,'('//trim(str(.true.,NC_NN+1))//'A)',iostat=E_IO)repeat(' ',vtk(rf)%indent),(' '//str(n=var(n1)),n1=1,NC_NN) - write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = NC_NN*BYR8P) - write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R8',NC_NN - write(vtk(rf)%ua,iostat=E_IO)var - case(binary) - s_buffer=repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call pack_data(a1=[int(NC_NN*BYR8P,I4P)],a2=var,packed=varp) - call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_SCAL_1DA_R8 - - !> Function for saving field of scalar variable (R8P, 3D array). - !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_SCAL_3DA_R8(NC_NN,varname,var,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. - character(*), intent(IN):: varname !< Variable name. - real(R8P), intent(IN):: var(1:,1:,1:) !< Variable to be saved [1:Nx,1:Ny,1:Nz]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I1P), allocatable:: varp(:) !< Packed data. - character(1), allocatable:: var64(:) !< Variable encoded in base64. - integer(I4P):: rf !< Real file index. - integer(I4P):: nx,ny,nz !< Counters. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,'(A)', iostat=E_IO)trim(s_buffer) - write(vtk(rf)%u,'('//trim(str(.true.,NC_NN+1))//'A)',iostat=E_IO)repeat(' ',vtk(rf)%indent),& - (((' '//str(n=var(nx,ny,nz)),nx=1,size(var,dim=1)),ny=1,size(var,dim=2)),nz=1,size(var,dim=3)) - write(vtk(rf)%u,'(A)', iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = NC_NN*BYR8P) - write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R8',NC_NN - write(vtk(rf)%ua,iostat=E_IO)var - case(binary) - s_buffer=repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call pack_data(a1=[int(NC_NN*BYR8P,I4P)],a2=reshape(var,[NC_NN]),packed=varp) - call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_SCAL_3DA_R8 - - !> Function for saving field of scalar variable (R4P, 1D array). - !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_SCAL_1DA_R4(NC_NN,varname,var,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. - character(*), intent(IN):: varname !< Variable name. - real(R4P), intent(IN):: var(1:) !< Variable to be saved [1:NC_NN]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I1P), allocatable:: varp(:) !< Packed data. - character(1), allocatable:: var64(:) !< Variable encoded in base64. - integer(I4P):: rf !< Real file index. - integer(I4P):: n1 !< Counter. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,'(A)', iostat=E_IO)trim(s_buffer) - write(vtk(rf)%u,'('//trim(str(.true.,NC_NN+1))//'A)',iostat=E_IO)repeat(' ',vtk(rf)%indent),(' '//str(n=var(n1)),n1=1,NC_NN) - write(vtk(rf)%u,'(A)', iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = NC_NN*BYR4P) - write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R4',NC_NN - write(vtk(rf)%ua,iostat=E_IO)var - case(binary) - s_buffer=repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call pack_data(a1=[int(NC_NN*BYR4P,I4P)],a2=var,packed=varp) - call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_SCAL_1DA_R4 - - !> Function for saving field of scalar variable (R4P, 3D array). - !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_SCAL_3DA_R4(NC_NN,varname,var,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. - character(*), intent(IN):: varname !< Variable name. - real(R4P), intent(IN):: var(1:,1:,1:) !< Variable to be saved [1:Nx,1:Ny,1:Nz]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I1P), allocatable:: varp(:) !< Packed data. - character(1), allocatable:: var64(:) !< Variable encoded in base64. - integer(I4P):: rf !< Real file index. - integer(I4P):: nx,ny,nz !< Counters. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,'(A)', iostat=E_IO)trim(s_buffer) - write(vtk(rf)%u,'('//trim(str(.true.,NC_NN+1))//'A)',iostat=E_IO)repeat(' ',vtk(rf)%indent),& - (((' '//str(n=var(nx,ny,nz)),nx=1,size(var,dim=1)),ny=1,size(var,dim=2)),nz=1,size(var,dim=3)) - write(vtk(rf)%u,'(A)', iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = NC_NN*BYR4P) - write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R4',NC_NN - write(vtk(rf)%ua,iostat=E_IO)var - case(binary) - s_buffer=repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call pack_data(a1=[int(NC_NN*BYR4P,I4P)],a2=reshape(var,[NC_NN]),packed=varp) - call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_SCAL_3DA_R4 - - !> Function for saving field of scalar variable (I8P, 1D array). - !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_SCAL_1DA_I8(NC_NN,varname,var,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. - character(*), intent(IN):: varname !< Variable name. - integer(I8P), intent(IN):: var(1:) !< Variable to be saved [1:NC_NN]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I1P), allocatable:: varp(:) !< Packed data. - character(1), allocatable:: var64(:) !< Variable encoded in base64. - integer(I4P):: rf !< Real file index. - integer(I4P):: n1 !< Counter. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) - write(vtk(rf)%u,'('//trim(str(.true.,NC_NN+1))//'A)',iostat=E_IO)repeat(' ',vtk(rf)%indent),(' '//str(n=var(n1)),n1=1,NC_NN) - write(vtk(rf)%u,'(A)',iostat=E_IO)'' - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = int(NC_NN*BYI8P,I4P)) - write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I8',NC_NN - write(vtk(rf)%ua,iostat=E_IO)var - case(binary) - s_buffer=repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call pack_data(a1=[int(NC_NN*BYI8P,I4P)],a2=var,packed=varp) - call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_SCAL_1DA_I8 - - !> Function for saving field of scalar variable (I8P, 3D array). - !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_SCAL_3DA_I8(NC_NN,varname,var,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. - character(*), intent(IN):: varname !< Variable name. - integer(I8P), intent(IN):: var(1:,1:,1:) !< Variable to be saved [1:Nx,1:Ny,1:Nz]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I1P), allocatable:: varp(:) !< Packed data. - character(1), allocatable:: var64(:) !< Variable encoded in base64. - integer(I4P):: rf !< Real file index. - integer(I4P):: nx,ny,nz !< Counters. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) - write(vtk(rf)%u,'('//trim(str(.true.,NC_NN+1))//'A)',iostat=E_IO)repeat(' ',vtk(rf)%indent),& - (((' '//str(n=var(nx,ny,nz)),nx=1,size(var,dim=1)),ny=1,size(var,dim=2)),nz=1,size(var,dim=3)) - write(vtk(rf)%u,'(A)',iostat=E_IO)'' - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = int(NC_NN*BYI8P,I4P)) - write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I8',NC_NN - write(vtk(rf)%ua,iostat=E_IO)var - case(binary) - s_buffer=repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call pack_data(a1=[int(NC_NN*BYI8P,I4P)],a2=reshape(var,[NC_NN]),packed=varp) - call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_SCAL_3DA_I8 - - !> Function for saving field of scalar variable (I4P, 1D array). - !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_SCAL_1DA_I4(NC_NN,varname,var,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. - character(*), intent(IN):: varname !< Variable name. - integer(I4P), intent(IN):: var(1:) !< Variable to be saved [1:NC_NN]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I1P), allocatable:: varp(:) !< Packed data. - character(1), allocatable:: var64(:) !< Variable encoded in base64. - integer(I4P):: rf !< Real file index. - integer(I4P):: n1 !< Counter. - integer(I8P):: Nvarp !< Dimension of varp, packed data. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) - write(vtk(rf)%u,'('//trim(str(.true.,NC_NN+1))//'A)',iostat=E_IO)repeat(' ',vtk(rf)%indent),(' '//str(n=var(n1)),n1=1,NC_NN) - write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = NC_NN*BYI4P) - write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I4',NC_NN - write(vtk(rf)%ua,iostat=E_IO)var - case(binary) - s_buffer=repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - Nvarp=size(transfer([int(NC_NN*BYI4P,I4P),var],varp),kind=I8P) ; if (allocated(varp)) deallocate(varp) ; allocate(varp(1:Nvarp)) - varp = transfer([int(NC_NN*BYI4P,I4P),var],varp) - call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_SCAL_1DA_I4 - - !> Function for saving field of scalar variable (I4P, 3D array). - !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_SCAL_3DA_I4(NC_NN,varname,var,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. - character(*), intent(IN):: varname !< Variable name. - integer(I4P), intent(IN):: var(1:,1:,1:) !< Variable to be saved [1:Nx,1:Ny,1:Nz]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I1P), allocatable:: varp(:) !< Packed data. - character(1), allocatable:: var64(:) !< Variable encoded in base64. - integer(I4P):: rf !< Real file index. - integer(I4P):: nx,ny,nz !< Counters. - integer(I8P):: Nvarp !< Dimension of varp, packed data. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) - write(vtk(rf)%u,'('//trim(str(.true.,NC_NN+1))//'A)',iostat=E_IO)repeat(' ',vtk(rf)%indent),& - (((' '//str(n=var(nx,ny,nz)),nx=1,size(var,dim=1)),ny=1,size(var,dim=2)),nz=1,size(var,dim=3)) - write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = NC_NN*BYI4P) - write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I4',NC_NN - write(vtk(rf)%ua,iostat=E_IO)var - case(binary) - s_buffer=repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - Nvarp=size(transfer([int(NC_NN*BYI4P,I4P),reshape(var,[NC_NN])],varp),kind=I8P) - if (allocated(varp)) deallocate(varp); allocate(varp(1:Nvarp)) - varp = transfer([int(NC_NN*BYI4P,I4P),reshape(var,[NC_NN])],varp) - call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_SCAL_3DA_I4 - - !> Function for saving field of scalar variable (I2P, 1D array). - !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_SCAL_1DA_I2(NC_NN,varname,var,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. - character(*), intent(IN):: varname !< Variable name. - integer(I2P), intent(IN):: var(1:) !< Variable to be saved [1:NC_NN]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I1P), allocatable:: varp(:) !< Packed data. - character(1), allocatable:: var64(:) !< Variable encoded in base64. - integer(I4P):: rf !< Real file index. - integer(I4P):: n1 !< Counter. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) - write(vtk(rf)%u,'('//trim(str(.true.,NC_NN+1))//'A)',iostat=E_IO)repeat(' ',vtk(rf)%indent),(' '//str(n=var(n1)),n1=1,NC_NN) - write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = NC_NN*BYI2P) - write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I2',NC_NN - write(vtk(rf)%ua,iostat=E_IO)var - case(binary) - s_buffer=repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call pack_data(a1=[int(NC_NN*BYI2P,I4P)],a2=var,packed=varp) - call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_SCAL_1DA_I2 - - !> Function for saving field of scalar variable (I2P, 3D array). - !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_SCAL_3DA_I2(NC_NN,varname,var,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. - character(*), intent(IN):: varname !< Variable name. - integer(I2P), intent(IN):: var(1:,1:,1:) !< Variable to be saved [1:Nx,1:Ny,1:Nz]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I1P), allocatable:: varp(:) !< Packed data. - character(1), allocatable:: var64(:) !< Variable encoded in base64. - integer(I4P):: rf !< Real file index. - integer(I4P):: nx,ny,nz !< Counters. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) - write(vtk(rf)%u,'('//trim(str(.true.,NC_NN+1))//'A)',iostat=E_IO)repeat(' ',vtk(rf)%indent),& - (((' '//str(n=var(nx,ny,nz)),nx=1,size(var,dim=1)),ny=1,size(var,dim=2)),nz=1,size(var,dim=3)) - write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = NC_NN*BYI2P) - write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I2',NC_NN - write(vtk(rf)%ua,iostat=E_IO)var - case(binary) - s_buffer=repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call pack_data(a1=[int(NC_NN*BYI2P,I4P)],a2=reshape(var,[NC_NN]),packed=varp) - call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_SCAL_3DA_I2 - - !> Function for saving field of scalar variable (I1P, 1D array). - !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_SCAL_1DA_I1(NC_NN,varname,var,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. - character(*), intent(IN):: varname !< Variable name. - integer(I1P), intent(IN):: var(1:) !< Variable to be saved [1:NC_NN]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I1P), allocatable:: varp(:) !< Packed data. - character(1), allocatable:: var64(:) !< Variable encoded in base64. - integer(I4P):: rf !< Real file index. - integer(I4P):: n1 !< Counter. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer=repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) - write(vtk(rf)%u,'('//trim(str(.true.,NC_NN+1))//'A)',iostat=E_IO)repeat(' ',vtk(rf)%indent),(' '//str(n=var(n1)),n1=1,NC_NN) - write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,bin_app) - s_buffer=repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = NC_NN*BYI1P) - write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I1',NC_NN - write(vtk(rf)%ua,iostat=E_IO)var - case(binary) - s_buffer=repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call pack_data(a1=[int(NC_NN*BYI1P,I4P)],a2=var,packed=varp) - call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_SCAL_1DA_I1 - - !> Function for saving field of scalar variable (I1P, 3D array). - !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_SCAL_3DA_I1(NC_NN,varname,var,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. - character(*), intent(IN):: varname !< Variable name. - integer(I1P), intent(IN):: var(1:,1:,1:) !< Variable to be saved [1:Nx,1:ny,1:Nz]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I1P), allocatable:: varp(:) !< Packed data. - character(1), allocatable:: var64(:) !< Variable encoded in base64. - integer(I4P):: rf !< Real file index. - integer(I4P):: nx,ny,nz !< Counters. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer=repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) - write(vtk(rf)%u,'('//trim(str(.true.,NC_NN+1))//'A)',iostat=E_IO)repeat(' ',vtk(rf)%indent),& - (((' '//str(n=var(nx,ny,nz)),nx=1,size(var,dim=1)),ny=1,size(var,dim=2)),nz=1,size(var,dim=3)) - write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,bin_app) - s_buffer=repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = NC_NN*BYI1P) - write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I1',NC_NN - write(vtk(rf)%ua,iostat=E_IO)var - case(binary) - s_buffer=repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call pack_data(a1=[int(NC_NN*BYI1P,I4P)],a2=reshape(var,[NC_NN]),packed=varp) - call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_SCAL_3DA_I1 - - !> Function for saving field of vectorial variable (R8P, 1D arrays). - !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_VECT_1DA_R8(NC_NN,varname,varX,varY,varZ,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. - character(*), intent(IN):: varname !< Variable name. - real(R8P), intent(IN):: varX(1:) !< X component [1:NC_NN]. - real(R8P), intent(IN):: varY(1:) !< Y component [1:NC_NN]. - real(R8P), intent(IN):: varZ(1:) !< Z component [1:NC_NN]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - real(R8P), allocatable:: var(:) !< X, Y, Z component. - integer(I1P), allocatable:: varp(:) !< Packed data. - character(1), allocatable:: var64(:) !< Variable encoded in base64. - integer(I4P):: rf !< Real file index. - integer(I4P):: n1 !< Counter. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) - do n1=1,NC_NN - write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//str(n=varX(n1))//' '//str(n=varY(n1))//' '//str(n=varZ(n1)) - enddo - write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = 3*NC_NN*BYR8P) - write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R8',3*NC_NN - write(vtk(rf)%ua,iostat=E_IO)(varX(n1),varY(n1),varZ(n1),n1=1,NC_NN) - case(binary) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - allocate(var(1:3*NC_NN)) - do n1=1,NC_NN - var(1+(n1-1)*3:1+(n1-1)*3+2)=[varX(n1),varY(n1),varZ(n1)] - enddo - call pack_data(a1=[int(3*NC_NN*BYR8P,I4P)],a2=var,packed=varp) ; deallocate(var) - call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_VECT_1DA_R8 - - !> Function for saving field of vectorial variable (R8P, 3D arrays). - !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_VECT_3DA_R8(NC_NN,varname,varX,varY,varZ,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. - character(*), intent(IN):: varname !< Variable name. - real(R8P), intent(IN):: varX(1:,1:,1:) !< X component [1:Nx,1:Ny,1:Nz]. - real(R8P), intent(IN):: varY(1:,1:,1:) !< Y component [1:Nx,1:Ny,1:Nz]. - real(R8P), intent(IN):: varZ(1:,1:,1:) !< Z component [1:Nx,1:Ny,1:Nz]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - real(R8P), allocatable:: var(:) !< X, Y, Z component. - integer(I1P), allocatable:: varp(:) !< Packed data. - character(1), allocatable:: var64(:) !< Variable encoded in base64. - integer(I4P):: rf !< Real file index. - integer(I4P):: nx,ny,nz,n1 !< Counters. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) - do nz=1,size(varX,dim=3) ; do ny=1,size(varX,dim=2) ; do nx=1,size(varX,dim=1) - write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//& - str(n=varX(nx,ny,nz))//' '//str(n=varY(nx,ny,nz))//' '//str(n=varZ(nx,ny,nz)) - enddo ; enddo ; enddo - write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = 3*NC_NN*BYR8P) - write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R8',3*NC_NN - write(vtk(rf)%ua,iostat=E_IO)(((varX(nx,ny,nz),varY(nx,ny,nz),varZ(nx,ny,nz),& - nx=1,size(varX,dim=1)),ny=1,size(varX,dim=2)),nz=1,size(varX,dim=3)) - case(binary) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - allocate(var(1:3*NC_NN)) - n1 = 0_I4P - do nz=1,size(varX,dim=3) ; do ny=1,size(varX,dim=2) ; do nx=1,size(varX,dim=1) - n1 = n1 + 1_I4P ; var(1+(n1-1)*3:1+(n1-1)*3+2)=[varX(nx,ny,nz),varY(nx,ny,nz),varZ(nx,ny,nz)] - enddo ; enddo ; enddo - call pack_data(a1=[int(3*NC_NN*BYR8P,I4P)],a2=var,packed=varp) ; deallocate(var) - call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_VECT_3DA_R8 - - !> Function for saving field of vectorial variable (R4P, 1D arrays). - !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_VECT_1DA_R4(NC_NN,varname,varX,varY,varZ,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. - character(*), intent(IN):: varname !< Variable name. - real(R4P), intent(IN):: varX(1:) !< X component [1:NC_NN]. - real(R4P), intent(IN):: varY(1:) !< Y component [1:NC_NN]. - real(R4P), intent(IN):: varZ(1:) !< Z component [1:NC_NN]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - real(R4P), allocatable:: var(:) !< X, Y, Z component. - integer(I1P), allocatable:: varp(:) !< Packed data. - character(1), allocatable:: var64(:) !< Variable encoded in base64. - integer(I4P):: rf !< Real file index. - integer(I4P):: n1 !< Counter. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) - do n1=1,NC_NN - write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//str(n=varX(n1))//' '//str(n=varY(n1))//' '//str(n=varZ(n1)) - enddo - write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = 3*NC_NN*BYR4P) - write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R4',3*NC_NN - write(vtk(rf)%ua,iostat=E_IO)(varX(n1),varY(n1),varZ(n1),n1=1,NC_NN) - case(binary) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - allocate(var(1:3*NC_NN)) - do n1=1,NC_NN - var(1+(n1-1)*3:1+(n1-1)*3+2)=[varX(n1),varY(n1),varZ(n1)] - enddo - call pack_data(a1=[int(3*NC_NN*BYR4P,I4P)],a2=var,packed=varp) ; deallocate(var) - call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_VECT_1DA_R4 - - !> Function for saving field of vectorial variable (R4P, 3D arrays). - !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_VECT_3DA_R4(NC_NN,varname,varX,varY,varZ,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. - character(*), intent(IN):: varname !< Variable name. - real(R4P), intent(IN):: varX(1:,1:,1:) !< X component [1:Nx,1:Ny,1:Nz]. - real(R4P), intent(IN):: varY(1:,1:,1:) !< Y component [1:Nx,1:Ny,1:Nz]. - real(R4P), intent(IN):: varZ(1:,1:,1:) !< Z component [1:Nx,1:Ny,1:Nz]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - real(R4P), allocatable:: var(:) !< X, Y, Z component. - integer(I1P), allocatable:: varp(:) !< Packed data. - character(1), allocatable:: var64(:) !< Variable encoded in base64. - integer(I4P):: rf !< Real file index. - integer(I4P):: nx,ny,nz,n1 !< Counters. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) - do nz=1,size(varX,dim=3) ; do ny=1,size(varX,dim=2) ; do nx=1,size(varX,dim=1) - write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//& - str(n=varX(nx,ny,nz))//' '//str(n=varY(nx,ny,nz))//' '//str(n=varZ(nx,ny,nz)) - enddo ; enddo ; enddo - write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = 3*NC_NN*BYR4P) - write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R4',3*NC_NN - write(vtk(rf)%ua,iostat=E_IO)(((varX(nx,ny,nz),varY(nx,ny,nz),varZ(nx,ny,nz),& - nx=1,size(varX,dim=1)),ny=1,size(varX,dim=2)),nz=1,size(varX,dim=3)) - case(binary) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - allocate(var(1:3*NC_NN)) - n1 = 0_I4P - do nz=1,size(varX,dim=3) ; do ny=1,size(varX,dim=2) ; do nx=1,size(varX,dim=1) - n1 = n1 + 1_I4P ; var(1+(n1-1)*3:1+(n1-1)*3+2)=[varX(nx,ny,nz),varY(nx,ny,nz),varZ(nx,ny,nz)] - enddo ; enddo ; enddo - call pack_data(a1=[int(3*NC_NN*BYR4P,I4P)],a2=var,packed=varp) ; deallocate(var) - call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_VECT_3DA_R4 - - !> Function for saving field of vectorial variable (I8P, 1D arrays). - !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_VECT_1DA_I8(NC_NN,varname,varX,varY,varZ,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. - character(*), intent(IN):: varname !< Variable name. - integer(I8P), intent(IN):: varX(1:) !< X component [1:NC_NN]. - integer(I8P), intent(IN):: varY(1:) !< Y component [1:NC_NN]. - integer(I8P), intent(IN):: varZ(1:) !< Z component [1:NC_NN]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I8P), allocatable:: var(:) !< X, Y, Z component. - integer(I1P), allocatable:: varp(:) !< Packed data. - character(1), allocatable:: var64(:) !< Variable encoded in base64. - integer(I4P):: rf !< Real file index. - integer(I4P):: n1 !< Counter. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) - do n1=1,NC_NN - write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//str(n=varX(n1))//' '//str(n=varY(n1))//' '//str(n=varZ(n1)) - enddo - write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = int(3*NC_NN*BYI8P,I4P)) - write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I8',3*NC_NN - write(vtk(rf)%ua,iostat=E_IO)(varX(n1),varY(n1),varZ(n1),n1=1,NC_NN) - case(binary) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - allocate(var(1:3*NC_NN)) - do n1=1,NC_NN - var(1+(n1-1)*3:1+(n1-1)*3+2)=[varX(n1),varY(n1),varZ(n1)] - enddo - call pack_data(a1=[int(3*NC_NN*BYI8P,I4P)],a2=var,packed=varp) ; deallocate(var) - call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_VECT_1DA_I8 - - !> Function for saving field of vectorial variable (I8P, 3D arrays). - !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_VECT_3DA_I8(NC_NN,varname,varX,varY,varZ,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. - character(*), intent(IN):: varname !< Variable name. - integer(I8P), intent(IN):: varX(1:,1:,1:) !< X component [1:Nx,1:Ny,1:Nz]. - integer(I8P), intent(IN):: varY(1:,1:,1:) !< Y component [1:Nx,1:Ny,1:Nz]. - integer(I8P), intent(IN):: varZ(1:,1:,1:) !< Z component [1:Nx,1:Ny,1:Nz]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I8P), allocatable:: var(:) !< X, Y, Z component. - integer(I1P), allocatable:: varp(:) !< Packed data. - character(1), allocatable:: var64(:) !< Variable encoded in base64. - integer(I4P):: rf !< Real file index. - integer(I4P):: nx,ny,nz,n1 !< Counters. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) - do nz=1,size(varX,dim=3) ; do ny=1,size(varX,dim=2) ; do nx=1,size(varX,dim=1) - write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//& - str(n=varX(nx,ny,nz))//' '//str(n=varY(nx,ny,nz))//' '//str(n=varZ(nx,ny,nz)) - enddo ; enddo ; enddo - write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = int(3*NC_NN*BYI8P,I4P)) - write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I8',3*NC_NN - write(vtk(rf)%ua,iostat=E_IO)(((varX(nx,ny,nz),varY(nx,ny,nz),varZ(nx,ny,nz),& - nx=1,size(varX,dim=1)),ny=1,size(varX,dim=2)),nz=1,size(varX,dim=3)) - case(binary) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - allocate(var(1:3*NC_NN)) - n1 = 0_I4P - do nz=1,size(varX,dim=3) ; do ny=1,size(varX,dim=2) ; do nx=1,size(varX,dim=1) - n1 = n1 + 1_I4P ; var(1+(n1-1)*3:1+(n1-1)*3+2)=[varX(nx,ny,nz),varY(nx,ny,nz),varZ(nx,ny,nz)] - enddo ; enddo ; enddo - call pack_data(a1=[int(3*NC_NN*BYI8P,I4P)],a2=var,packed=varp) ; deallocate(var) - call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_VECT_3DA_I8 - - !> Function for saving field of vectorial variable (I4P, 1D arrays). - !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_VECT_1DA_I4(NC_NN,varname,varX,varY,varZ,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. - character(*), intent(IN):: varname !< Variable name. - integer(I4P), intent(IN):: varX(1:) !< X component [1:NC_NN]. - integer(I4P), intent(IN):: varY(1:) !< Y component [1:NC_NN]. - integer(I4P), intent(IN):: varZ(1:) !< Z component [1:NC_NN]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I4P), allocatable:: var(:) !< X, Y, Z component. - integer(I1P), allocatable:: varp(:) !< Packed data. - character(1), allocatable:: var64(:) !< Variable encoded in base64. - integer(I4P):: rf !< Real file index. - integer(I4P):: n1 !< Counter. - integer(I8P):: Nvarp !< Dimension of varp, packed data. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) - do n1=1,NC_NN - write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//str(n=varX(n1))//' '//str(n=varY(n1))//' '//str(n=varZ(n1)) - enddo - write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = 3*NC_NN*BYI4P) - write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I4',3*NC_NN - write(vtk(rf)%ua,iostat=E_IO)(varX(n1),varY(n1),varZ(n1),n1=1,NC_NN) - case(binary) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - allocate(var(1:3*NC_NN)) - do n1=1,NC_NN - var(1+(n1-1)*3:1+(n1-1)*3+2)=[varX(n1),varY(n1),varZ(n1)] - enddo - Nvarp=size(transfer([int(3*NC_NN*BYI4P,I4P),var],varp),kind=I8P) - if (allocated(varp)) deallocate(varp); allocate(varp(1:Nvarp)) - varp = transfer([int(3*NC_NN*BYI4P,I4P),var],varp) ; deallocate(var) - call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_VECT_1DA_I4 - - !> Function for saving field of vectorial variable (I4P, 3D arrays). - !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_VECT_3DA_I4(NC_NN,varname,varX,varY,varZ,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. - character(*), intent(IN):: varname !< Variable name. - integer(I4P), intent(IN):: varX(1:,1:,1:) !< X component [1:Nx,1:Ny,1:Nz]. - integer(I4P), intent(IN):: varY(1:,1:,1:) !< Y component [1:Nx,1:Ny,1:Nz]. - integer(I4P), intent(IN):: varZ(1:,1:,1:) !< Z component [1:Nx,1:Ny,1:Nz]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I4P), allocatable:: var(:) !< X, Y, Z component. - integer(I1P), allocatable:: varp(:) !< Packed data. - character(1), allocatable:: var64(:) !< Variable encoded in base64. - integer(I4P):: rf !< Real file index. - integer(I4P):: nx,ny,nz,n1 !< Counters. - integer(I8P):: Nvarp !< Dimension of varp, packed data. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) - do nz=1,size(varX,dim=3) ; do ny=1,size(varX,dim=2) ; do nx=1,size(varX,dim=1) - write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//& - str(n=varX(nx,ny,nz))//' '//str(n=varY(nx,ny,nz))//' '//str(n=varZ(nx,ny,nz)) - enddo ; enddo ; enddo - write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = 3*NC_NN*BYI4P) - write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I4',3*NC_NN - write(vtk(rf)%ua,iostat=E_IO)(((varX(nx,ny,nz),varY(nx,ny,nz),varZ(nx,ny,nz),& - nx=1,size(varX,dim=1)),ny=1,size(varX,dim=2)),nz=1,size(varX,dim=3)) - case(binary) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - allocate(var(1:3*NC_NN)) - n1 = 0_I4P - do nz=1,size(varX,dim=3) ; do ny=1,size(varX,dim=2) ; do nx=1,size(varX,dim=1) - n1 = n1 + 1_I4P ; var(1+(n1-1)*3:1+(n1-1)*3+2)=[varX(nx,ny,nz),varY(nx,ny,nz),varZ(nx,ny,nz)] - enddo ; enddo ; enddo - Nvarp=size(transfer([int(3*NC_NN*BYI4P,I4P),var],varp),kind=I8P) - if (allocated(varp)) deallocate(varp); allocate(varp(1:Nvarp)) - varp = transfer([int(3*NC_NN*BYI4P,I4P),var],varp) ; deallocate(var) - call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_VECT_3DA_I4 - - !> Function for saving field of vectorial variable (I2P, 1D arrays). - !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_VECT_1DA_I2(NC_NN,varname,varX,varY,varZ,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. - character(*), intent(IN):: varname !< Variable name. - integer(I2P), intent(IN):: varX(1:) !< X component [1:NC_NN]. - integer(I2P), intent(IN):: varY(1:) !< Y component [1:NC_NN]. - integer(I2P), intent(IN):: varZ(1:) !< Z component [1:NC_NN]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I2P), allocatable:: var(:) !< X, Y, Z component. - integer(I1P), allocatable:: varp(:) !< Packed data. - character(1), allocatable:: var64(:) !< Variable encoded in base64. - integer(I4P):: rf !< Real file index. - integer(I4P):: n1 !< Counter. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) - do n1=1,NC_NN - write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//str(n=varX(n1))//' '//str(n=varY(n1))//' '//str(n=varZ(n1)) - enddo - write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = 3*NC_NN*BYI2P) - write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I2',3*NC_NN - write(vtk(rf)%ua,iostat=E_IO)(varX(n1),varY(n1),varZ(n1),n1=1,NC_NN) - case(binary) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - allocate(var(1:3*NC_NN)) - do n1=1,NC_NN - var(1+(n1-1)*3:1+(n1-1)*3+2)=[varX(n1),varY(n1),varZ(n1)] - enddo - call pack_data(a1=[int(3*NC_NN*BYI2P,I4P)],a2=var,packed=varp) ; deallocate(var) - call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_VECT_1DA_I2 - - !> Function for saving field of vectorial variable (I2P, 3D arrays). - !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_VECT_3DA_I2(NC_NN,varname,varX,varY,varZ,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. - character(*), intent(IN):: varname !< Variable name. - integer(I2P), intent(IN):: varX(1:,1:,1:) !< X component [1:Nx,1:Ny,1:Nz]. - integer(I2P), intent(IN):: varY(1:,1:,1:) !< Y component [1:Nx,1:Ny,1:Nz]. - integer(I2P), intent(IN):: varZ(1:,1:,1:) !< Z component [1:Nx,1:Ny,1:Nz]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I2P), allocatable:: var(:) !< X, Y, Z component. - integer(I1P), allocatable:: varp(:) !< Packed data. - character(1), allocatable:: var64(:) !< Variable encoded in base64. - integer(I4P):: rf !< Real file index. - integer(I4P):: nx,ny,nz,n1 !< Counters. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) - do nz=1,size(varX,dim=3) ; do ny=1,size(varX,dim=2) ; do nx=1,size(varX,dim=1) - write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//& - str(n=varX(nx,ny,nz))//' '//str(n=varY(nx,ny,nz))//' '//str(n=varZ(nx,ny,nz)) - enddo ; enddo ; enddo - write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = 3*NC_NN*BYI2P) - write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I2',3*NC_NN - write(vtk(rf)%ua,iostat=E_IO)(((varX(nx,ny,nz),varY(nx,ny,nz),varZ(nx,ny,nz),& - nx=1,size(varX,dim=1)),ny=1,size(varX,dim=2)),nz=1,size(varX,dim=3)) - case(binary) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - allocate(var(1:3*NC_NN)) - n1 = 0_I4P - do nz=1,size(varX,dim=3) ; do ny=1,size(varX,dim=2) ; do nx=1,size(varX,dim=1) - n1 = n1 + 1_I4P ; var(1+(n1-1)*3:1+(n1-1)*3+2)=[varX(nx,ny,nz),varY(nx,ny,nz),varZ(nx,ny,nz)] - enddo ; enddo ; enddo - call pack_data(a1=[int(3*NC_NN*BYI2P,I4P)],a2=var,packed=varp) ; deallocate(var) - call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_VECT_3DA_I2 - - !> Function for saving field of vectorial variable (I1P, 1D arrays). - !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_VECT_1DA_I1(NC_NN,varname,varX,varY,varZ,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. - character(*), intent(IN):: varname !< Variable name. - integer(I1P), intent(IN):: varX(1:) !< X component [1:NC_NN]. - integer(I1P), intent(IN):: varY(1:) !< Y component [1:NC_NN]. - integer(I1P), intent(IN):: varZ(1:) !< Z component [1:NC_NN]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I1P), allocatable:: var(:) !< X, Y, Z component. - integer(I1P), allocatable:: varp(:) !< Packed data. - character(1), allocatable:: var64(:) !< Variable encoded in base64. - integer(I4P):: rf !< Real file index. - integer(I4P):: n1 !< Counter. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer=repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) - do n1=1,NC_NN - write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//str(n=varX(n1))//' '//str(n=varY(n1))//' '//str(n=varZ(n1)) - enddo - write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,bin_app) - s_buffer=repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - vtk(rf)%N_Byte = 3*NC_NN*BYI1P - call vtk(rf)%byte_update(N_Byte = 3*NC_NN*BYI1P) - write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I1',3*NC_NN - write(vtk(rf)%ua,iostat=E_IO)(varX(n1),varY(n1),varZ(n1),n1=1,NC_NN) - case(binary) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - allocate(var(1:3*NC_NN)) - do n1=1,NC_NN - var(1+(n1-1)*3:1+(n1-1)*3+2)=[varX(n1),varY(n1),varZ(n1)] - enddo - call pack_data(a1=[int(3*NC_NN*BYI1P,I4P)],a2=var,packed=varp) ; deallocate(var) - call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_VECT_1DA_I1 - - !> Function for saving field of vectorial variable (I1P, 3D arrays). - !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_VECT_3DA_I1(NC_NN,varname,varX,varY,varZ,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. - character(*), intent(IN):: varname !< Variable name. - integer(I1P), intent(IN):: varX(1:,1:,1:) !< X component [1:Nx,1:Ny,1:Nz]. - integer(I1P), intent(IN):: varY(1:,1:,1:) !< Y component [1:Nx,1:Ny,1:Nz]. - integer(I1P), intent(IN):: varZ(1:,1:,1:) !< Z component [1:Nx,1:Ny,1:Nz]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I1P), allocatable:: var(:) !< X, Y, Z component. - integer(I1P), allocatable:: varp(:) !< Packed data. - character(1), allocatable:: var64(:) !< Variable encoded in base64. - integer(I4P):: rf !< Real file index. - integer(I4P):: nx,ny,nz,n1 !< Counters. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer=repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) - do nz=1,size(varX,dim=3) ; do ny=1,size(varX,dim=2) ; do nx=1,size(varX,dim=1) - write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//& - str(n=varX(nx,ny,nz))//' '//str(n=varY(nx,ny,nz))//' '//str(n=varZ(nx,ny,nz)) - enddo ; enddo ; enddo - write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,bin_app) - s_buffer=repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - vtk(rf)%N_Byte = 3*NC_NN*BYI1P - call vtk(rf)%byte_update(N_Byte = 3*NC_NN*BYI1P) - write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I1',3*NC_NN - write(vtk(rf)%ua,iostat=E_IO)(((varX(nx,ny,nz),varY(nx,ny,nz),varZ(nx,ny,nz),& - nx=1,size(varX,dim=1)),ny=1,size(varX,dim=2)),nz=1,size(varX,dim=3)) - case(binary) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - allocate(var(1:3*NC_NN)) - n1 = 0_I4P - do nz=1,size(varX,dim=3) ; do ny=1,size(varX,dim=2) ; do nx=1,size(varX,dim=1) - n1 = n1 + 1_I4P ; var(1+(n1-1)*3:1+(n1-1)*3+2)=[varX(nx,ny,nz),varY(nx,ny,nz),varZ(nx,ny,nz)] - enddo ; enddo ; enddo - call pack_data(a1=[int(3*NC_NN*BYI1P,I4P)],a2=var,packed=varp) ; deallocate(var) - call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_VECT_3DA_I1 - - !> Function for saving field of list variable (R8P, 1D array). - !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_LIST_1DA_R8(NC_NN,N_COL,varname,var,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. - integer(I4P), intent(IN):: N_COL !< Number of columns. - character(*), intent(IN):: varname !< Variable name. - real(R8P), intent(IN):: var(1:,1:) !< Components [1:N_COL,1:NC_NN]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I1P), allocatable:: varp(:) !< Packed data. - character(1), allocatable:: var64(:) !< Variable encoded in base64. - integer(I4P):: rf !< Real file index. - integer(I4P):: n1,n2 !< Counters. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) - do n2=1,NC_NN - write(vtk(rf)%u,'('//trim(str(.true.,N_COL+1))//'A)',iostat=E_IO)repeat(' ',vtk(rf)%indent),& - (' '//str(n=var(n1,n2)),n1=1,N_COL) - enddo - write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = N_COL*NC_NN*BYR8P) - write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R8',N_COL*NC_NN - write(vtk(rf)%ua,iostat=E_IO)var - case(binary) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call pack_data(a1=[int(N_COL*NC_NN*BYR8P,I4P)],a2=reshape(var,[N_COL*NC_NN]),packed=varp) - call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_LIST_1DA_R8 - - !> Function for saving field of list variable (R8P, 3D array). - !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_LIST_3DA_R8(NC_NN,N_COL,varname,var,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. - integer(I4P), intent(IN):: N_COL !< Number of columns. - character(*), intent(IN):: varname !< Variable name. - real(R8P), intent(IN):: var(1:,1:,1:,1:) !< Components [1:N_COL,1:Nx,1:Ny,1:Nz]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I1P), allocatable:: varp(:) !< Packed data. - character(1), allocatable:: var64(:) !< Variable encoded in base64. - integer(I4P):: rf !< Real file index. - integer(I4P):: nx,ny,nz,n1 !< Counters. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) - do nz=1,size(var,dim=4) ; do ny=1,size(var,dim=3) ; do nx=1,size(var,dim=2) - write(vtk(rf)%u,'('//trim(str(.true.,N_COL+1))//'A)',iostat=E_IO)repeat(' ',vtk(rf)%indent),& - (' '//str(n=var(n1,nx,ny,nz)),n1=1,N_COL) - enddo ; enddo ; enddo - write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = N_COL*NC_NN*BYR8P) - write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R8',N_COL*NC_NN - write(vtk(rf)%ua,iostat=E_IO)var - case(binary) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call pack_data(a1=[int(N_COL*NC_NN*BYR8P,I4P)],a2=reshape(var,[N_COL*NC_NN]),packed=varp) - call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_LIST_3DA_R8 - - !> Function for saving field of list variable (R4P, 1D array). - !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_LIST_1DA_R4(NC_NN,N_COL,varname,var,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. - integer(I4P), intent(IN):: N_COL !< Number of columns. - character(*), intent(IN):: varname !< Variable name. - real(R4P), intent(IN):: var(1:,1:) !< Components [1:N_COL,1:NC_NN]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I1P), allocatable:: varp(:) !< Packed data. - character(1), allocatable:: var64(:) !< Variable encoded in base64. - integer(I4P):: rf !< Real file index. - integer(I4P):: n1,n2 !< Counters. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) - do n2=1,NC_NN - write(vtk(rf)%u,'('//trim(str(.true.,N_COL+1))//'A)',iostat=E_IO)repeat(' ',vtk(rf)%indent),& - (' '//str(n=var(n1,n2)),n1=1,N_COL) - enddo - write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = N_COL*NC_NN*BYR4P) - write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R4',N_COL*NC_NN - write(vtk(rf)%ua,iostat=E_IO)var - case(binary) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call pack_data(a1=[int(N_COL*NC_NN*BYR4P,I4P)],a2=reshape(var,[N_COL*NC_NN]),packed=varp) - call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_LIST_1DA_R4 - - !> Function for saving field of list variable (R4P, 3D array). - !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_LIST_3DA_R4(NC_NN,N_COL,varname,var,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. - integer(I4P), intent(IN):: N_COL !< Number of columns. - character(*), intent(IN):: varname !< Variable name. - real(R4P), intent(IN):: var(1:,1:,1:,1:) !< Components [1:N_COL,1:Nx,1:Ny,1:Nz]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I1P), allocatable:: varp(:) !< Packed data. - character(1), allocatable:: var64(:) !< Variable encoded in base64. - integer(I4P):: rf !< Real file index. - integer(I4P):: nx,ny,nz,n1 !< Counters. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) - do nz=1,size(var,dim=4) ; do ny=1,size(var,dim=3) ; do nx=1,size(var,dim=2) - write(vtk(rf)%u,'('//trim(str(.true.,N_COL+1))//'A)',iostat=E_IO)repeat(' ',vtk(rf)%indent),& - (' '//str(n=var(n1,nx,ny,nz)),n1=1,N_COL) - enddo ; enddo ; enddo - write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = N_COL*NC_NN*BYR4P) - write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R4',N_COL*NC_NN - write(vtk(rf)%ua,iostat=E_IO)var - case(binary) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call pack_data(a1=[int(N_COL*NC_NN*BYR4P,I4P)],a2=reshape(var,[N_COL*NC_NN]),packed=varp) - call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_LIST_3DA_R4 - - !> Function for saving field of list variable (I8P, 1D array). - !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_LIST_1DA_I8(NC_NN,N_COL,varname,var,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. - integer(I4P), intent(IN):: N_COL !< Number of columns. - character(*), intent(IN):: varname !< Variable name. - integer(I8P), intent(IN):: var(1:,1:) !< Components [1:N_COL,1:NC_NN]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I1P), allocatable:: varp(:) !< Packed data. - character(1), allocatable:: var64(:) !< Variable encoded in base64. - integer(I4P):: rf !< Real file index. - integer(I4P):: n1,n2 !< Counters. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) - do n2=1,NC_NN - write(vtk(rf)%u,'('//trim(str(.true.,N_COL+1))//'A)',iostat=E_IO)repeat(' ',vtk(rf)%indent),& - (' '//str(n=var(n1,n2)),n1=1,N_COL) - enddo - write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = int(N_COL*NC_NN*BYI8P,I4P)) - write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I8',N_COL*NC_NN - write(vtk(rf)%ua,iostat=E_IO)var - case(binary) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call pack_data(a1=[int(N_COL*NC_NN*BYI8P,I4P)],a2=reshape(var,[N_COL*NC_NN]),packed=varp) - call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_LIST_1DA_I8 - - !> Function for saving field of list variable (I8P, 3D array). - !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_LIST_3DA_I8(NC_NN,N_COL,varname,var,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. - integer(I4P), intent(IN):: N_COL !< Number of columns. - character(*), intent(IN):: varname !< Variable name. - integer(I8P), intent(IN):: var(1:,1:,1:,1:) !< Components [1:N_COL,1:Nx,1:Ny,1:Nz]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I1P), allocatable:: varp(:) !< Packed data. - character(1), allocatable:: var64(:) !< Variable encoded in base64. - integer(I4P):: rf !< Real file index. - integer(I4P):: nx,ny,nz,n1 !< Counters. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) - do nz=1,size(var,dim=4) ; do ny=1,size(var,dim=3) ; do nx=1,size(var,dim=2) - write(vtk(rf)%u,'('//trim(str(.true.,N_COL+1))//'A)',iostat=E_IO)repeat(' ',vtk(rf)%indent),& - (' '//str(n=var(n1,nx,ny,nz)),n1=1,N_COL) - enddo ; enddo ; enddo - write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = int(N_COL*NC_NN*BYI8P,I4P)) - write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I8',N_COL*NC_NN - write(vtk(rf)%ua,iostat=E_IO)var - case(binary) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call pack_data(a1=[int(N_COL*NC_NN*BYI8P,I4P)],a2=reshape(var,[N_COL*NC_NN]),packed=varp) - call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_LIST_3DA_I8 - - !> Function for saving field of list variable (I4P, 1D array). - !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_LIST_1DA_I4(NC_NN,N_COL,varname,var,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. - integer(I4P), intent(IN):: N_COL !< Number of columns. - character(*), intent(IN):: varname !< Variable name. - integer(I4P), intent(IN):: var(1:,1:) !< Components [1:N_COL,1:NC_NN]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I1P), allocatable:: varp(:) !< Packed data. - character(1), allocatable:: var64(:) !< Variable encoded in base64. - integer(I4P):: rf !< Real file index. - integer(I4P):: n1,n2 !< Counters. - integer(I8P):: Nvarp !< Dimension of varp, packed data. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) - do n2=1,NC_NN - write(vtk(rf)%u,'('//trim(str(.true.,N_COL+1))//'A)',iostat=E_IO)repeat(' ',vtk(rf)%indent),& - (' '//str(n=var(n1,n2)),n1=1,N_COL) - enddo - write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = N_COL*NC_NN*BYI4P) - write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I4',N_COL*NC_NN - write(vtk(rf)%ua,iostat=E_IO)var - case(binary) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - Nvarp=size(transfer([int(N_COL*NC_NN*BYI4P,I4P),reshape(var,[N_COL*NC_NN])],varp),kind=I8P) - if (allocated(varp)) deallocate(varp); allocate(varp(1:Nvarp)) - varp = transfer([int(N_COL*NC_NN*BYI4P,I4P),reshape(var,[N_COL*NC_NN])],varp) - call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_LIST_1DA_I4 - - !> Function for saving field of list variable (I4P, 3D array). - !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_LIST_3DA_I4(NC_NN,N_COL,varname,var,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. - integer(I4P), intent(IN):: N_COL !< Number of columns. - character(*), intent(IN):: varname !< Variable name. - integer(I4P), intent(IN):: var(1:,1:,1:,1:) !< Components [1:N_COL,1:Nx,1:Ny,1:Nz]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I1P), allocatable:: varp(:) !< Packed data. - character(1), allocatable:: var64(:) !< Variable encoded in base64. - integer(I4P):: rf !< Real file index. - integer(I4P):: nx,ny,nz,n1 !< Counters. - integer(I8P):: Nvarp !< Dimension of varp, packed data. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) - do nz=1,size(var,dim=4) ; do ny=1,size(var,dim=3) ; do nx=1,size(var,dim=2) - write(vtk(rf)%u,'('//trim(str(.true.,N_COL+1))//'A)',iostat=E_IO)repeat(' ',vtk(rf)%indent),& - (' '//str(n=var(n1,nx,ny,nz)),n1=1,N_COL) - enddo ; enddo ; enddo - write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = N_COL*NC_NN*BYI4P) - write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I4',N_COL*NC_NN - write(vtk(rf)%ua,iostat=E_IO)var - case(binary) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - Nvarp=size(transfer([int(N_COL*NC_NN*BYI4P,I4P),reshape(var,[N_COL*NC_NN])],varp),kind=I8P) - if (allocated(varp)) deallocate(varp); allocate(varp(1:Nvarp)) - varp = transfer([int(N_COL*NC_NN*BYI4P,I4P),reshape(var,[N_COL*NC_NN])],varp) - call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_LIST_3DA_I4 - - !> Function for saving field of list variable (I2P, 1D array). - !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_LIST_1DA_I2(NC_NN,N_COL,varname,var,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. - integer(I4P), intent(IN):: N_COL !< Number of columns. - character(*), intent(IN):: varname !< Variable name. - integer(I2P), intent(IN):: var(1:,1:) !< Components [1:N_COL,1:NC_NN]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I1P), allocatable:: varp(:) !< Packed data. - character(1), allocatable:: var64(:) !< Variable encoded in base64. - integer(I4P):: rf !< Real file index. - integer(I4P):: n1,n2 !< Counters. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) - do n2=1,NC_NN - write(vtk(rf)%u,'('//trim(str(.true.,N_COL+1))//'A)',iostat=E_IO)repeat(' ',vtk(rf)%indent),& - (' '//str(n=var(n1,n2)),n1=1,N_COL) - enddo - write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = N_COL*NC_NN*BYI2P) - write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I2',N_COL*NC_NN - write(vtk(rf)%ua,iostat=E_IO)var - case(binary) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call pack_data(a1=[int(N_COL*NC_NN*BYI2P,I4P)],a2=reshape(var,[N_COL*NC_NN]),packed=varp) - call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_LIST_1DA_I2 - - !> Function for saving field of list variable (I2P, 3D array). - !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_LIST_3DA_I2(NC_NN,N_COL,varname,var,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. - integer(I4P), intent(IN):: N_COL !< Number of columns. - character(*), intent(IN):: varname !< Variable name. - integer(I2P), intent(IN):: var(1:,1:,1:,1:) !< Components [1:N_COL,1:Nx,1:Ny,1:Nz]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I1P), allocatable:: varp(:) !< Packed data. - character(1), allocatable:: var64(:) !< Variable encoded in base64. - integer(I4P):: rf !< Real file index. - integer(I4P):: nx,ny,nz,n1 !< Counters. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) - do nz=1,size(var,dim=4) ; do ny=1,size(var,dim=3) ; do nx=1,size(var,dim=2) - write(vtk(rf)%u,'('//trim(str(.true.,N_COL+1))//'A)',iostat=E_IO)repeat(' ',vtk(rf)%indent),& - (' '//str(n=var(n1,nx,ny,nz)),n1=1,N_COL) - enddo ; enddo ; enddo - write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = N_COL*NC_NN*BYI2P) - write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I2',N_COL*NC_NN - write(vtk(rf)%ua,iostat=E_IO)var - case(binary) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call pack_data(a1=[int(N_COL*NC_NN*BYI2P,I4P)],a2=reshape(var,[N_COL*NC_NN]),packed=varp) - call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_LIST_3DA_I2 - - !> Function for saving field of list variable (I1P, 1D array). - !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_LIST_1DA_I1(NC_NN,N_COL,varname,var,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. - integer(I4P), intent(IN):: N_COL !< Number of columns. - character(*), intent(IN):: varname !< Variable name. - integer(I1P), intent(IN):: var(1:,1:) !< Components [1:N_COL,1:NC_NN]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I1P), allocatable:: varp(:) !< Packed data. - character(1), allocatable:: var64(:) !< Variable encoded in base64. - integer(I4P):: rf !< Real file index. - integer(I4P):: n1,n2 !< Counters. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) - do n2=1,NC_NN - write(vtk(rf)%u,'('//trim(str(.true.,N_COL+1))//'A)',iostat=E_IO)repeat(' ',vtk(rf)%indent),& - (' '//str(n=var(n1,n2)),n1=1,N_COL) - enddo - write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = N_COL*NC_NN*BYI1P) - write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I1',N_COL*NC_NN - write(vtk(rf)%ua,iostat=E_IO)var - case(binary) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call pack_data(a1=[int(N_COL*NC_NN*BYI1P,I4P)],a2=reshape(var,[N_COL*NC_NN]),packed=varp) - call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_LIST_1DA_I1 - - !> Function for saving field of list variable (I1P, 3D array). - !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_LIST_3DA_I1(NC_NN,N_COL,varname,var,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. - integer(I4P), intent(IN):: N_COL !< Number of columns. - character(*), intent(IN):: varname !< Variable name. - integer(I1P), intent(IN):: var(1:,1:,1:,1:) !< Components [1:N_COL,1:Nx,1:Ny,1:Nz]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I1P), allocatable:: varp(:) !< Packed data. - character(1), allocatable:: var64(:) !< Variable encoded in base64. - integer(I4P):: rf !< Real file index. - integer(I4P):: nx,ny,nz,n1 !< Counters. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) - do nz=1,size(var,dim=4) ; do ny=1,size(var,dim=3) ; do nx=1,size(var,dim=2) - write(vtk(rf)%u,'('//trim(str(.true.,N_COL+1))//'A)',iostat=E_IO)repeat(' ',vtk(rf)%indent),& - (' '//str(n=var(n1,nx,ny,nz)),n1=1,N_COL) - enddo ; enddo ; enddo - write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case(raw,bin_app) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call vtk(rf)%byte_update(N_Byte = N_COL*NC_NN*BYI1P) - write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I1',N_COL*NC_NN - write(vtk(rf)%ua,iostat=E_IO)var - case(binary) - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - call pack_data(a1=[int(N_COL*NC_NN*BYI1P,I4P)],a2=reshape(var,[N_COL*NC_NN]),packed=varp) - call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) - write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_LIST_3DA_I1 - !> @} - - !> @brief Function for finalizing the VTK-XML file. - !> @note An example of usage is: \n - !> @code ... - !> E_IO = VTK_END_XML() - !> ... @endcode - !> @return E_IO: integer(I4P) error flag - !> @ingroup Lib_VTK_IOPublicProcedure - function VTK_END_XML(cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(INOUT), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(2):: var_type !< Varable type = R8,R4,I8,I4,I2,I1. - real(R8P), allocatable:: v_R8(:) !< R8 vector for IO in AppendData. - real(R4P), allocatable:: v_R4(:) !< R4 vector for IO in AppendData. - integer(I8P), allocatable:: v_I8(:) !< I8 vector for IO in AppendData. - integer(I4P), allocatable:: v_I4(:) !< I4 vector for IO in AppendData. - integer(I2P), allocatable:: v_I2(:) !< I2 vector for IO in AppendData. - integer(I1P), allocatable:: v_I1(:) !< I1 vector for IO in AppendData. - integer(I1P), allocatable:: varp(:) !< Packed data. - character(1), allocatable:: var64(:) !< Variable encoded in base64. - integer(I4P):: rf !< Real file index. - integer(I8P):: Nvarp !< Dimension of varp, packed data. -#ifdef HUGE - integer(I8P):: N_v !< Vector dimension. - integer(I8P):: n1 !< Counter. -#else - integer(I4P):: N_v !< Vector dimension. - integer(I4P):: n1 !< Counter. -#endif - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - vtk(rf)%indent = vtk(rf)%indent - 2 - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)'' - case(raw,bin_app) - vtk(rf)%indent = vtk(rf)%indent - 2 - write(unit =vtk(rf)%u, iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - if (vtk(rf)%f==raw) then - write(unit =vtk(rf)%u, iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - else - write(unit =vtk(rf)%u, iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - endif - write(unit =vtk(rf)%u, iostat=E_IO)'_' - endfile(unit=vtk(rf)%ua,iostat=E_IO) - rewind(unit =vtk(rf)%ua,iostat=E_IO) - do - read(unit=vtk(rf)%ua,iostat=E_IO,end=100)vtk(rf)%N_Byte,var_type,N_v - select case(var_type) - case('R8') - allocate(v_R8(1:N_v)) - read(unit =vtk(rf)%ua,iostat=E_IO)(v_R8(n1),n1=1,N_v) - if (vtk(rf)%f==raw) then - write(unit=vtk(rf)%u,iostat=E_IO)int(vtk(rf)%N_Byte,I4P),(v_R8(n1),n1=1,N_v) - else - call pack_data(a1=[int(vtk(rf)%N_Byte,I4P)],a2=v_R8,packed=varp) - call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) - write(unit=vtk(rf)%u,iostat=E_IO)tochar(var64) ; deallocate(var64) - endif - deallocate(v_R8) - case('R4') - allocate(v_R4(1:N_v)) - read(unit =vtk(rf)%ua,iostat=E_IO)(v_R4(n1),n1=1,N_v) - if (vtk(rf)%f==raw) then - write(unit=vtk(rf)%u,iostat=E_IO)int(vtk(rf)%N_Byte,I4P),(v_R4(n1),n1=1,N_v) - else - call pack_data(a1=[int(vtk(rf)%N_Byte,I4P)],a2=v_R4,packed=varp) - call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) - write(unit=vtk(rf)%u,iostat=E_IO)tochar(var64) ; deallocate(var64) - endif - deallocate(v_R4) - case('I8') - allocate(v_I8(1:N_v)) - read(unit =vtk(rf)%ua,iostat=E_IO)(v_I8(n1),n1=1,N_v) - if (vtk(rf)%f==raw) then - write(unit=vtk(rf)%u,iostat=E_IO)int(vtk(rf)%N_Byte,I4P),(v_I8(n1),n1=1,N_v) - else - call pack_data(a1=[int(vtk(rf)%N_Byte,I4P)],a2=v_I8,packed=varp) - call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) - write(unit=vtk(rf)%u,iostat=E_IO)tochar(var64) ; deallocate(var64) - endif - deallocate(v_I8) - case('I4') - allocate(v_I4(1:N_v)) - read(unit =vtk(rf)%ua,iostat=E_IO)(v_I4(n1),n1=1,N_v) - if (vtk(rf)%f==raw) then - write(unit=vtk(rf)%u,iostat=E_IO)int(vtk(rf)%N_Byte,I4P),(v_I4(n1),n1=1,N_v) - else - Nvarp=size(transfer([int(vtk(rf)%N_Byte,I4P),v_I4],varp),kind=I8P) - if (allocated(varp)) deallocate(varp); allocate(varp(1:Nvarp)) - varp = transfer([int(vtk(rf)%N_Byte,I4P),v_I4],varp) - call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) - write(unit=vtk(rf)%u,iostat=E_IO)tochar(var64) ; deallocate(var64) - endif - deallocate(v_I4) - case('I2') - allocate(v_I2(1:N_v)) - read(unit =vtk(rf)%ua,iostat=E_IO)(v_I2(n1),n1=1,N_v) - if (vtk(rf)%f==raw) then - write(unit=vtk(rf)%u,iostat=E_IO)int(vtk(rf)%N_Byte,I4P),(v_I2(n1),n1=1,N_v) - else - call pack_data(a1=[int(vtk(rf)%N_Byte,I4P)],a2=v_I2,packed=varp) - call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) - write(unit=vtk(rf)%u,iostat=E_IO)tochar(var64) ; deallocate(var64) - endif - deallocate(v_I2) - case('I1') - allocate(v_I1(1:N_v)) - read(unit =vtk(rf)%ua,iostat=E_IO)(v_I1(n1),n1=1,N_v) - if (vtk(rf)%f==raw) then - write(unit=vtk(rf)%u,iostat=E_IO)int(vtk(rf)%N_Byte,I4P),(v_I1(n1),n1=1,N_v) - else - call pack_data(a1=[int(vtk(rf)%N_Byte,I4P)],a2=v_I1,packed=varp) - call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) - write(unit=vtk(rf)%u,iostat=E_IO)tochar(var64) ; deallocate(var64) - endif - deallocate(v_I1) - case default - E_IO = 1 - write (stderr,'(A)')' bad var_type = '//var_type - write (stderr,'(A)')' N_Byte = '//trim(str(n=vtk(rf)%N_Byte))//' N_v = '//trim(str(n=N_v)) - return - endselect - enddo - 100 continue - write(unit=vtk(rf)%u,iostat=E_IO)end_rec - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - write(unit=vtk(rf)%u,iostat=E_IO)''//end_rec - close(unit=vtk(rf)%ua,iostat=E_IO) - case(binary) - vtk(rf)%indent = vtk(rf)%indent - 2 - write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec - write(unit=vtk(rf)%u,iostat=E_IO)''//end_rec - endselect - close(unit=vtk(rf)%u,iostat=E_IO) - call vtk_update(act='remove',cf=rf,Nvtk=Nvtk,vtk=vtk) - f = rf - if (present(cf)) cf = rf - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_END_XML - - !> The VTK_VTM_XML function is used for initializing a VTM (VTK Multiblocks) XML file that is a wrapper to a set of VTK-XML files. - !> @return E_IO: integer(I4P) error flag - !> @ingroup Lib_VTK_IOPublicProcedure - function VTM_INI_XML(filename) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - character(*), intent(IN):: filename !< File name of output VTM file. - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - if (.not.ir_initialized) call IR_Init - if (endian==endianL) then - s_buffer='' - else - s_buffer='' - endif - open(unit=Get_Unit(vtm%u),file=trim(filename),form='FORMATTED',access='SEQUENTIAL',action='WRITE',status='REPLACE',iostat=E_IO) - write(unit=vtm%u,fmt='(A)',iostat=E_IO)'' - write(unit=vtm%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtm%indent = 2 - write(unit=vtm%u,fmt='(A)',iostat=E_IO)repeat(' ',vtm%indent)//'' ; vtm%indent = vtm%indent + 2 - vtm%blk = -1 - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTM_INI_XML - - !> The VTM_BLK_XML function is used for opening or closing a block level of a VTM file. - !> @return E_IO: integer(I4P) error flag - !> @ingroup Lib_VTK_IOPublicProcedure - function VTM_BLK_XML(block_action) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - character(*), intent(IN):: block_action !< Block action: OPEN or CLOSE block. - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - select case(trim(Upper_Case(block_action))) - case('OPEN') - vtm%blk = vtm%blk + 1 - write(unit=vtm%u,fmt='(A)',iostat=E_IO)repeat(' ',vtm%indent)//'' - vtm%indent = vtm%indent + 2 - case('CLOSE') - vtm%indent = vtm%indent - 2 ; write(unit=vtm%u,fmt='(A)',iostat=E_IO)repeat(' ',vtm%indent)//'' - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTM_BLK_XML - - !> The VTM_WRF_XML function is used for saving the list of VTK-XML wrapped files by the actual block of the mutliblock VTM file. - !> @return E_IO: integer(I4P) error flag - !> @ingroup Lib_VTK_IOPublicProcedure - function VTM_WRF_XML(flist) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - character(*), intent(IN):: flist(:) !< List of VTK-XML wrapped files. - integer(I4P):: E_IO !< Input/Output inquiring flag: 0 if IO is done, > 0 if IO is not done. - integer(I4P):: f !< File counter. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - do f=1,size(flist) - write(unit=vtm%u,fmt='(A)',iostat=E_IO)repeat(' ',vtm%indent)//'' - enddo - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTM_WRF_XML - - !> Function for finalizing open file, it has not inputs, @libvtk manages the file unit without the - !> user's action. - !> @return E_IO: integer(I4P) error flag - !> @ingroup Lib_VTK_IOPublicProcedure - function VTM_END_XML() result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - vtm%indent = vtm%indent - 2 - write(unit=vtm%u,fmt='(A)',iostat=E_IO)repeat(' ',vtm%indent)//'' - write(unit=vtm%u,fmt='(A)',iostat=E_IO)'' - close(unit=vtm%u) - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTM_END_XML - - !> @brief Function for initializing parallel (partitioned) VTK-XML file. - !> @return E_IO: integer(I4P) error flag - !> @ingroup Lib_VTK_IOPublicProcedure - function PVTK_INI_XML(filename,mesh_topology,tp,cf,nx1,nx2,ny1,ny2,nz1,nz2) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - character(*), intent(IN):: filename !< File name. - character(*), intent(IN):: mesh_topology !< Mesh topology. - character(*), intent(IN):: tp !< Type of geometry representation (Float32, Float64, ecc). - integer(I4P), intent(OUT), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P), intent(IN), optional:: nx1 !< Initial node of x axis. - integer(I4P), intent(IN), optional:: nx2 !< Final node of x axis. - integer(I4P), intent(IN), optional:: ny1 !< Initial node of y axis. - integer(I4P), intent(IN), optional:: ny2 !< Final node of y axis. - integer(I4P), intent(IN), optional:: nz1 !< Initial node of z axis. - integer(I4P), intent(IN), optional:: nz2 !< Final node of z axis. - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I4P):: rf !< Real file index. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - if (.not.ir_initialized) call IR_Init - call vtk_update(act='add',cf=rf,Nvtk=Nvtk,vtk=vtk) - f = rf - if (present(cf)) cf = rf - vtk(rf)%topology = trim(mesh_topology) - open(unit=Get_Unit(vtk(rf)%u),file=trim(filename),& - form='FORMATTED',access='SEQUENTIAL',action='WRITE',status='REPLACE',iostat=E_IO) - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)'' - if (endian==endianL) then - s_buffer = '' - else - s_buffer = '' - endif - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(rf)%indent = 2 - select case(trim(vtk(rf)%topology)) - case('PRectilinearGrid') - s_buffer = repeat(' ',vtk(rf)%indent)//'<'//trim(vtk(rf)%topology)//' WholeExtent="'//& - trim(str(n=nx1))//' '//trim(str(n=nx2))//' '// & - trim(str(n=ny1))//' '//trim(str(n=ny2))//' '// & - trim(str(n=nz1))//' '//trim(str(n=nz2))//'" GhostLevel="#">' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(rf)%indent = vtk(rf)%indent + 2 - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent + 2 - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case('PStructuredGrid') - s_buffer = repeat(' ',vtk(rf)%indent)//'<'//trim(vtk(rf)%topology)//' WholeExtent="'//& - trim(str(n=nx1))//' '//trim(str(n=nx2))//' '// & - trim(str(n=ny1))//' '//trim(str(n=ny2))//' '// & - trim(str(n=nz1))//' '//trim(str(n=nz2))//'" GhostLevel="#">' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(rf)%indent = vtk(rf)%indent + 2 - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent + 2 - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) - vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - case('PUnstructuredGrid') - s_buffer = repeat(' ',vtk(rf)%indent)//'<'//trim(vtk(rf)%topology)//' GhostLevel="0">' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(rf)%indent = vtk(rf)%indent + 2 - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent + 2 - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) - vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction PVTK_INI_XML - - !> Function for saving piece geometry source for parallel (partitioned) VTK-XML file. - !> @return E_IO: integer(I4P) error flag - !> @ingroup Lib_VTK_IOPublicProcedure - function PVTK_GEO_XML(source,cf,nx1,nx2,ny1,ny2,nz1,nz2) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - character(*), intent(IN):: source !< Source file name containing the piece data. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P), intent(IN), optional:: nx1 !< Initial node of x axis. - integer(I4P), intent(IN), optional:: nx2 !< Final node of x axis. - integer(I4P), intent(IN), optional:: ny1 !< Initial node of y axis. - integer(I4P), intent(IN), optional:: ny2 !< Final node of y axis. - integer(I4P), intent(IN), optional:: nz1 !< Initial node of z axis. - integer(I4P), intent(IN), optional:: nz2 !< Final node of z axis. - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I4P):: rf !< Real file index. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case (vtk(rf)%topology) - case('PRectilinearGrid','PStructuredGrid') - s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) - case('PUnstructuredGrid') - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction PVTK_GEO_XML - - !> Function that \b must be called before saving the data related to geometric mesh, this function initializes the - !> saving of data variables indicating the \em type (node or cell centered) of variables that will be saved. - !> @ingroup Lib_VTK_IOPublicProcedure - function PVTK_DAT_XML(var_location,var_block_action,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - character(*), intent(IN):: var_location !< Location of saving variables: CELL or NODE centered. - character(*), intent(IN):: var_block_action !< Variables block action: OPEN or CLOSE block. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - integer(I4P):: rf !< Real file index. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(trim(Upper_Case(var_location))) - case('CELL') - select case(trim(Upper_Case(var_block_action))) - case('OPEN') - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent + 2 - case('CLOSE') - vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - endselect - case('NODE') - select case(trim(Upper_Case(var_block_action))) - case('OPEN') - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent + 2 - case('CLOSE') - vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - endselect - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction PVTK_DAT_XML - - !> Function for saving variable associated to nodes or cells geometry. - !> @return E_IO: integer(I4P) error flag - !> @ingroup Lib_VTK_IOPublicProcedure - function PVTK_VAR_XML(varname,tp,cf,Nc) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - character(*), intent(IN):: varname !< Variable name. - character(*), intent(IN):: tp !< Type of data representation (Float32, Float64, ecc). - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P), intent(IN), optional:: Nc !< Number of components of variable. - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I4P):: rf !< Real file index. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - if (present(Nc)) then - s_buffer = repeat(' ',vtk(rf)%indent)//'' - else - s_buffer = repeat(' ',vtk(rf)%indent)//'' - endif - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction PVTK_VAR_XML - - !> @brief Function for finalizing the parallel (partitioned) VTK-XML file. - !> @return E_IO: integer(I4P) error flag - !> @ingroup Lib_VTK_IOPublicProcedure - function PVTK_END_XML(cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(INOUT), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - integer(I4P):: rf !< Real file index. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - vtk(rf)%indent = vtk(rf)%indent - 2 - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)'' - close(unit=vtk(rf)%u,iostat=E_IO) - call vtk_update(act='remove',cf=rf,Nvtk=Nvtk,vtk=vtk) - f = rf - if (present(cf)) cf = rf - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction PVTK_END_XML - - !> @brief Function for initializing VTK-legacy file. - !> @remark This function must be the first to be called. - !> @note An example of usage is: \n - !> @code ... - !> E_IO=VTK_INI('Binary','example.vtk','VTK legacy file','UNSTRUCTURED_GRID') - !> ... @endcode - !> @return E_IO: integer(I4P) error flag - !> @ingroup Lib_VTK_IOPublicProcedure - function VTK_INI(output_format,filename,title,mesh_topology,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - character(*), intent(IN):: output_format !< Output format: ASCII or RAW. - character(*), intent(IN):: filename !< Name of file. - character(*), intent(IN):: title !< Title. - character(*), intent(IN):: mesh_topology !< Mesh topology. - integer(I4P), intent(OUT), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - integer(I4P):: rf !< Real file index. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - if (.not.ir_initialized) call IR_Init - call vtk_update(act='add',cf=rf,Nvtk=Nvtk,vtk=vtk) - f = rf - if (present(cf)) cf = rf - vtk(rf)%topology = trim(mesh_topology) - select case(trim(Upper_Case(output_format))) - case('ASCII') - vtk(rf)%f = ascii - open(unit=Get_Unit(vtk(rf)%u),file=trim(filename),form='FORMATTED',& - access='SEQUENTIAL',action='WRITE',status='REPLACE',iostat=E_IO) - ! writing header of file - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)'# vtk DataFile Version 3.0' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(title) - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(Upper_Case(output_format)) - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)'DATASET '//trim(vtk(rf)%topology) - case('RAW') - vtk(rf)%f = raw - open(unit=Get_Unit(vtk(rf)%u),file=trim(filename),& - form='UNFORMATTED',access='STREAM',action='WRITE',status='REPLACE',iostat=E_IO) - ! writing header of file - write(unit=vtk(rf)%u,iostat=E_IO)'# vtk DataFile Version 3.0'//end_rec - write(unit=vtk(rf)%u,iostat=E_IO)trim(title)//end_rec - write(unit=vtk(rf)%u,iostat=E_IO)trim(Upper_Case(output_format))//end_rec - write(unit=vtk(rf)%u,iostat=E_IO)'DATASET '//trim(vtk(rf)%topology)//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_INI - - !> @ingroup Lib_VTK_IOPrivateProcedure - !> @{ - !> Function for saving mesh with \b STRUCTURED_POINTS topology (R8P). - !> @return E_IO: integer(I4P) error flag - function VTK_GEO_STRP_R8(Nx,Ny,Nz,X0,Y0,Z0,Dx,Dy,Dz,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: Nx !< Number of nodes in x direction. - integer(I4P), intent(IN):: Ny !< Number of nodes in y direction. - integer(I4P), intent(IN):: Nz !< Number of nodes in z direction. - real(R8P), intent(IN):: X0 !< X coordinate of origin. - real(R8P), intent(IN):: Y0 !< Y coordinate of origin. - real(R8P), intent(IN):: Z0 !< Z coordinate of origin. - real(R8P), intent(IN):: Dx !< Space step in x direction. - real(R8P), intent(IN):: Dy !< Space step in y direction. - real(R8P), intent(IN):: Dz !< Space step in z direction. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - integer(I4P):: rf !< Real file index. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - write(vtk(rf)%u,'(A)',iostat=E_IO)'DIMENSIONS '//trim(str(.true.,Nx))//' '//trim(str(.true.,Ny))//' '//trim(str(.true.,Nz)) - write(vtk(rf)%u,'(A)',iostat=E_IO)'ORIGIN '//trim(str(n=X0))//' '//trim(str(n=Y0))//' '//trim(str(n=Z0)) - write(vtk(rf)%u,'(A)',iostat=E_IO)'SPACING '//trim(str(n=Dx))//' '//trim(str(n=Dy))//' '//trim(str(n=Dz)) - case(raw) - write(vtk(rf)%u,iostat=E_IO)'DIMENSIONS '//trim(str(.true.,Nx))//' '//trim(str(.true.,Ny))//' '//trim(str(.true.,Nz))//end_rec - write(vtk(rf)%u,iostat=E_IO)'ORIGIN '//trim(str(n=X0))//' '//trim(str(n=Y0))//' '//trim(str(n=Z0))//end_rec - write(vtk(rf)%u,iostat=E_IO)'SPACING '//trim(str(n=Dx))//' '//trim(str(n=Dy))//' '//trim(str(n=Dz))//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_GEO_STRP_R8 - - !> Function for saving mesh with \b STRUCTURED_POINTS topology (R4P). - !> @return E_IO: integer(I4P) error flag - function VTK_GEO_STRP_R4(Nx,Ny,Nz,X0,Y0,Z0,Dx,Dy,Dz,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: Nx !< Number of nodes in x direction. - integer(I4P), intent(IN):: Ny !< Number of nodes in y direction. - integer(I4P), intent(IN):: Nz !< Number of nodes in z direction. - real(R4P), intent(IN):: X0 !< X coordinate of origin. - real(R4P), intent(IN):: Y0 !< Y coordinate of origin. - real(R4P), intent(IN):: Z0 !< Z coordinate of origin. - real(R4P), intent(IN):: Dx !< Space step in x direction. - real(R4P), intent(IN):: Dy !< Space step in y direction. - real(R4P), intent(IN):: Dz !< Space step in z direction. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - integer(I4P):: rf !< Real file index. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - write(vtk(rf)%u,'(A)',iostat=E_IO)'DIMENSIONS '//trim(str(.true.,Nx))//' '//trim(str(.true.,Ny))//' '//trim(str(.true.,Nz)) - write(vtk(rf)%u,'(A)',iostat=E_IO)'ORIGIN '//trim(str(n=X0))//' '//trim(str(n=Y0))//' '//trim(str(n=Z0)) - write(vtk(rf)%u,'(A)',iostat=E_IO)'SPACING '//trim(str(n=Dx))//' '//trim(str(n=Dy))//' '//trim(str(n=Dz)) - case(raw) - write(vtk(rf)%u,iostat=E_IO)'DIMENSIONS '//trim(str(.true.,Nx))//' '//trim(str(.true.,Ny))//' '//trim(str(.true.,Nz))//end_rec - write(vtk(rf)%u,iostat=E_IO)'ORIGIN '//trim(str(n=X0))//' '//trim(str(n=Y0))//' '//trim(str(n=Z0))//end_rec - write(vtk(rf)%u,iostat=E_IO)'SPACING '//trim(str(n=Dx))//' '//trim(str(n=Dy))//' '//trim(str(n=Dz))//end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_GEO_STRP_R4 - - !> Function for saving mesh with \b STRUCTURED_GRID topology (R8P, 1D arrays). - !> @return E_IO: integer(I4P) error flag - function VTK_GEO_STRG_1DA_R8(Nx,Ny,Nz,NN,X,Y,Z,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: Nx !< Number of nodes in x direction. - integer(I4P), intent(IN):: Ny !< Number of nodes in y direction. - integer(I4P), intent(IN):: Nz !< Number of nodes in z direction. - integer(I4P), intent(IN):: NN !< Number of all nodes. - real(R8P), intent(IN):: X(1:) !< X coordinates [1:NN]. - real(R8P), intent(IN):: Y(1:) !< Y coordinates [1:NN]. - real(R8P), intent(IN):: Z(1:) !< Z coordinates [1:NN]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - integer(I4P):: rf !< Real file index. - integer(I4P):: n1 !< Counter. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - write(vtk(rf)%u,'(A)',iostat=E_IO)'DIMENSIONS '//trim(str(.true.,Nx))//' '//trim(str(.true.,Ny))//' '//trim(str(.true.,Nz)) - write(vtk(rf)%u,'(A)',iostat=E_IO)'POINTS '//trim(str(.true.,NN))//' double' - do n1=1,NN - write(vtk(rf)%u,'(A)',iostat=E_IO)str(n=X(n1))//' '//str(n=Y(n1))//' '//str(n=Z(n1)) - enddo - case(raw) - write(vtk(rf)%u,iostat=E_IO)'DIMENSIONS '//trim(str(.true.,Nx))//' '//trim(str(.true.,Ny))//' '//trim(str(.true.,Nz))//end_rec - write(vtk(rf)%u,iostat=E_IO)'POINTS '//trim(str(.true.,NN))//' double'//end_rec - write(vtk(rf)%u,iostat=E_IO)(X(n1),Y(n1),Z(n1),n1=1,NN) - write(vtk(rf)%u,iostat=E_IO)end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_GEO_STRG_1DA_R8 - - !> Function for saving mesh with \b STRUCTURED_GRID topology (R8P, 1D arrays, packed API). - !> @return E_IO: integer(I4P) error flag - function VTK_GEO_STRG_1DAP_R8(Nx,Ny,Nz,NN,XYZ,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: Nx !< Number of nodes in x direction. - integer(I4P), intent(IN):: Ny !< Number of nodes in y direction. - integer(I4P), intent(IN):: Nz !< Number of nodes in z direction. - integer(I4P), intent(IN):: NN !< Number of all nodes. - real(R8P), intent(IN):: XYZ(1:,1:) !< X, Y and Z coordinates [1:3,1:NN]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - integer(I4P):: rf !< Real file index. - integer(I4P):: n1 !< Counter. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - write(vtk(rf)%u,'(A)',iostat=E_IO)'DIMENSIONS '//trim(str(.true.,Nx))//' '//trim(str(.true.,Ny))//' '//trim(str(.true.,Nz)) - write(vtk(rf)%u,'(A)',iostat=E_IO)'POINTS '//trim(str(.true.,NN))//' double' - do n1=1,NN - write(vtk(rf)%u,'(A)',iostat=E_IO)str(n=XYZ(1,n1))//' '//str(n=XYZ(2,n1))//' '//str(n=XYZ(3,n1)) - enddo - case(raw) - write(vtk(rf)%u,iostat=E_IO)'DIMENSIONS '//trim(str(.true.,Nx))//' '//trim(str(.true.,Ny))//' '//trim(str(.true.,Nz))//end_rec - write(vtk(rf)%u,iostat=E_IO)'POINTS '//trim(str(.true.,NN))//' double'//end_rec - write(vtk(rf)%u,iostat=E_IO)XYZ - write(vtk(rf)%u,iostat=E_IO)end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_GEO_STRG_1DAP_R8 - - !> Function for saving mesh with \b STRUCTURED_GRID topology (R8P, 3D arrays). - !> @return E_IO: integer(I4P) error flag - function VTK_GEO_STRG_3DA_R8(Nx,Ny,Nz,NN,X,Y,Z,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: Nx !< Number of nodes in x direction. - integer(I4P), intent(IN):: Ny !< Number of nodes in y direction. - integer(I4P), intent(IN):: Nz !< Number of nodes in z direction. - integer(I4P), intent(IN):: NN !< Number of all nodes. - real(R8P), intent(IN):: X(1:,1:,1:) !< X coordinates [1:Nx,1:Ny,1:Nz]. - real(R8P), intent(IN):: Y(1:,1:,1:) !< Y coordinates [1:Nx,1:Ny,1:Nz]. - real(R8P), intent(IN):: Z(1:,1:,1:) !< Z coordinates [1:Nx,1:Ny,1:Nz]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - integer(I4P):: rf !< Real file index. - integer(I4P):: n1,n2,n3 !< Counters. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - write(vtk(rf)%u,'(A)',iostat=E_IO)'DIMENSIONS '//trim(str(.true.,Nx))//' '//trim(str(.true.,Ny))//' '//trim(str(.true.,Nz)) - write(vtk(rf)%u,'(A)',iostat=E_IO)'POINTS '//trim(str(.true.,NN))//' double' - do n3=1,Nz - do n2=1,Ny - do n1=1,Nx - write(vtk(rf)%u,'(A)',iostat=E_IO)str(n=X(n1,n2,n3))//' '//str(n=Y(n1,n2,n3))//' '//str(n=Z(n1,n2,n3)) - enddo - enddo - enddo - case(raw) - write(vtk(rf)%u,iostat=E_IO)'DIMENSIONS '//trim(str(.true.,Nx))//' '//trim(str(.true.,Ny))//' '//trim(str(.true.,Nz))//end_rec - write(vtk(rf)%u,iostat=E_IO)'POINTS '//trim(str(.true.,NN))//' double'//end_rec - write(vtk(rf)%u,iostat=E_IO)(((X(n1,n2,n3),Y(n1,n2,n3),Z(n1,n2,n3),n1=1,Nx),n2=1,Ny),n3=1,Nz) - write(vtk(rf)%u,iostat=E_IO)end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_GEO_STRG_3DA_R8 - - !> Function for saving mesh with \b STRUCTURED_GRID topology (R8P, 3D arrays, packed API). - !> @return E_IO: integer(I4P) error flag - function VTK_GEO_STRG_3DAP_R8(Nx,Ny,Nz,NN,XYZ,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: Nx !< Number of nodes in x direction. - integer(I4P), intent(IN):: Ny !< Number of nodes in y direction. - integer(I4P), intent(IN):: Nz !< Number of nodes in z direction. - integer(I4P), intent(IN):: NN !< Number of all nodes. - real(R8P), intent(IN):: XYZ(1:,1:,1:,1:) !< X, Y and Z coordinates [1:3,1:Nx,1:Ny,1:Nz]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - integer(I4P):: rf !< Real file index. - integer(I4P):: n1,n2,n3 !< Counters. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - write(vtk(rf)%u,'(A)',iostat=E_IO)'DIMENSIONS '//trim(str(.true.,Nx))//' '//trim(str(.true.,Ny))//' '//trim(str(.true.,Nz)) - write(vtk(rf)%u,'(A)',iostat=E_IO)'POINTS '//trim(str(.true.,NN))//' double' - do n3=1,Nz - do n2=1,Ny - do n1=1,Nx - write(vtk(rf)%u,'(A)',iostat=E_IO)str(n=XYZ(1,n1,n2,n3))//' '//str(n=XYZ(2,n1,n2,n3))//' '//str(n=XYZ(3,n1,n2,n3)) - enddo - enddo - enddo - case(raw) - write(vtk(rf)%u,iostat=E_IO)'DIMENSIONS '//trim(str(.true.,Nx))//' '//trim(str(.true.,Ny))//' '//trim(str(.true.,Nz))//end_rec - write(vtk(rf)%u,iostat=E_IO)'POINTS '//trim(str(.true.,NN))//' double'//end_rec - write(vtk(rf)%u,iostat=E_IO)XYZ - write(vtk(rf)%u,iostat=E_IO)end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_GEO_STRG_3DAP_R8 - - !> Function for saving mesh with \b STRUCTURED_GRID topology (R4P, 1D arrays). - !> @return E_IO: integer(I4P) error flag - function VTK_GEO_STRG_1DA_R4(Nx,Ny,Nz,NN,X,Y,Z,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: Nx !< Number of nodes in x direction. - integer(I4P), intent(IN):: Ny !< Number of nodes in y direction. - integer(I4P), intent(IN):: Nz !< Number of nodes in z direction. - integer(I4P), intent(IN):: NN !< Number of all nodes. - real(R4P), intent(IN):: X(1:) !< X coordinates [1:NN]. - real(R4P), intent(IN):: Y(1:) !< Y coordinates [1:NN]. - real(R4P), intent(IN):: Z(1:) !< Z coordinates [1:NN]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - integer(I4P):: rf !< Real file index. - integer(I4P):: n1 !< Counter. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - write(vtk(rf)%u,'(A)',iostat=E_IO)'DIMENSIONS '//trim(str(.true.,Nx))//' '//trim(str(.true.,Ny))//' '//trim(str(.true.,Nz)) - write(vtk(rf)%u,'(A)',iostat=E_IO)'POINTS '//trim(str(.true.,NN))//' float' - do n1=1,NN - write(vtk(rf)%u,'(A)',iostat=E_IO)str(n=X(n1))//' '//str(n=Y(n1))//' '//str(n=Z(n1)) - enddo - case(raw) - write(vtk(rf)%u,iostat=E_IO)'DIMENSIONS '//trim(str(.true.,Nx))//' '//trim(str(.true.,Ny))//' '//trim(str(.true.,Nz))//end_rec - write(vtk(rf)%u,iostat=E_IO)'POINTS '//trim(str(.true.,NN))//' float'//end_rec - write(vtk(rf)%u,iostat=E_IO)(X(n1),Y(n1),Z(n1),n1=1,NN) - write(vtk(rf)%u,iostat=E_IO)end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_GEO_STRG_1DA_R4 - - !> Function for saving mesh with \b STRUCTURED_GRID topology (R4P, 1D arrays, packed API). - !> @return E_IO: integer(I4P) error flag - function VTK_GEO_STRG_1DAP_R4(Nx,Ny,Nz,NN,XYZ,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: Nx !< Number of nodes in x direction. - integer(I4P), intent(IN):: Ny !< Number of nodes in y direction. - integer(I4P), intent(IN):: Nz !< Number of nodes in z direction. - integer(I4P), intent(IN):: NN !< Number of all nodes. - real(R4P), intent(IN):: XYZ(1:,1:) !< X, Y and Z coordinates [1:3,1:NN]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - integer(I4P):: rf !< Real file index. - integer(I4P):: n1 !< Counter. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - write(vtk(rf)%u,'(A)',iostat=E_IO)'DIMENSIONS '//trim(str(.true.,Nx))//' '//trim(str(.true.,Ny))//' '//trim(str(.true.,Nz)) - write(vtk(rf)%u,'(A)',iostat=E_IO)'POINTS '//trim(str(.true.,NN))//' float' - do n1=1,NN - write(vtk(rf)%u,'(A)',iostat=E_IO)str(n=XYZ(1,n1))//' '//str(n=XYZ(2,n1))//' '//str(n=XYZ(3,n1)) - enddo - case(raw) - write(vtk(rf)%u,iostat=E_IO)'DIMENSIONS '//trim(str(.true.,Nx))//' '//trim(str(.true.,Ny))//' '//trim(str(.true.,Nz))//end_rec - write(vtk(rf)%u,iostat=E_IO)'POINTS '//trim(str(.true.,NN))//' float'//end_rec - write(vtk(rf)%u,iostat=E_IO)XYZ - write(vtk(rf)%u,iostat=E_IO)end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_GEO_STRG_1DAP_R4 - - !> Function for saving mesh with \b STRUCTURED_GRID topology (R4P, 3D arrays). - !> @return E_IO: integer(I4P) error flag - function VTK_GEO_STRG_3DA_R4(Nx,Ny,Nz,NN,X,Y,Z,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: Nx !< Number of nodes in x direction. - integer(I4P), intent(IN):: Ny !< Number of nodes in y direction. - integer(I4P), intent(IN):: Nz !< Number of nodes in z direction. - integer(I4P), intent(IN):: NN !< Number of all nodes. - real(R4P), intent(IN):: X(1:,1:,1:) !< X coordinates [1:Nx,1:Ny,1:Nz]. - real(R4P), intent(IN):: Y(1:,1:,1:) !< Y coordinates [1:Nx,1:Ny,1:Nz]. - real(R4P), intent(IN):: Z(1:,1:,1:) !< Z coordinates [1:Nx,1:Ny,1:Nz]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - integer(I4P):: rf !< Real file index. - integer(I4P):: n1,n2,n3 !< Counters. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - write(vtk(rf)%u,'(A)',iostat=E_IO)'DIMENSIONS '//trim(str(.true.,Nx))//' '//trim(str(.true.,Ny))//' '//trim(str(.true.,Nz)) - write(vtk(rf)%u,'(A)',iostat=E_IO)'POINTS '//trim(str(.true.,NN))//' float' - do n3=1,Nz - do n2=1,Ny - do n1=1,Nx - write(vtk(rf)%u,'(A)',iostat=E_IO)str(n=X(n1,n2,n3))//' '//str(n=Y(n1,n2,n3))//' '//str(n=Z(n1,n2,n3)) - enddo - enddo - enddo - case(raw) - write(vtk(rf)%u,iostat=E_IO)'DIMENSIONS '//trim(str(.true.,Nx))//' '//trim(str(.true.,Ny))//' '//trim(str(.true.,Nz))//end_rec - write(vtk(rf)%u,iostat=E_IO)'POINTS '//trim(str(.true.,NN))//' float'//end_rec - write(vtk(rf)%u,iostat=E_IO)(((X(n1,n2,n3),Y(n1,n2,n3),Z(n1,n2,n3),n1=1,Nx),n2=1,Ny),n3=1,Nz) - write(vtk(rf)%u,iostat=E_IO)end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_GEO_STRG_3DA_R4 - - !> Function for saving mesh with \b STRUCTURED_GRID topology (R4P, 3D arrays, packed API). - !> @return E_IO: integer(I4P) error flag - function VTK_GEO_STRG_3DAP_R4(Nx,Ny,Nz,NN,XYZ,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: Nx !< Number of nodes in x direction. - integer(I4P), intent(IN):: Ny !< Number of nodes in y direction. - integer(I4P), intent(IN):: Nz !< Number of nodes in z direction. - integer(I4P), intent(IN):: NN !< Number of all nodes. - real(R4P), intent(IN):: XYZ(1:,1:,1:,1:) !< X, Y and Z coordinates [1:3,1:Nx,1:Ny,1:Nz]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - integer(I4P):: rf !< Real file index. - integer(I4P):: n1,n2,n3 !< Counters. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - write(vtk(rf)%u,'(A)',iostat=E_IO)'DIMENSIONS '//trim(str(.true.,Nx))//' '//trim(str(.true.,Ny))//' '//trim(str(.true.,Nz)) - write(vtk(rf)%u,'(A)',iostat=E_IO)'POINTS '//trim(str(.true.,NN))//' float' - do n3=1,Nz - do n2=1,Ny - do n1=1,Nx - write(vtk(rf)%u,'(A)',iostat=E_IO)str(n=XYZ(1,n1,n2,n3))//' '//str(n=XYZ(2,n1,n2,n3))//' '//str(n=XYZ(3,n1,n2,n3)) - enddo - enddo - enddo - case(raw) - write(vtk(rf)%u,iostat=E_IO)'DIMENSIONS '//trim(str(.true.,Nx))//' '//trim(str(.true.,Ny))//' '//trim(str(.true.,Nz))//end_rec - write(vtk(rf)%u,iostat=E_IO)'POINTS '//trim(str(.true.,NN))//' float'//end_rec - write(vtk(rf)%u,iostat=E_IO)XYZ - write(vtk(rf)%u,iostat=E_IO)end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_GEO_STRG_3DAP_R4 - - !> Function for saving mesh with \b RECTILINEAR_GRID topology (R8P). - !> @return E_IO: integer(I4P) error flag - function VTK_GEO_RECT_R8(Nx,Ny,Nz,X,Y,Z,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: Nx !< Number of nodes in x direction. - integer(I4P), intent(IN):: Ny !< Number of nodes in y direction. - integer(I4P), intent(IN):: Nz !< Number of nodes in z direction. - real(R8P), intent(IN):: X(1:Nx) !< X coordinates. - real(R8P), intent(IN):: Y(1:Ny) !< Y coordinates. - real(R8P), intent(IN):: Z(1:Nz) !< Z coordinates. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - integer(I4P):: rf !< Real file index. - integer(I4P):: n1 !< Counter. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - write(vtk(rf)%u,'(A)',iostat=E_IO)'DIMENSIONS '//trim(str(.true.,Nx))//' '//trim(str(.true.,Ny))//' '//trim(str(.true.,Nz)) - write(vtk(rf)%u,'(A)',iostat=E_IO)'X_COORDINATES '//trim(str(.true.,Nx))//' double' - do n1=1,Nx - write(vtk(rf)%u,'(A)',iostat=E_IO)str(n=X(n1)) - enddo - write(vtk(rf)%u,'(A)',iostat=E_IO)'Y_COORDINATES '//trim(str(.true.,Ny))//' double' - do n1=1,Ny - write(vtk(rf)%u,'(A)',iostat=E_IO)str(n=Y(n1)) - enddo - write(vtk(rf)%u,'(A)',iostat=E_IO)'Z_COORDINATES '//trim(str(.true.,Nz))//' double' - do n1=1,Nz - write(vtk(rf)%u,'(A)',iostat=E_IO)str(n=Z(n1)) - enddo - case(raw) - write(vtk(rf)%u,iostat=E_IO)'DIMENSIONS '//trim(str(.true.,Nx))//' '//trim(str(.true.,Ny))//' '//trim(str(.true.,Nz))//end_rec - write(vtk(rf)%u,iostat=E_IO)'X_COORDINATES '//trim(str(.true.,Nx))//' double'//end_rec - write(vtk(rf)%u,iostat=E_IO)X - write(vtk(rf)%u,iostat=E_IO)end_rec - write(vtk(rf)%u,iostat=E_IO)'Y_COORDINATES '//trim(str(.true.,Ny))//' double'//end_rec - write(vtk(rf)%u,iostat=E_IO)Y - write(vtk(rf)%u,iostat=E_IO)end_rec - write(vtk(rf)%u,iostat=E_IO)'Z_COORDINATES '//trim(str(.true.,Nz))//' double'//end_rec - write(vtk(rf)%u,iostat=E_IO)Z - write(vtk(rf)%u,iostat=E_IO)end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_GEO_RECT_R8 - - !> Function for saving mesh with \b RECTILINEAR_GRID topology (R4P). - !> @return E_IO: integer(I4P) error flag - function VTK_GEO_RECT_R4(Nx,Ny,Nz,X,Y,Z,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: Nx !< Number of nodes in x direction. - integer(I4P), intent(IN):: Ny !< Number of nodes in y direction. - integer(I4P), intent(IN):: Nz !< Number of nodes in z direction. - real(R4P), intent(IN):: X(1:Nx) !< X coordinates. - real(R4P), intent(IN):: Y(1:Ny) !< Y coordinates. - real(R4P), intent(IN):: Z(1:Nz) !< Z coordinates. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - integer(I4P):: rf !< Real file index. - integer(I4P):: n1 !< Counter. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - write(vtk(rf)%u,'(A)',iostat=E_IO)'DIMENSIONS '//trim(str(.true.,Nx))//' '//trim(str(.true.,Ny))//' '//trim(str(.true.,Nz)) - write(vtk(rf)%u,'(A)',iostat=E_IO)'X_COORDINATES '//trim(str(.true.,Nx))//' float' - do n1=1,Nx - write(vtk(rf)%u,'(A)',iostat=E_IO)str(n=X(n1)) - enddo - write(vtk(rf)%u,'(A)',iostat=E_IO)'Y_COORDINATES '//trim(str(.true.,Ny))//' float' - do n1=1,Ny - write(vtk(rf)%u,'(A)',iostat=E_IO)str(n=Y(n1)) - enddo - write(vtk(rf)%u,'(A)',iostat=E_IO)'Z_COORDINATES '//trim(str(.true.,Nz))//' float' - do n1=1,Nz - write(vtk(rf)%u,'(A)',iostat=E_IO)str(n=Z(n1)) - enddo - case(raw) - write(vtk(rf)%u,iostat=E_IO)'DIMENSIONS '//trim(str(.true.,Nx))//' '//trim(str(.true.,Ny))//' '//trim(str(.true.,Nz))//end_rec - write(vtk(rf)%u,iostat=E_IO)'X_COORDINATES '//trim(str(.true.,Nx))//' float'//end_rec - write(vtk(rf)%u,iostat=E_IO)X - write(vtk(rf)%u,iostat=E_IO)end_rec - write(vtk(rf)%u,iostat=E_IO)'Y_COORDINATES '//trim(str(.true.,Ny))//' float'//end_rec - write(vtk(rf)%u,iostat=E_IO)Y - write(vtk(rf)%u,iostat=E_IO)end_rec - write(vtk(rf)%u,iostat=E_IO)'Z_COORDINATES '//trim(str(.true.,Nz))//' float'//end_rec - write(vtk(rf)%u,iostat=E_IO)Z - write(vtk(rf)%u,iostat=E_IO)end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_GEO_RECT_R4 - - !> Function for saving mesh with \b UNSTRUCTURED_GRID topology (R8P). - !> @return E_IO: integer(I4P) error flag - function VTK_GEO_UNST_R8(NN,X,Y,Z,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NN !< Number of nodes. - real(R8P), intent(IN):: X(1:) !< X coordinates of all nodes [1:NN]. - real(R8P), intent(IN):: Y(1:) !< Y coordinates of all nodes [1:NN]. - real(R8P), intent(IN):: Z(1:) !< Z coordinates of all nodes [1:NN]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - integer(I4P):: rf !< Real file index. - integer(I4P):: n1 !< Counter. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)'POINTS '//str(.true.,NN)//' double' - do n1=1,NN - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)str(n=X(n1))//' '//str(n=Y(n1))//' '//str(n=Z(n1)) - enddo - case(raw) - write(unit=vtk(rf)%u,iostat=E_IO)'POINTS '//str(.true.,NN)//' double'//end_rec - write(unit=vtk(rf)%u,iostat=E_IO)(X(n1),Y(n1),Z(n1),n1=1,NN) - write(unit=vtk(rf)%u,iostat=E_IO)end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_GEO_UNST_R8 - - !> Function for saving mesh with \b UNSTRUCTURED_GRID topology (R8P, packed API). - !> @return E_IO: integer(I4P) error flag - function VTK_GEO_UNST_P_R8(NN,XYZ,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NN !< Number of nodes. - real(R8P), intent(IN):: XYZ(1:,1:) !< X, Y and Z coordinates of all nodes [1:3,1:NN]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - integer(I4P):: rf !< Real file index. - integer(I4P):: n1 !< Counter. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)'POINTS '//str(.true.,NN)//' double' - do n1=1,NN - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)str(n=XYZ(1,n1))//' '//str(n=XYZ(2,n1))//' '//str(n=XYZ(3,n1)) - enddo - case(raw) - write(unit=vtk(rf)%u,iostat=E_IO)'POINTS '//str(.true.,NN)//' double'//end_rec - write(unit=vtk(rf)%u,iostat=E_IO)XYZ - write(unit=vtk(rf)%u,iostat=E_IO)end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_GEO_UNST_P_R8 - - !> Function for saving mesh with \b UNSTRUCTURED_GRID topology (R4P). - !> @return E_IO: integer(I4P) error flag - function VTK_GEO_UNST_R4(NN,X,Y,Z,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NN !< number of nodes. - real(R4P), intent(IN):: X(1:) !< X coordinates of all nodes [1:NN]. - real(R4P), intent(IN):: Y(1:) !< Y coordinates of all nodes [1:NN]. - real(R4P), intent(IN):: Z(1:) !< Z coordinates of all nodes [1:NN]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - integer(I4P):: rf !< Real file index. - integer(I4P):: n1 !< counter. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)'POINTS '//str(.true.,NN)//' float' - do n1=1,NN - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)str(n=X(n1))//' '//str(n=Y(n1))//' '//str(n=Z(n1)) - enddo - case(raw) - write(unit=vtk(rf)%u,iostat=E_IO)'POINTS '//str(.true.,NN)//' float'//end_rec - write(unit=vtk(rf)%u,iostat=E_IO)(X(n1),Y(n1),Z(n1),n1=1,NN) - write(unit=vtk(rf)%u,iostat=E_IO)end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_GEO_UNST_R4 - - !> Function for saving mesh with \b UNSTRUCTURED_GRID topology (R4P, packed API). - !> @return E_IO: integer(I4P) error flag - function VTK_GEO_UNST_P_R4(NN,XYZ,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NN !< number of nodes. - real(R4P), intent(IN):: XYZ(1:,1:) !< X, Y and Z coordinates of all nodes [1:3,1:NN]. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - integer(I4P):: rf !< Real file index. - integer(I4P):: n1 !< counter. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)'POINTS '//str(.true.,NN)//' float' - do n1=1,NN - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)str(n=XYZ(1,n1))//' '//str(n=XYZ(2,n1))//' '//str(n=XYZ(3,n1)) - enddo - case(raw) - write(unit=vtk(rf)%u,iostat=E_IO)'POINTS '//str(.true.,NN)//' float'//end_rec - write(unit=vtk(rf)%u,iostat=E_IO)XYZ - write(unit=vtk(rf)%u,iostat=E_IO)end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_GEO_UNST_P_R4 - !> @} - - !> Function that \b must be used when unstructured grid is used, it saves the connectivity of the unstructured gird. - !> @note The vector \b connect must follow the VTK-legacy standard. It is passed as \em assumed-shape array - !> because its dimensions is related to the mesh dimensions in a complex way. Its dimensions can be calculated by the following - !> equation: \f$dc = NC + \sum\limits_{i = 1}^{NC} {nvertex_i }\f$ - !> where \f$dc\f$ is connectivity vector dimension and \f$nvertex_i\f$ is the number of vertices of \f$i^{th}\f$ cell. The VTK- - !> legacy standard for the mesh connectivity is quite obscure at least at first sight. It is more simple analyzing an example. - !> Suppose we have a mesh composed by 2 cells, one hexahedron (8 vertices) and one pyramid with square basis (5 vertices) and - !> suppose that the basis of pyramid is constitute by a face of the hexahedron and so the two cells share 4 vertices. - !> The above equation !> gives \f$dc=2+8+5=15\f$. The connectivity vector for this mesh can be: \n - !> first cell \n - !> connect(1) = 8 number of vertices of \f$1^\circ\f$ cell \n - !> connect(2) = 0 identification flag of \f$1^\circ\f$ vertex of 1° cell \n - !> connect(3) = 1 identification flag of \f$2^\circ\f$ vertex of 1° cell \n - !> connect(4) = 2 identification flag of \f$3^\circ\f$ vertex of 1° cell \n - !> connect(5) = 3 identification flag of \f$4^\circ\f$ vertex of 1° cell \n - !> connect(6) = 4 identification flag of \f$5^\circ\f$ vertex of 1° cell \n - !> connect(7) = 5 identification flag of \f$6^\circ\f$ vertex of 1° cell \n - !> connect(8) = 6 identification flag of \f$7^\circ\f$ vertex of 1° cell \n - !> connect(9) = 7 identification flag of \f$8^\circ\f$ vertex of 1° cell \n - !> second cell \n - !> connect(10) = 5 number of vertices of \f$2^\circ \f$cell \n - !> connect(11) = 0 identification flag of \f$1^\circ\f$ vertex of 2° cell \n - !> connect(12) = 1 identification flag of \f$2^\circ\f$ vertex of 2° cell \n - !> connect(13) = 2 identification flag of \f$3^\circ\f$ vertex of 2° cell \n - !> connect(14) = 3 identification flag of \f$4^\circ\f$ vertex of 2° cell \n - !> connect(15) = 8 identification flag of \f$5^\circ\f$ vertex of 2° cell \n - !> Note that the first 4 identification flags of pyramid vertices as the same of the first 4 identification flags of - !> the hexahedron because the two cells share this face. It is also important to note that the identification flags start - !> form $0$ value: this is impose to the VTK standard. The function VTK_CON does not calculate the connectivity vector: it - !> writes the connectivity vector conforming the VTK standard, but does not calculate it. - !> The vector variable \em cell_type must conform the VTK-legacy standard (see the file VTK-Standard at the - !> Kitware homepage). It contains the - !> \em type of each cells. For the above example this vector is: \n - !> first cell \n - !> cell_type(1) = 12 hexahedron type of \f$1^\circ\f$ cell \n - !> second cell \n - !> cell_type(2) = 14 pyramid type of \f$2^\circ\f$ cell \n - !> @return E_IO: integer(I4P) error flag - !> @ingroup Lib_VTK_IOPublicProcedure - function VTK_CON(NC,connect,cell_type,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NC !< Number of cells. - integer(I4P), intent(IN):: connect(:) !< Mesh connectivity. - integer(I4P), intent(IN):: cell_type(1:NC) !< VTK cell type. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I4P):: ncon !< Dimension of connectivity vector. - integer(I4P):: rf !< Real file index. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - ncon = size(connect,1) - select case(vtk(rf)%f) - case(ascii) - write(unit=vtk(rf)%u,fmt='(A,2'//FI4P//')',iostat=E_IO)'CELLS ',NC,ncon - write(unit=vtk(rf)%u,fmt=FI4P, iostat=E_IO)connect - write(unit=vtk(rf)%u,fmt='(A,'//FI4P//')', iostat=E_IO)'CELL_TYPES ',NC - write(unit=vtk(rf)%u,fmt=FI4P, iostat=E_IO)cell_type - case(raw) - write(s_buffer, fmt='(A,2'//FI4P//')',iostat=E_IO)'CELLS ',NC,ncon - write(unit=vtk(rf)%u, iostat=E_IO)trim(s_buffer)//end_rec - write(unit=vtk(rf)%u, iostat=E_IO)connect - write(unit=vtk(rf)%u, iostat=E_IO)end_rec - write(s_buffer, fmt='(A,'//FI4P//')', iostat=E_IO)'CELL_TYPES ',NC - write(unit=vtk(rf)%u, iostat=E_IO)trim(s_buffer)//end_rec - write(unit=vtk(rf)%u, iostat=E_IO)cell_type - write(unit=vtk(rf)%u, iostat=E_IO)end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_CON - - !> Function that \b must be called before saving the data related to geometric mesh, this function initializes the - !> saving of data variables indicating the \em type (node or cell centered) of variables that will be saved. - !> @note A single file can contain both cell and node centered variables. In this case the VTK_DAT function must be - !> called two times, before saving cell-centered variables and before saving node-centered variables. - !> Examples of usage are: \n - !> \b Node piece: \n - !> @code ... - !> E_IO=VTK_DAT(50,'node') - !> ... @endcode - !> \b Cell piece: \n - !> @code ... - !> E_IO=VTK_DAT(50,'cell') - !> ... @endcode - !> @return E_IO: integer(I4P) error flag - !> @ingroup Lib_VTK_IOPublicProcedure - function VTK_DAT(NC_NN,var_location,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes of field. - character(*), intent(IN):: var_location !< Location of saving variables: cell for cell-centered, node for node-centered. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I4P):: rf !< Real file index. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - select case(trim(Upper_Case(var_location))) - case('CELL') - write(unit=vtk(rf)%u,fmt='(A,'//FI4P//')',iostat=E_IO)'CELL_DATA ',NC_NN - case('NODE') - write(unit=vtk(rf)%u,fmt='(A,'//FI4P//')',iostat=E_IO)'POINT_DATA ',NC_NN - endselect - case(raw) - select case(trim(Upper_Case(var_location))) - case('CELL') - write(s_buffer,fmt='(A,'//FI4P//')',iostat=E_IO)'CELL_DATA ',NC_NN - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - case('NODE') - write(s_buffer,fmt='(A,'//FI4P//')',iostat=E_IO)'POINT_DATA ',NC_NN - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - endselect - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_DAT - - !> @ingroup Lib_VTK_IOPrivateProcedure - !> @{ - !> Function for saving field of scalar variable (R8P). - !> @return E_IO: integer(I4P) error flag - function VTK_VAR_SCAL_R8(NC_NN,varname,var,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NC_NN !< Number of nodes or cells. - character(*), intent(IN):: varname !< Variable name. - real(R8P), intent(IN):: var(1:NC_NN) !< Variable to be saved. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - integer(I4P):: rf !< Real file index. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)'SCALARS '//trim(varname)//' double 1' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)'LOOKUP_TABLE default' - write(unit=vtk(rf)%u,fmt=FR8P, iostat=E_IO)var - case(raw) - write(unit=vtk(rf)%u,iostat=E_IO)'SCALARS '//trim(varname)//' double 1'//end_rec - write(unit=vtk(rf)%u,iostat=E_IO)'LOOKUP_TABLE default'//end_rec - write(unit=vtk(rf)%u,iostat=E_IO)var - write(unit=vtk(rf)%u,iostat=E_IO)end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_SCAL_R8 - - !> Function for saving field of scalar variable (R4P). - !> @return E_IO: integer(I4P) error flag - function VTK_VAR_SCAL_R4(NC_NN,varname,var,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NC_NN !< Number of nodes or cells. - character(*), intent(IN):: varname !< Variable name. - real(R4P), intent(IN):: var(1:NC_NN) !< Variable to be saved. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - integer(I4P):: rf !< Real file index. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)'SCALARS '//trim(varname)//' float 1' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)'LOOKUP_TABLE default' - write(unit=vtk(rf)%u,fmt=FR4P, iostat=E_IO)var - case(raw) - write(unit=vtk(rf)%u,iostat=E_IO)'SCALARS '//trim(varname)//' float 1'//end_rec - write(unit=vtk(rf)%u,iostat=E_IO)'LOOKUP_TABLE default'//end_rec - write(unit=vtk(rf)%u,iostat=E_IO)var - write(unit=vtk(rf)%u,iostat=E_IO)end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_SCAL_R4 - - !> Function for saving field of scalar variable (I4P). - !> @return E_IO: integer(I4P) error flag - function VTK_VAR_SCAL_I4(NC_NN,varname,var,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NC_NN !< Number of nodes or cells. - character(*), intent(IN):: varname !< Variable name. - integer(I4P), intent(IN):: var(1:NC_NN) !< Variable to be saved. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - integer(I4P):: rf !< Real file index. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)'SCALARS '//trim(varname)//' int 1' - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)'LOOKUP_TABLE default' - write(unit=vtk(rf)%u,fmt=FI4P, iostat=E_IO)var - case(raw) - write(unit=vtk(rf)%u,iostat=E_IO)'SCALARS '//trim(varname)//' int 1'//end_rec - write(unit=vtk(rf)%u,iostat=E_IO)'LOOKUP_TABLE default'//end_rec - write(unit=vtk(rf)%u,iostat=E_IO)var - write(unit=vtk(rf)%u,iostat=E_IO)end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_SCAL_I4 - - !> Function for saving field of vectorial variable (R8P). - !> @return E_IO: integer(I4P) error flag - function VTK_VAR_VECT_R8(vec_type,NC_NN,varname,varX,varY,varZ,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - character(*), intent(IN):: vec_type !< Vector type: vect = generic vector , norm = normal vector. - integer(I4P), intent(IN):: NC_NN !< Number of nodes or cells. - character(*), intent(IN):: varname !< Variable name. - real(R8P), intent(IN):: varX(1:NC_NN) !< X component of vector. - real(R8P), intent(IN):: varY(1:NC_NN) !< Y component of vector. - real(R8P), intent(IN):: varZ(1:NC_NN) !< Z component of vector. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - integer(I4P):: rf !< Real file index. - integer(I4P):: n1 !< Counter. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - select case(Upper_Case(trim(vec_type))) - case('VECT') - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)'VECTORS '//trim(varname)//' double' - case('NORM') - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)'NORMALS '//trim(varname)//' double' - endselect - write(unit=vtk(rf)%u,fmt='(3'//FR8P//')',iostat=E_IO)(varX(n1),varY(n1),varZ(n1),n1=1,NC_NN) - case(raw) - select case(Upper_Case(trim(vec_type))) - case('VECT') - write(unit=vtk(rf)%u,iostat=E_IO)'VECTORS '//trim(varname)//' double'//end_rec - case('NORM') - write(unit=vtk(rf)%u,iostat=E_IO)'NORMALS '//trim(varname)//' double'//end_rec - endselect - write(unit=vtk(rf)%u,iostat=E_IO)(varX(n1),varY(n1),varZ(n1),n1=1,NC_NN) - write(unit=vtk(rf)%u,iostat=E_IO)end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_VECT_R8 - - !> Function for saving field of vectorial variable (R4P). - !> @return E_IO: integer(I4P) error flag - function VTK_VAR_VECT_R4(vec_type,NC_NN,varname,varX,varY,varZ,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - character(*), intent(IN):: vec_type !< Vector type: vect = generic vector , norm = normal vector. - integer(I4P), intent(IN):: NC_NN !< Number of nodes or cells. - character(*), intent(IN):: varname !< Variable name. - real(R4P), intent(IN):: varX(1:NC_NN) !< X component of vector. - real(R4P), intent(IN):: varY(1:NC_NN) !< Y component of vector. - real(R4P), intent(IN):: varZ(1:NC_NN) !< Z component of vector. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - integer(I4P):: rf !< Real file index. - integer(I4P):: n1 !< Counter. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - select case(Upper_Case(trim(vec_type))) - case('vect') - write(unit=vtk(rf)%u,fmt='(A)', iostat=E_IO)'VECTORS '//trim(varname)//' float' - case('norm') - write(unit=vtk(rf)%u,fmt='(A)', iostat=E_IO)'NORMALS '//trim(varname)//' float' - endselect - write(unit=vtk(rf)%u,fmt='(3'//FR4P//')',iostat=E_IO)(varX(n1),varY(n1),varZ(n1),n1=1,NC_NN) - case(raw) - select case(Upper_Case(trim(vec_type))) - case('vect') - write(unit=vtk(rf)%u,iostat=E_IO)'VECTORS '//trim(varname)//' float'//end_rec - case('norm') - write(unit=vtk(rf)%u,iostat=E_IO)'NORMALS '//trim(varname)//' float'//end_rec - endselect - write(unit=vtk(rf)%u,iostat=E_IO)(varX(n1),varY(n1),varZ(n1),n1=1,NC_NN) - write(unit=vtk(rf)%u,iostat=E_IO)end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_VECT_R4 - - !> Function for saving field of vectorial variable (I4P). - !> @return E_IO: integer(I4P) error flag - function VTK_VAR_VECT_I4(NC_NN,varname,varX,varY,varZ,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NC_NN !< Number of nodes or cells. - character(*), intent(IN):: varname !< Variable name. - integer(I4P), intent(IN):: varX(1:NC_NN) !< X component of vector. - integer(I4P), intent(IN):: varY(1:NC_NN) !< Y component of vector. - integer(I4P), intent(IN):: varZ(1:NC_NN) !< Z component of vector. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - integer(I4P):: rf !< Real file index. - integer(I4P):: n1 !< Counter. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)'VECTORS '//trim(varname)//' int' - write(unit=vtk(rf)%u,fmt='(3'//FI4P//')',iostat=E_IO)(varX(n1),varY(n1),varZ(n1),n1=1,NC_NN) - case(raw) - write(unit=vtk(rf)%u,iostat=E_IO)'VECTORS '//trim(varname)//' int'//end_rec - write(unit=vtk(rf)%u,iostat=E_IO)(varX(n1),varY(n1),varZ(n1),n1=1,NC_NN) - write(unit=vtk(rf)%u,iostat=E_IO)end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_VECT_I4 - - !> Function for saving texture variable (R8P). - !> @return E_IO: integer(I4P) error flag - function VTK_VAR_TEXT_R8(NC_NN,dimm,varname,textCoo,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NC_NN !< Number of nodes or cells. - integer(I4P), intent(IN):: dimm !< Texture dimensions. - character(*), intent(IN):: varname !< Variable name. - real(R8P), intent(IN):: textCoo(1:NC_NN,1:dimm) !< Texture. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I4P):: rf !< Real file index. - integer(I4P):: n1,n2 !< Counters. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - write(unit=vtk(rf)%u,fmt='(A,1X,'//FI4P//',1X,A)',iostat=E_IO)'TEXTURE_COORDINATES '//trim(varname),dimm,' double' - write(s_buffer,fmt='(I1)',iostat=E_IO)dimm - s_buffer='('//trim(s_buffer)//FR4P//')' - write(unit=vtk(rf)%u,fmt=trim(s_buffer),iostat=E_IO)((textCoo(n1,n2),n2=1,dimm),n1=1,NC_NN) - case(raw) - write(s_buffer,fmt='(A,1X,'//FI4P//',1X,A)',iostat=E_IO)'TEXTURE_COORDINATES '//trim(varname),dimm,' double' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - write(unit=vtk(rf)%u,iostat=E_IO)((textCoo(n1,n2),n2=1,dimm),n1=1,NC_NN) - write(unit=vtk(rf)%u,iostat=E_IO)end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_TEXT_R8 - - !> Function for saving texture variable (R4P). - !> @return E_IO: integer(I4P) error flag - function VTK_VAR_TEXT_R4(NC_NN,dimm,varname,textCoo,cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - !! Function for saving texture variable (R4P). - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(IN):: NC_NN !< Number of nodes or cells. - integer(I4P), intent(IN):: dimm !< Texture dimensions. - character(*), intent(IN):: varname !< Variable name. - real(R4P), intent(IN):: textCoo(1:NC_NN,1:dimm) !< Texture. - integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I4P):: rf !< Real file index. - integer(I4P):: n1,n2 !< Counters. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - select case(vtk(rf)%f) - case(ascii) - write(unit=vtk(rf)%u,fmt='(A,1X,'//FI4P//',1X,A)',iostat=E_IO)'TEXTURE_COORDINATES '//trim(varname),dimm,' float' - write(s_buffer,fmt='(I1)',iostat=E_IO)dimm - s_buffer='('//trim(s_buffer)//FR4P//')' - write(unit=vtk(rf)%u,fmt=trim(s_buffer),iostat=E_IO)((textCoo(n1,n2),n2=1,dimm),n1=1,NC_NN) - case(raw) - write(s_buffer,fmt='(A,1X,'//FI4P//',1X,A)',iostat=E_IO)'TEXTURE_COORDINATES '//trim(varname),dimm,' float' - write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec - write(unit=vtk(rf)%u,iostat=E_IO)((textCoo(n1,n2),n2=1,dimm),n1=1,NC_NN) - write(unit=vtk(rf)%u,iostat=E_IO)end_rec - endselect - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_TEXT_R4 - !> @} - - !>Function for finalizing open file, it has not inputs, @libvtk manages the file unit without the - !>user's action. - !> @note An example of usage is: \n - !> @code ... - !> E_IO=VTK_END() - !> ... @endcode - !> @return E_IO: integer(I4P) error flag - !> @ingroup Lib_VTK_IOPublicProcedure - function VTK_END(cf) result(E_IO) - !--------------------------------------------------------------------------------------------------------------------------------- - implicit none - integer(I4P), intent(INOUT), optional:: cf !< Current file index (for concurrent files IO). - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - integer(I4P):: rf !< Real file index. - !--------------------------------------------------------------------------------------------------------------------------------- - - !--------------------------------------------------------------------------------------------------------------------------------- - E_IO = -1_I4P - rf = f - if (present(cf)) then - rf = cf ; f = cf - endif - close(unit=vtk(rf)%u,iostat=E_IO) - call vtk_update(act='remove',cf=rf,Nvtk=Nvtk,vtk=vtk) - f = rf - if (present(cf)) cf = rf - return - !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_END -endmodule Lib_VTK_IO diff --git a/lib/fftw3.f03 b/lib/fftw3.f03 deleted file mode 100644 index 75def88cc..000000000 --- a/lib/fftw3.f03 +++ /dev/null @@ -1,1226 +0,0 @@ -! Generated automatically. DO NOT EDIT! - - integer, parameter :: C_FFTW_R2R_KIND = C_INT32_T - - integer(C_INT), parameter :: FFTW_R2HC = 0_C_INT - integer(C_INT), parameter :: FFTW_HC2R = 1_C_INT - integer(C_INT), parameter :: FFTW_DHT = 2_C_INT - integer(C_INT), parameter :: FFTW_REDFT00 = 3_C_INT - integer(C_INT), parameter :: FFTW_REDFT01 = 4_C_INT - integer(C_INT), parameter :: FFTW_REDFT10 = 5_C_INT - integer(C_INT), parameter :: FFTW_REDFT11 = 6_C_INT - integer(C_INT), parameter :: FFTW_RODFT00 = 7_C_INT - integer(C_INT), parameter :: FFTW_RODFT01 = 8_C_INT - integer(C_INT), parameter :: FFTW_RODFT10 = 9_C_INT - integer(C_INT), parameter :: FFTW_RODFT11 = 10_C_INT - integer(C_INT), parameter :: FFTW_FORWARD = -1_C_INT - integer(C_INT), parameter :: FFTW_BACKWARD = +1_C_INT - integer(C_INT), parameter :: FFTW_MEASURE = 0_C_INT - integer(C_INT), parameter :: FFTW_DESTROY_INPUT = 1_C_INT - integer(C_INT), parameter :: FFTW_UNALIGNED = 2_C_INT - integer(C_INT), parameter :: FFTW_CONSERVE_MEMORY = 4_C_INT - integer(C_INT), parameter :: FFTW_EXHAUSTIVE = 8_C_INT - integer(C_INT), parameter :: FFTW_PRESERVE_INPUT = 16_C_INT - integer(C_INT), parameter :: FFTW_PATIENT = 32_C_INT - integer(C_INT), parameter :: FFTW_ESTIMATE = 64_C_INT - integer(C_INT), parameter :: FFTW_ESTIMATE_PATIENT = 128_C_INT - integer(C_INT), parameter :: FFTW_BELIEVE_PCOST = 256_C_INT - integer(C_INT), parameter :: FFTW_NO_DFT_R2HC = 512_C_INT - integer(C_INT), parameter :: FFTW_NO_NONTHREADED = 1024_C_INT - integer(C_INT), parameter :: FFTW_NO_BUFFERING = 2048_C_INT - integer(C_INT), parameter :: FFTW_NO_INDIRECT_OP = 4096_C_INT - integer(C_INT), parameter :: FFTW_ALLOW_LARGE_GENERIC = 8192_C_INT - integer(C_INT), parameter :: FFTW_NO_RANK_SPLITS = 16384_C_INT - integer(C_INT), parameter :: FFTW_NO_VRANK_SPLITS = 32768_C_INT - integer(C_INT), parameter :: FFTW_NO_VRECURSE = 65536_C_INT - integer(C_INT), parameter :: FFTW_NO_SIMD = 131072_C_INT - integer(C_INT), parameter :: FFTW_NO_SLOW = 262144_C_INT - integer(C_INT), parameter :: FFTW_NO_FIXED_RADIX_LARGE_N = 524288_C_INT - integer(C_INT), parameter :: FFTW_ALLOW_PRUNING = 1048576_C_INT - integer(C_INT), parameter :: FFTW_WISDOM_ONLY = 2097152_C_INT - - type, bind(C) :: fftw_iodim - integer(C_INT) n, is, os - end type fftw_iodim - type, bind(C) :: fftw_iodim64 - integer(C_INTPTR_T) n, is, os - end type fftw_iodim64 - - interface - type(C_PTR) function fftw_plan_dft(rank,n,in,out,sign,flags) bind(C, name='fftw_plan_dft') - import - integer(C_INT), value :: rank - integer(C_INT), dimension(*), intent(in) :: n - complex(C_DOUBLE_COMPLEX), dimension(*), intent(out) :: in - complex(C_DOUBLE_COMPLEX), dimension(*), intent(out) :: out - integer(C_INT), value :: sign - integer(C_INT), value :: flags - end function fftw_plan_dft - - type(C_PTR) function fftw_plan_dft_1d(n,in,out,sign,flags) bind(C, name='fftw_plan_dft_1d') - import - integer(C_INT), value :: n - complex(C_DOUBLE_COMPLEX), dimension(*), intent(out) :: in - complex(C_DOUBLE_COMPLEX), dimension(*), intent(out) :: out - integer(C_INT), value :: sign - integer(C_INT), value :: flags - end function fftw_plan_dft_1d - - type(C_PTR) function fftw_plan_dft_2d(n0,n1,in,out,sign,flags) bind(C, name='fftw_plan_dft_2d') - import - integer(C_INT), value :: n0 - integer(C_INT), value :: n1 - complex(C_DOUBLE_COMPLEX), dimension(*), intent(out) :: in - complex(C_DOUBLE_COMPLEX), dimension(*), intent(out) :: out - integer(C_INT), value :: sign - integer(C_INT), value :: flags - end function fftw_plan_dft_2d - - type(C_PTR) function fftw_plan_dft_3d(n0,n1,n2,in,out,sign,flags) bind(C, name='fftw_plan_dft_3d') - import - integer(C_INT), value :: n0 - integer(C_INT), value :: n1 - integer(C_INT), value :: n2 - complex(C_DOUBLE_COMPLEX), dimension(*), intent(out) :: in - complex(C_DOUBLE_COMPLEX), dimension(*), intent(out) :: out - integer(C_INT), value :: sign - integer(C_INT), value :: flags - end function fftw_plan_dft_3d - - type(C_PTR) function fftw_plan_many_dft(rank,n,howmany,in,inembed,istride,idist,out,onembed,ostride,odist,sign,flags) & - bind(C, name='fftw_plan_many_dft') - import - integer(C_INT), value :: rank - integer(C_INT), dimension(*), intent(in) :: n - integer(C_INT), value :: howmany - complex(C_DOUBLE_COMPLEX), dimension(*), intent(out) :: in - integer(C_INT), dimension(*), intent(in) :: inembed - integer(C_INT), value :: istride - integer(C_INT), value :: idist - complex(C_DOUBLE_COMPLEX), dimension(*), intent(out) :: out - integer(C_INT), dimension(*), intent(in) :: onembed - integer(C_INT), value :: ostride - integer(C_INT), value :: odist - integer(C_INT), value :: sign - integer(C_INT), value :: flags - end function fftw_plan_many_dft - - type(C_PTR) function fftw_plan_guru_dft(rank,dims,howmany_rank,howmany_dims,in,out,sign,flags) & - bind(C, name='fftw_plan_guru_dft') - import - integer(C_INT), value :: rank - type(fftw_iodim), dimension(*), intent(in) :: dims - integer(C_INT), value :: howmany_rank - type(fftw_iodim), dimension(*), intent(in) :: howmany_dims - complex(C_DOUBLE_COMPLEX), dimension(*), intent(out) :: in - complex(C_DOUBLE_COMPLEX), dimension(*), intent(out) :: out - integer(C_INT), value :: sign - integer(C_INT), value :: flags - end function fftw_plan_guru_dft - - type(C_PTR) function fftw_plan_guru_split_dft(rank,dims,howmany_rank,howmany_dims,ri,ii,ro,io,flags) & - bind(C, name='fftw_plan_guru_split_dft') - import - integer(C_INT), value :: rank - type(fftw_iodim), dimension(*), intent(in) :: dims - integer(C_INT), value :: howmany_rank - type(fftw_iodim), dimension(*), intent(in) :: howmany_dims - real(C_DOUBLE), dimension(*), intent(out) :: ri - real(C_DOUBLE), dimension(*), intent(out) :: ii - real(C_DOUBLE), dimension(*), intent(out) :: ro - real(C_DOUBLE), dimension(*), intent(out) :: io - integer(C_INT), value :: flags - end function fftw_plan_guru_split_dft - - type(C_PTR) function fftw_plan_guru64_dft(rank,dims,howmany_rank,howmany_dims,in,out,sign,flags) & - bind(C, name='fftw_plan_guru64_dft') - import - integer(C_INT), value :: rank - type(fftw_iodim64), dimension(*), intent(in) :: dims - integer(C_INT), value :: howmany_rank - type(fftw_iodim64), dimension(*), intent(in) :: howmany_dims - complex(C_DOUBLE_COMPLEX), dimension(*), intent(out) :: in - complex(C_DOUBLE_COMPLEX), dimension(*), intent(out) :: out - integer(C_INT), value :: sign - integer(C_INT), value :: flags - end function fftw_plan_guru64_dft - - type(C_PTR) function fftw_plan_guru64_split_dft(rank,dims,howmany_rank,howmany_dims,ri,ii,ro,io,flags) & - bind(C, name='fftw_plan_guru64_split_dft') - import - integer(C_INT), value :: rank - type(fftw_iodim64), dimension(*), intent(in) :: dims - integer(C_INT), value :: howmany_rank - type(fftw_iodim64), dimension(*), intent(in) :: howmany_dims - real(C_DOUBLE), dimension(*), intent(out) :: ri - real(C_DOUBLE), dimension(*), intent(out) :: ii - real(C_DOUBLE), dimension(*), intent(out) :: ro - real(C_DOUBLE), dimension(*), intent(out) :: io - integer(C_INT), value :: flags - end function fftw_plan_guru64_split_dft - - subroutine fftw_execute_dft(p,in,out) bind(C, name='fftw_execute_dft') - import - type(C_PTR), value :: p - complex(C_DOUBLE_COMPLEX), dimension(*), intent(inout) :: in - complex(C_DOUBLE_COMPLEX), dimension(*), intent(out) :: out - end subroutine fftw_execute_dft - - subroutine fftw_execute_split_dft(p,ri,ii,ro,io) bind(C, name='fftw_execute_split_dft') - import - type(C_PTR), value :: p - real(C_DOUBLE), dimension(*), intent(inout) :: ri - real(C_DOUBLE), dimension(*), intent(inout) :: ii - real(C_DOUBLE), dimension(*), intent(out) :: ro - real(C_DOUBLE), dimension(*), intent(out) :: io - end subroutine fftw_execute_split_dft - - type(C_PTR) function fftw_plan_many_dft_r2c(rank,n,howmany,in,inembed,istride,idist,out,onembed,ostride,odist,flags) & - bind(C, name='fftw_plan_many_dft_r2c') - import - integer(C_INT), value :: rank - integer(C_INT), dimension(*), intent(in) :: n - integer(C_INT), value :: howmany - real(C_DOUBLE), dimension(*), intent(out) :: in - integer(C_INT), dimension(*), intent(in) :: inembed - integer(C_INT), value :: istride - integer(C_INT), value :: idist - complex(C_DOUBLE_COMPLEX), dimension(*), intent(out) :: out - integer(C_INT), dimension(*), intent(in) :: onembed - integer(C_INT), value :: ostride - integer(C_INT), value :: odist - integer(C_INT), value :: flags - end function fftw_plan_many_dft_r2c - - type(C_PTR) function fftw_plan_dft_r2c(rank,n,in,out,flags) bind(C, name='fftw_plan_dft_r2c') - import - integer(C_INT), value :: rank - integer(C_INT), dimension(*), intent(in) :: n - real(C_DOUBLE), dimension(*), intent(out) :: in - complex(C_DOUBLE_COMPLEX), dimension(*), intent(out) :: out - integer(C_INT), value :: flags - end function fftw_plan_dft_r2c - - type(C_PTR) function fftw_plan_dft_r2c_1d(n,in,out,flags) bind(C, name='fftw_plan_dft_r2c_1d') - import - integer(C_INT), value :: n - real(C_DOUBLE), dimension(*), intent(out) :: in - complex(C_DOUBLE_COMPLEX), dimension(*), intent(out) :: out - integer(C_INT), value :: flags - end function fftw_plan_dft_r2c_1d - - type(C_PTR) function fftw_plan_dft_r2c_2d(n0,n1,in,out,flags) bind(C, name='fftw_plan_dft_r2c_2d') - import - integer(C_INT), value :: n0 - integer(C_INT), value :: n1 - real(C_DOUBLE), dimension(*), intent(out) :: in - complex(C_DOUBLE_COMPLEX), dimension(*), intent(out) :: out - integer(C_INT), value :: flags - end function fftw_plan_dft_r2c_2d - - type(C_PTR) function fftw_plan_dft_r2c_3d(n0,n1,n2,in,out,flags) bind(C, name='fftw_plan_dft_r2c_3d') - import - integer(C_INT), value :: n0 - integer(C_INT), value :: n1 - integer(C_INT), value :: n2 - real(C_DOUBLE), dimension(*), intent(out) :: in - complex(C_DOUBLE_COMPLEX), dimension(*), intent(out) :: out - integer(C_INT), value :: flags - end function fftw_plan_dft_r2c_3d - - type(C_PTR) function fftw_plan_many_dft_c2r(rank,n,howmany,in,inembed,istride,idist,out,onembed,ostride,odist,flags) & - bind(C, name='fftw_plan_many_dft_c2r') - import - integer(C_INT), value :: rank - integer(C_INT), dimension(*), intent(in) :: n - integer(C_INT), value :: howmany - complex(C_DOUBLE_COMPLEX), dimension(*), intent(out) :: in - integer(C_INT), dimension(*), intent(in) :: inembed - integer(C_INT), value :: istride - integer(C_INT), value :: idist - real(C_DOUBLE), dimension(*), intent(out) :: out - integer(C_INT), dimension(*), intent(in) :: onembed - integer(C_INT), value :: ostride - integer(C_INT), value :: odist - integer(C_INT), value :: flags - end function fftw_plan_many_dft_c2r - - type(C_PTR) function fftw_plan_dft_c2r(rank,n,in,out,flags) bind(C, name='fftw_plan_dft_c2r') - import - integer(C_INT), value :: rank - integer(C_INT), dimension(*), intent(in) :: n - complex(C_DOUBLE_COMPLEX), dimension(*), intent(out) :: in - real(C_DOUBLE), dimension(*), intent(out) :: out - integer(C_INT), value :: flags - end function fftw_plan_dft_c2r - - type(C_PTR) function fftw_plan_dft_c2r_1d(n,in,out,flags) bind(C, name='fftw_plan_dft_c2r_1d') - import - integer(C_INT), value :: n - complex(C_DOUBLE_COMPLEX), dimension(*), intent(out) :: in - real(C_DOUBLE), dimension(*), intent(out) :: out - integer(C_INT), value :: flags - end function fftw_plan_dft_c2r_1d - - type(C_PTR) function fftw_plan_dft_c2r_2d(n0,n1,in,out,flags) bind(C, name='fftw_plan_dft_c2r_2d') - import - integer(C_INT), value :: n0 - integer(C_INT), value :: n1 - complex(C_DOUBLE_COMPLEX), dimension(*), intent(out) :: in - real(C_DOUBLE), dimension(*), intent(out) :: out - integer(C_INT), value :: flags - end function fftw_plan_dft_c2r_2d - - type(C_PTR) function fftw_plan_dft_c2r_3d(n0,n1,n2,in,out,flags) bind(C, name='fftw_plan_dft_c2r_3d') - import - integer(C_INT), value :: n0 - integer(C_INT), value :: n1 - integer(C_INT), value :: n2 - complex(C_DOUBLE_COMPLEX), dimension(*), intent(out) :: in - real(C_DOUBLE), dimension(*), intent(out) :: out - integer(C_INT), value :: flags - end function fftw_plan_dft_c2r_3d - - type(C_PTR) function fftw_plan_guru_dft_r2c(rank,dims,howmany_rank,howmany_dims,in,out,flags) & - bind(C, name='fftw_plan_guru_dft_r2c') - import - integer(C_INT), value :: rank - type(fftw_iodim), dimension(*), intent(in) :: dims - integer(C_INT), value :: howmany_rank - type(fftw_iodim), dimension(*), intent(in) :: howmany_dims - real(C_DOUBLE), dimension(*), intent(out) :: in - complex(C_DOUBLE_COMPLEX), dimension(*), intent(out) :: out - integer(C_INT), value :: flags - end function fftw_plan_guru_dft_r2c - - type(C_PTR) function fftw_plan_guru_dft_c2r(rank,dims,howmany_rank,howmany_dims,in,out,flags) & - bind(C, name='fftw_plan_guru_dft_c2r') - import - integer(C_INT), value :: rank - type(fftw_iodim), dimension(*), intent(in) :: dims - integer(C_INT), value :: howmany_rank - type(fftw_iodim), dimension(*), intent(in) :: howmany_dims - complex(C_DOUBLE_COMPLEX), dimension(*), intent(out) :: in - real(C_DOUBLE), dimension(*), intent(out) :: out - integer(C_INT), value :: flags - end function fftw_plan_guru_dft_c2r - - type(C_PTR) function fftw_plan_guru_split_dft_r2c(rank,dims,howmany_rank,howmany_dims,in,ro,io,flags) & - bind(C, name='fftw_plan_guru_split_dft_r2c') - import - integer(C_INT), value :: rank - type(fftw_iodim), dimension(*), intent(in) :: dims - integer(C_INT), value :: howmany_rank - type(fftw_iodim), dimension(*), intent(in) :: howmany_dims - real(C_DOUBLE), dimension(*), intent(out) :: in - real(C_DOUBLE), dimension(*), intent(out) :: ro - real(C_DOUBLE), dimension(*), intent(out) :: io - integer(C_INT), value :: flags - end function fftw_plan_guru_split_dft_r2c - - type(C_PTR) function fftw_plan_guru_split_dft_c2r(rank,dims,howmany_rank,howmany_dims,ri,ii,out,flags) & - bind(C, name='fftw_plan_guru_split_dft_c2r') - import - integer(C_INT), value :: rank - type(fftw_iodim), dimension(*), intent(in) :: dims - integer(C_INT), value :: howmany_rank - type(fftw_iodim), dimension(*), intent(in) :: howmany_dims - real(C_DOUBLE), dimension(*), intent(out) :: ri - real(C_DOUBLE), dimension(*), intent(out) :: ii - real(C_DOUBLE), dimension(*), intent(out) :: out - integer(C_INT), value :: flags - end function fftw_plan_guru_split_dft_c2r - - type(C_PTR) function fftw_plan_guru64_dft_r2c(rank,dims,howmany_rank,howmany_dims,in,out,flags) & - bind(C, name='fftw_plan_guru64_dft_r2c') - import - integer(C_INT), value :: rank - type(fftw_iodim64), dimension(*), intent(in) :: dims - integer(C_INT), value :: howmany_rank - type(fftw_iodim64), dimension(*), intent(in) :: howmany_dims - real(C_DOUBLE), dimension(*), intent(out) :: in - complex(C_DOUBLE_COMPLEX), dimension(*), intent(out) :: out - integer(C_INT), value :: flags - end function fftw_plan_guru64_dft_r2c - - type(C_PTR) function fftw_plan_guru64_dft_c2r(rank,dims,howmany_rank,howmany_dims,in,out,flags) & - bind(C, name='fftw_plan_guru64_dft_c2r') - import - integer(C_INT), value :: rank - type(fftw_iodim64), dimension(*), intent(in) :: dims - integer(C_INT), value :: howmany_rank - type(fftw_iodim64), dimension(*), intent(in) :: howmany_dims - complex(C_DOUBLE_COMPLEX), dimension(*), intent(out) :: in - real(C_DOUBLE), dimension(*), intent(out) :: out - integer(C_INT), value :: flags - end function fftw_plan_guru64_dft_c2r - - type(C_PTR) function fftw_plan_guru64_split_dft_r2c(rank,dims,howmany_rank,howmany_dims,in,ro,io,flags) & - bind(C, name='fftw_plan_guru64_split_dft_r2c') - import - integer(C_INT), value :: rank - type(fftw_iodim64), dimension(*), intent(in) :: dims - integer(C_INT), value :: howmany_rank - type(fftw_iodim64), dimension(*), intent(in) :: howmany_dims - real(C_DOUBLE), dimension(*), intent(out) :: in - real(C_DOUBLE), dimension(*), intent(out) :: ro - real(C_DOUBLE), dimension(*), intent(out) :: io - integer(C_INT), value :: flags - end function fftw_plan_guru64_split_dft_r2c - - type(C_PTR) function fftw_plan_guru64_split_dft_c2r(rank,dims,howmany_rank,howmany_dims,ri,ii,out,flags) & - bind(C, name='fftw_plan_guru64_split_dft_c2r') - import - integer(C_INT), value :: rank - type(fftw_iodim64), dimension(*), intent(in) :: dims - integer(C_INT), value :: howmany_rank - type(fftw_iodim64), dimension(*), intent(in) :: howmany_dims - real(C_DOUBLE), dimension(*), intent(out) :: ri - real(C_DOUBLE), dimension(*), intent(out) :: ii - real(C_DOUBLE), dimension(*), intent(out) :: out - integer(C_INT), value :: flags - end function fftw_plan_guru64_split_dft_c2r - - subroutine fftw_execute_dft_r2c(p,in,out) bind(C, name='fftw_execute_dft_r2c') - import - type(C_PTR), value :: p - real(C_DOUBLE), dimension(*), intent(inout) :: in - complex(C_DOUBLE_COMPLEX), dimension(*), intent(out) :: out - end subroutine fftw_execute_dft_r2c - - subroutine fftw_execute_dft_c2r(p,in,out) bind(C, name='fftw_execute_dft_c2r') - import - type(C_PTR), value :: p - complex(C_DOUBLE_COMPLEX), dimension(*), intent(inout) :: in - real(C_DOUBLE), dimension(*), intent(out) :: out - end subroutine fftw_execute_dft_c2r - - subroutine fftw_execute_split_dft_r2c(p,in,ro,io) bind(C, name='fftw_execute_split_dft_r2c') - import - type(C_PTR), value :: p - real(C_DOUBLE), dimension(*), intent(inout) :: in - real(C_DOUBLE), dimension(*), intent(out) :: ro - real(C_DOUBLE), dimension(*), intent(out) :: io - end subroutine fftw_execute_split_dft_r2c - - subroutine fftw_execute_split_dft_c2r(p,ri,ii,out) bind(C, name='fftw_execute_split_dft_c2r') - import - type(C_PTR), value :: p - real(C_DOUBLE), dimension(*), intent(inout) :: ri - real(C_DOUBLE), dimension(*), intent(inout) :: ii - real(C_DOUBLE), dimension(*), intent(out) :: out - end subroutine fftw_execute_split_dft_c2r - - type(C_PTR) function fftw_plan_many_r2r(rank,n,howmany,in,inembed,istride,idist,out,onembed,ostride,odist,kind,flags) & - bind(C, name='fftw_plan_many_r2r') - import - integer(C_INT), value :: rank - integer(C_INT), dimension(*), intent(in) :: n - integer(C_INT), value :: howmany - real(C_DOUBLE), dimension(*), intent(out) :: in - integer(C_INT), dimension(*), intent(in) :: inembed - integer(C_INT), value :: istride - integer(C_INT), value :: idist - real(C_DOUBLE), dimension(*), intent(out) :: out - integer(C_INT), dimension(*), intent(in) :: onembed - integer(C_INT), value :: ostride - integer(C_INT), value :: odist - integer(C_FFTW_R2R_KIND), dimension(*), intent(in) :: kind - integer(C_INT), value :: flags - end function fftw_plan_many_r2r - - type(C_PTR) function fftw_plan_r2r(rank,n,in,out,kind,flags) bind(C, name='fftw_plan_r2r') - import - integer(C_INT), value :: rank - integer(C_INT), dimension(*), intent(in) :: n - real(C_DOUBLE), dimension(*), intent(out) :: in - real(C_DOUBLE), dimension(*), intent(out) :: out - integer(C_FFTW_R2R_KIND), dimension(*), intent(in) :: kind - integer(C_INT), value :: flags - end function fftw_plan_r2r - - type(C_PTR) function fftw_plan_r2r_1d(n,in,out,kind,flags) bind(C, name='fftw_plan_r2r_1d') - import - integer(C_INT), value :: n - real(C_DOUBLE), dimension(*), intent(out) :: in - real(C_DOUBLE), dimension(*), intent(out) :: out - integer(C_FFTW_R2R_KIND), value :: kind - integer(C_INT), value :: flags - end function fftw_plan_r2r_1d - - type(C_PTR) function fftw_plan_r2r_2d(n0,n1,in,out,kind0,kind1,flags) bind(C, name='fftw_plan_r2r_2d') - import - integer(C_INT), value :: n0 - integer(C_INT), value :: n1 - real(C_DOUBLE), dimension(*), intent(out) :: in - real(C_DOUBLE), dimension(*), intent(out) :: out - integer(C_FFTW_R2R_KIND), value :: kind0 - integer(C_FFTW_R2R_KIND), value :: kind1 - integer(C_INT), value :: flags - end function fftw_plan_r2r_2d - - type(C_PTR) function fftw_plan_r2r_3d(n0,n1,n2,in,out,kind0,kind1,kind2,flags) bind(C, name='fftw_plan_r2r_3d') - import - integer(C_INT), value :: n0 - integer(C_INT), value :: n1 - integer(C_INT), value :: n2 - real(C_DOUBLE), dimension(*), intent(out) :: in - real(C_DOUBLE), dimension(*), intent(out) :: out - integer(C_FFTW_R2R_KIND), value :: kind0 - integer(C_FFTW_R2R_KIND), value :: kind1 - integer(C_FFTW_R2R_KIND), value :: kind2 - integer(C_INT), value :: flags - end function fftw_plan_r2r_3d - - type(C_PTR) function fftw_plan_guru_r2r(rank,dims,howmany_rank,howmany_dims,in,out,kind,flags) & - bind(C, name='fftw_plan_guru_r2r') - import - integer(C_INT), value :: rank - type(fftw_iodim), dimension(*), intent(in) :: dims - integer(C_INT), value :: howmany_rank - type(fftw_iodim), dimension(*), intent(in) :: howmany_dims - real(C_DOUBLE), dimension(*), intent(out) :: in - real(C_DOUBLE), dimension(*), intent(out) :: out - integer(C_FFTW_R2R_KIND), dimension(*), intent(in) :: kind - integer(C_INT), value :: flags - end function fftw_plan_guru_r2r - - type(C_PTR) function fftw_plan_guru64_r2r(rank,dims,howmany_rank,howmany_dims,in,out,kind,flags) & - bind(C, name='fftw_plan_guru64_r2r') - import - integer(C_INT), value :: rank - type(fftw_iodim64), dimension(*), intent(in) :: dims - integer(C_INT), value :: howmany_rank - type(fftw_iodim64), dimension(*), intent(in) :: howmany_dims - real(C_DOUBLE), dimension(*), intent(out) :: in - real(C_DOUBLE), dimension(*), intent(out) :: out - integer(C_FFTW_R2R_KIND), dimension(*), intent(in) :: kind - integer(C_INT), value :: flags - end function fftw_plan_guru64_r2r - - subroutine fftw_execute_r2r(p,in,out) bind(C, name='fftw_execute_r2r') - import - type(C_PTR), value :: p - real(C_DOUBLE), dimension(*), intent(inout) :: in - real(C_DOUBLE), dimension(*), intent(out) :: out - end subroutine fftw_execute_r2r - - subroutine fftw_destroy_plan(p) bind(C, name='fftw_destroy_plan') - import - type(C_PTR), value :: p - end subroutine fftw_destroy_plan - - subroutine fftw_forget_wisdom() bind(C, name='fftw_forget_wisdom') - import - end subroutine fftw_forget_wisdom - - subroutine fftw_cleanup() bind(C, name='fftw_cleanup') - import - end subroutine fftw_cleanup - - subroutine fftw_set_timelimit(t) bind(C, name='fftw_set_timelimit') - import - real(C_DOUBLE), value :: t - end subroutine fftw_set_timelimit - - subroutine fftw_plan_with_nthreads(nthreads) bind(C, name='fftw_plan_with_nthreads') - import - integer(C_INT), value :: nthreads - end subroutine fftw_plan_with_nthreads - - integer(C_INT) function fftw_init_threads() bind(C, name='fftw_init_threads') - import - end function fftw_init_threads - - subroutine fftw_cleanup_threads() bind(C, name='fftw_cleanup_threads') - import - end subroutine fftw_cleanup_threads - - integer(C_INT) function fftw_export_wisdom_to_filename(filename) bind(C, name='fftw_export_wisdom_to_filename') - import - character(C_CHAR), dimension(*), intent(in) :: filename - end function fftw_export_wisdom_to_filename - - subroutine fftw_export_wisdom_to_file(output_file) bind(C, name='fftw_export_wisdom_to_file') - import - type(C_PTR), value :: output_file - end subroutine fftw_export_wisdom_to_file - - type(C_PTR) function fftw_export_wisdom_to_string() bind(C, name='fftw_export_wisdom_to_string') - import - end function fftw_export_wisdom_to_string - - subroutine fftw_export_wisdom(write_char,data) bind(C, name='fftw_export_wisdom') - import - type(C_FUNPTR), value :: write_char - type(C_PTR), value :: data - end subroutine fftw_export_wisdom - - integer(C_INT) function fftw_import_system_wisdom() bind(C, name='fftw_import_system_wisdom') - import - end function fftw_import_system_wisdom - - integer(C_INT) function fftw_import_wisdom_from_filename(filename) bind(C, name='fftw_import_wisdom_from_filename') - import - character(C_CHAR), dimension(*), intent(in) :: filename - end function fftw_import_wisdom_from_filename - - integer(C_INT) function fftw_import_wisdom_from_file(input_file) bind(C, name='fftw_import_wisdom_from_file') - import - type(C_PTR), value :: input_file - end function fftw_import_wisdom_from_file - - integer(C_INT) function fftw_import_wisdom_from_string(input_string) bind(C, name='fftw_import_wisdom_from_string') - import - character(C_CHAR), dimension(*), intent(in) :: input_string - end function fftw_import_wisdom_from_string - - integer(C_INT) function fftw_import_wisdom(read_char,data) bind(C, name='fftw_import_wisdom') - import - type(C_FUNPTR), value :: read_char - type(C_PTR), value :: data - end function fftw_import_wisdom - - subroutine fftw_fprint_plan(p,output_file) bind(C, name='fftw_fprint_plan') - import - type(C_PTR), value :: p - type(C_PTR), value :: output_file - end subroutine fftw_fprint_plan - - subroutine fftw_print_plan(p) bind(C, name='fftw_print_plan') - import - type(C_PTR), value :: p - end subroutine fftw_print_plan - - type(C_PTR) function fftw_malloc(n) bind(C, name='fftw_malloc') - import - integer(C_SIZE_T), value :: n - end function fftw_malloc - - type(C_PTR) function fftw_alloc_real(n) bind(C, name='fftw_alloc_real') - import - integer(C_SIZE_T), value :: n - end function fftw_alloc_real - - type(C_PTR) function fftw_alloc_complex(n) bind(C, name='fftw_alloc_complex') - import - integer(C_SIZE_T), value :: n - end function fftw_alloc_complex - - subroutine fftw_free(p) bind(C, name='fftw_free') - import - type(C_PTR), value :: p - end subroutine fftw_free - - subroutine fftw_flops(p,add,mul,fmas) bind(C, name='fftw_flops') - import - type(C_PTR), value :: p - real(C_DOUBLE), intent(out) :: add - real(C_DOUBLE), intent(out) :: mul - real(C_DOUBLE), intent(out) :: fmas - end subroutine fftw_flops - - real(C_DOUBLE) function fftw_estimate_cost(p) bind(C, name='fftw_estimate_cost') - import - type(C_PTR), value :: p - end function fftw_estimate_cost - - real(C_DOUBLE) function fftw_cost(p) bind(C, name='fftw_cost') - import - type(C_PTR), value :: p - end function fftw_cost - - end interface - - type, bind(C) :: fftwf_iodim - integer(C_INT) n, is, os - end type fftwf_iodim - type, bind(C) :: fftwf_iodim64 - integer(C_INTPTR_T) n, is, os - end type fftwf_iodim64 - - interface - type(C_PTR) function fftwf_plan_dft(rank,n,in,out,sign,flags) bind(C, name='fftwf_plan_dft') - import - integer(C_INT), value :: rank - integer(C_INT), dimension(*), intent(in) :: n - complex(C_FLOAT_COMPLEX), dimension(*), intent(out) :: in - complex(C_FLOAT_COMPLEX), dimension(*), intent(out) :: out - integer(C_INT), value :: sign - integer(C_INT), value :: flags - end function fftwf_plan_dft - - type(C_PTR) function fftwf_plan_dft_1d(n,in,out,sign,flags) bind(C, name='fftwf_plan_dft_1d') - import - integer(C_INT), value :: n - complex(C_FLOAT_COMPLEX), dimension(*), intent(out) :: in - complex(C_FLOAT_COMPLEX), dimension(*), intent(out) :: out - integer(C_INT), value :: sign - integer(C_INT), value :: flags - end function fftwf_plan_dft_1d - - type(C_PTR) function fftwf_plan_dft_2d(n0,n1,in,out,sign,flags) bind(C, name='fftwf_plan_dft_2d') - import - integer(C_INT), value :: n0 - integer(C_INT), value :: n1 - complex(C_FLOAT_COMPLEX), dimension(*), intent(out) :: in - complex(C_FLOAT_COMPLEX), dimension(*), intent(out) :: out - integer(C_INT), value :: sign - integer(C_INT), value :: flags - end function fftwf_plan_dft_2d - - type(C_PTR) function fftwf_plan_dft_3d(n0,n1,n2,in,out,sign,flags) bind(C, name='fftwf_plan_dft_3d') - import - integer(C_INT), value :: n0 - integer(C_INT), value :: n1 - integer(C_INT), value :: n2 - complex(C_FLOAT_COMPLEX), dimension(*), intent(out) :: in - complex(C_FLOAT_COMPLEX), dimension(*), intent(out) :: out - integer(C_INT), value :: sign - integer(C_INT), value :: flags - end function fftwf_plan_dft_3d - - type(C_PTR) function fftwf_plan_many_dft(rank,n,howmany,in,inembed,istride,idist,out,onembed,ostride,odist,sign,flags) & - bind(C, name='fftwf_plan_many_dft') - import - integer(C_INT), value :: rank - integer(C_INT), dimension(*), intent(in) :: n - integer(C_INT), value :: howmany - complex(C_FLOAT_COMPLEX), dimension(*), intent(out) :: in - integer(C_INT), dimension(*), intent(in) :: inembed - integer(C_INT), value :: istride - integer(C_INT), value :: idist - complex(C_FLOAT_COMPLEX), dimension(*), intent(out) :: out - integer(C_INT), dimension(*), intent(in) :: onembed - integer(C_INT), value :: ostride - integer(C_INT), value :: odist - integer(C_INT), value :: sign - integer(C_INT), value :: flags - end function fftwf_plan_many_dft - - type(C_PTR) function fftwf_plan_guru_dft(rank,dims,howmany_rank,howmany_dims,in,out,sign,flags) & - bind(C, name='fftwf_plan_guru_dft') - import - integer(C_INT), value :: rank - type(fftwf_iodim), dimension(*), intent(in) :: dims - integer(C_INT), value :: howmany_rank - type(fftwf_iodim), dimension(*), intent(in) :: howmany_dims - complex(C_FLOAT_COMPLEX), dimension(*), intent(out) :: in - complex(C_FLOAT_COMPLEX), dimension(*), intent(out) :: out - integer(C_INT), value :: sign - integer(C_INT), value :: flags - end function fftwf_plan_guru_dft - - type(C_PTR) function fftwf_plan_guru_split_dft(rank,dims,howmany_rank,howmany_dims,ri,ii,ro,io,flags) & - bind(C, name='fftwf_plan_guru_split_dft') - import - integer(C_INT), value :: rank - type(fftwf_iodim), dimension(*), intent(in) :: dims - integer(C_INT), value :: howmany_rank - type(fftwf_iodim), dimension(*), intent(in) :: howmany_dims - real(C_FLOAT), dimension(*), intent(out) :: ri - real(C_FLOAT), dimension(*), intent(out) :: ii - real(C_FLOAT), dimension(*), intent(out) :: ro - real(C_FLOAT), dimension(*), intent(out) :: io - integer(C_INT), value :: flags - end function fftwf_plan_guru_split_dft - - type(C_PTR) function fftwf_plan_guru64_dft(rank,dims,howmany_rank,howmany_dims,in,out,sign,flags) & - bind(C, name='fftwf_plan_guru64_dft') - import - integer(C_INT), value :: rank - type(fftwf_iodim64), dimension(*), intent(in) :: dims - integer(C_INT), value :: howmany_rank - type(fftwf_iodim64), dimension(*), intent(in) :: howmany_dims - complex(C_FLOAT_COMPLEX), dimension(*), intent(out) :: in - complex(C_FLOAT_COMPLEX), dimension(*), intent(out) :: out - integer(C_INT), value :: sign - integer(C_INT), value :: flags - end function fftwf_plan_guru64_dft - - type(C_PTR) function fftwf_plan_guru64_split_dft(rank,dims,howmany_rank,howmany_dims,ri,ii,ro,io,flags) & - bind(C, name='fftwf_plan_guru64_split_dft') - import - integer(C_INT), value :: rank - type(fftwf_iodim64), dimension(*), intent(in) :: dims - integer(C_INT), value :: howmany_rank - type(fftwf_iodim64), dimension(*), intent(in) :: howmany_dims - real(C_FLOAT), dimension(*), intent(out) :: ri - real(C_FLOAT), dimension(*), intent(out) :: ii - real(C_FLOAT), dimension(*), intent(out) :: ro - real(C_FLOAT), dimension(*), intent(out) :: io - integer(C_INT), value :: flags - end function fftwf_plan_guru64_split_dft - - subroutine fftwf_execute_dft(p,in,out) bind(C, name='fftwf_execute_dft') - import - type(C_PTR), value :: p - complex(C_FLOAT_COMPLEX), dimension(*), intent(inout) :: in - complex(C_FLOAT_COMPLEX), dimension(*), intent(out) :: out - end subroutine fftwf_execute_dft - - subroutine fftwf_execute_split_dft(p,ri,ii,ro,io) bind(C, name='fftwf_execute_split_dft') - import - type(C_PTR), value :: p - real(C_FLOAT), dimension(*), intent(inout) :: ri - real(C_FLOAT), dimension(*), intent(inout) :: ii - real(C_FLOAT), dimension(*), intent(out) :: ro - real(C_FLOAT), dimension(*), intent(out) :: io - end subroutine fftwf_execute_split_dft - - type(C_PTR) function fftwf_plan_many_dft_r2c(rank,n,howmany,in,inembed,istride,idist,out,onembed,ostride,odist,flags) & - bind(C, name='fftwf_plan_many_dft_r2c') - import - integer(C_INT), value :: rank - integer(C_INT), dimension(*), intent(in) :: n - integer(C_INT), value :: howmany - real(C_FLOAT), dimension(*), intent(out) :: in - integer(C_INT), dimension(*), intent(in) :: inembed - integer(C_INT), value :: istride - integer(C_INT), value :: idist - complex(C_FLOAT_COMPLEX), dimension(*), intent(out) :: out - integer(C_INT), dimension(*), intent(in) :: onembed - integer(C_INT), value :: ostride - integer(C_INT), value :: odist - integer(C_INT), value :: flags - end function fftwf_plan_many_dft_r2c - - type(C_PTR) function fftwf_plan_dft_r2c(rank,n,in,out,flags) bind(C, name='fftwf_plan_dft_r2c') - import - integer(C_INT), value :: rank - integer(C_INT), dimension(*), intent(in) :: n - real(C_FLOAT), dimension(*), intent(out) :: in - complex(C_FLOAT_COMPLEX), dimension(*), intent(out) :: out - integer(C_INT), value :: flags - end function fftwf_plan_dft_r2c - - type(C_PTR) function fftwf_plan_dft_r2c_1d(n,in,out,flags) bind(C, name='fftwf_plan_dft_r2c_1d') - import - integer(C_INT), value :: n - real(C_FLOAT), dimension(*), intent(out) :: in - complex(C_FLOAT_COMPLEX), dimension(*), intent(out) :: out - integer(C_INT), value :: flags - end function fftwf_plan_dft_r2c_1d - - type(C_PTR) function fftwf_plan_dft_r2c_2d(n0,n1,in,out,flags) bind(C, name='fftwf_plan_dft_r2c_2d') - import - integer(C_INT), value :: n0 - integer(C_INT), value :: n1 - real(C_FLOAT), dimension(*), intent(out) :: in - complex(C_FLOAT_COMPLEX), dimension(*), intent(out) :: out - integer(C_INT), value :: flags - end function fftwf_plan_dft_r2c_2d - - type(C_PTR) function fftwf_plan_dft_r2c_3d(n0,n1,n2,in,out,flags) bind(C, name='fftwf_plan_dft_r2c_3d') - import - integer(C_INT), value :: n0 - integer(C_INT), value :: n1 - integer(C_INT), value :: n2 - real(C_FLOAT), dimension(*), intent(out) :: in - complex(C_FLOAT_COMPLEX), dimension(*), intent(out) :: out - integer(C_INT), value :: flags - end function fftwf_plan_dft_r2c_3d - - type(C_PTR) function fftwf_plan_many_dft_c2r(rank,n,howmany,in,inembed,istride,idist,out,onembed,ostride,odist,flags) & - bind(C, name='fftwf_plan_many_dft_c2r') - import - integer(C_INT), value :: rank - integer(C_INT), dimension(*), intent(in) :: n - integer(C_INT), value :: howmany - complex(C_FLOAT_COMPLEX), dimension(*), intent(out) :: in - integer(C_INT), dimension(*), intent(in) :: inembed - integer(C_INT), value :: istride - integer(C_INT), value :: idist - real(C_FLOAT), dimension(*), intent(out) :: out - integer(C_INT), dimension(*), intent(in) :: onembed - integer(C_INT), value :: ostride - integer(C_INT), value :: odist - integer(C_INT), value :: flags - end function fftwf_plan_many_dft_c2r - - type(C_PTR) function fftwf_plan_dft_c2r(rank,n,in,out,flags) bind(C, name='fftwf_plan_dft_c2r') - import - integer(C_INT), value :: rank - integer(C_INT), dimension(*), intent(in) :: n - complex(C_FLOAT_COMPLEX), dimension(*), intent(out) :: in - real(C_FLOAT), dimension(*), intent(out) :: out - integer(C_INT), value :: flags - end function fftwf_plan_dft_c2r - - type(C_PTR) function fftwf_plan_dft_c2r_1d(n,in,out,flags) bind(C, name='fftwf_plan_dft_c2r_1d') - import - integer(C_INT), value :: n - complex(C_FLOAT_COMPLEX), dimension(*), intent(out) :: in - real(C_FLOAT), dimension(*), intent(out) :: out - integer(C_INT), value :: flags - end function fftwf_plan_dft_c2r_1d - - type(C_PTR) function fftwf_plan_dft_c2r_2d(n0,n1,in,out,flags) bind(C, name='fftwf_plan_dft_c2r_2d') - import - integer(C_INT), value :: n0 - integer(C_INT), value :: n1 - complex(C_FLOAT_COMPLEX), dimension(*), intent(out) :: in - real(C_FLOAT), dimension(*), intent(out) :: out - integer(C_INT), value :: flags - end function fftwf_plan_dft_c2r_2d - - type(C_PTR) function fftwf_plan_dft_c2r_3d(n0,n1,n2,in,out,flags) bind(C, name='fftwf_plan_dft_c2r_3d') - import - integer(C_INT), value :: n0 - integer(C_INT), value :: n1 - integer(C_INT), value :: n2 - complex(C_FLOAT_COMPLEX), dimension(*), intent(out) :: in - real(C_FLOAT), dimension(*), intent(out) :: out - integer(C_INT), value :: flags - end function fftwf_plan_dft_c2r_3d - - type(C_PTR) function fftwf_plan_guru_dft_r2c(rank,dims,howmany_rank,howmany_dims,in,out,flags) & - bind(C, name='fftwf_plan_guru_dft_r2c') - import - integer(C_INT), value :: rank - type(fftwf_iodim), dimension(*), intent(in) :: dims - integer(C_INT), value :: howmany_rank - type(fftwf_iodim), dimension(*), intent(in) :: howmany_dims - real(C_FLOAT), dimension(*), intent(out) :: in - complex(C_FLOAT_COMPLEX), dimension(*), intent(out) :: out - integer(C_INT), value :: flags - end function fftwf_plan_guru_dft_r2c - - type(C_PTR) function fftwf_plan_guru_dft_c2r(rank,dims,howmany_rank,howmany_dims,in,out,flags) & - bind(C, name='fftwf_plan_guru_dft_c2r') - import - integer(C_INT), value :: rank - type(fftwf_iodim), dimension(*), intent(in) :: dims - integer(C_INT), value :: howmany_rank - type(fftwf_iodim), dimension(*), intent(in) :: howmany_dims - complex(C_FLOAT_COMPLEX), dimension(*), intent(out) :: in - real(C_FLOAT), dimension(*), intent(out) :: out - integer(C_INT), value :: flags - end function fftwf_plan_guru_dft_c2r - - type(C_PTR) function fftwf_plan_guru_split_dft_r2c(rank,dims,howmany_rank,howmany_dims,in,ro,io,flags) & - bind(C, name='fftwf_plan_guru_split_dft_r2c') - import - integer(C_INT), value :: rank - type(fftwf_iodim), dimension(*), intent(in) :: dims - integer(C_INT), value :: howmany_rank - type(fftwf_iodim), dimension(*), intent(in) :: howmany_dims - real(C_FLOAT), dimension(*), intent(out) :: in - real(C_FLOAT), dimension(*), intent(out) :: ro - real(C_FLOAT), dimension(*), intent(out) :: io - integer(C_INT), value :: flags - end function fftwf_plan_guru_split_dft_r2c - - type(C_PTR) function fftwf_plan_guru_split_dft_c2r(rank,dims,howmany_rank,howmany_dims,ri,ii,out,flags) & - bind(C, name='fftwf_plan_guru_split_dft_c2r') - import - integer(C_INT), value :: rank - type(fftwf_iodim), dimension(*), intent(in) :: dims - integer(C_INT), value :: howmany_rank - type(fftwf_iodim), dimension(*), intent(in) :: howmany_dims - real(C_FLOAT), dimension(*), intent(out) :: ri - real(C_FLOAT), dimension(*), intent(out) :: ii - real(C_FLOAT), dimension(*), intent(out) :: out - integer(C_INT), value :: flags - end function fftwf_plan_guru_split_dft_c2r - - type(C_PTR) function fftwf_plan_guru64_dft_r2c(rank,dims,howmany_rank,howmany_dims,in,out,flags) & - bind(C, name='fftwf_plan_guru64_dft_r2c') - import - integer(C_INT), value :: rank - type(fftwf_iodim64), dimension(*), intent(in) :: dims - integer(C_INT), value :: howmany_rank - type(fftwf_iodim64), dimension(*), intent(in) :: howmany_dims - real(C_FLOAT), dimension(*), intent(out) :: in - complex(C_FLOAT_COMPLEX), dimension(*), intent(out) :: out - integer(C_INT), value :: flags - end function fftwf_plan_guru64_dft_r2c - - type(C_PTR) function fftwf_plan_guru64_dft_c2r(rank,dims,howmany_rank,howmany_dims,in,out,flags) & - bind(C, name='fftwf_plan_guru64_dft_c2r') - import - integer(C_INT), value :: rank - type(fftwf_iodim64), dimension(*), intent(in) :: dims - integer(C_INT), value :: howmany_rank - type(fftwf_iodim64), dimension(*), intent(in) :: howmany_dims - complex(C_FLOAT_COMPLEX), dimension(*), intent(out) :: in - real(C_FLOAT), dimension(*), intent(out) :: out - integer(C_INT), value :: flags - end function fftwf_plan_guru64_dft_c2r - - type(C_PTR) function fftwf_plan_guru64_split_dft_r2c(rank,dims,howmany_rank,howmany_dims,in,ro,io,flags) & - bind(C, name='fftwf_plan_guru64_split_dft_r2c') - import - integer(C_INT), value :: rank - type(fftwf_iodim64), dimension(*), intent(in) :: dims - integer(C_INT), value :: howmany_rank - type(fftwf_iodim64), dimension(*), intent(in) :: howmany_dims - real(C_FLOAT), dimension(*), intent(out) :: in - real(C_FLOAT), dimension(*), intent(out) :: ro - real(C_FLOAT), dimension(*), intent(out) :: io - integer(C_INT), value :: flags - end function fftwf_plan_guru64_split_dft_r2c - - type(C_PTR) function fftwf_plan_guru64_split_dft_c2r(rank,dims,howmany_rank,howmany_dims,ri,ii,out,flags) & - bind(C, name='fftwf_plan_guru64_split_dft_c2r') - import - integer(C_INT), value :: rank - type(fftwf_iodim64), dimension(*), intent(in) :: dims - integer(C_INT), value :: howmany_rank - type(fftwf_iodim64), dimension(*), intent(in) :: howmany_dims - real(C_FLOAT), dimension(*), intent(out) :: ri - real(C_FLOAT), dimension(*), intent(out) :: ii - real(C_FLOAT), dimension(*), intent(out) :: out - integer(C_INT), value :: flags - end function fftwf_plan_guru64_split_dft_c2r - - subroutine fftwf_execute_dft_r2c(p,in,out) bind(C, name='fftwf_execute_dft_r2c') - import - type(C_PTR), value :: p - real(C_FLOAT), dimension(*), intent(inout) :: in - complex(C_FLOAT_COMPLEX), dimension(*), intent(out) :: out - end subroutine fftwf_execute_dft_r2c - - subroutine fftwf_execute_dft_c2r(p,in,out) bind(C, name='fftwf_execute_dft_c2r') - import - type(C_PTR), value :: p - complex(C_FLOAT_COMPLEX), dimension(*), intent(inout) :: in - real(C_FLOAT), dimension(*), intent(out) :: out - end subroutine fftwf_execute_dft_c2r - - subroutine fftwf_execute_split_dft_r2c(p,in,ro,io) bind(C, name='fftwf_execute_split_dft_r2c') - import - type(C_PTR), value :: p - real(C_FLOAT), dimension(*), intent(inout) :: in - real(C_FLOAT), dimension(*), intent(out) :: ro - real(C_FLOAT), dimension(*), intent(out) :: io - end subroutine fftwf_execute_split_dft_r2c - - subroutine fftwf_execute_split_dft_c2r(p,ri,ii,out) bind(C, name='fftwf_execute_split_dft_c2r') - import - type(C_PTR), value :: p - real(C_FLOAT), dimension(*), intent(inout) :: ri - real(C_FLOAT), dimension(*), intent(inout) :: ii - real(C_FLOAT), dimension(*), intent(out) :: out - end subroutine fftwf_execute_split_dft_c2r - - type(C_PTR) function fftwf_plan_many_r2r(rank,n,howmany,in,inembed,istride,idist,out,onembed,ostride,odist,kind,flags) & - bind(C, name='fftwf_plan_many_r2r') - import - integer(C_INT), value :: rank - integer(C_INT), dimension(*), intent(in) :: n - integer(C_INT), value :: howmany - real(C_FLOAT), dimension(*), intent(out) :: in - integer(C_INT), dimension(*), intent(in) :: inembed - integer(C_INT), value :: istride - integer(C_INT), value :: idist - real(C_FLOAT), dimension(*), intent(out) :: out - integer(C_INT), dimension(*), intent(in) :: onembed - integer(C_INT), value :: ostride - integer(C_INT), value :: odist - integer(C_FFTW_R2R_KIND), dimension(*), intent(in) :: kind - integer(C_INT), value :: flags - end function fftwf_plan_many_r2r - - type(C_PTR) function fftwf_plan_r2r(rank,n,in,out,kind,flags) bind(C, name='fftwf_plan_r2r') - import - integer(C_INT), value :: rank - integer(C_INT), dimension(*), intent(in) :: n - real(C_FLOAT), dimension(*), intent(out) :: in - real(C_FLOAT), dimension(*), intent(out) :: out - integer(C_FFTW_R2R_KIND), dimension(*), intent(in) :: kind - integer(C_INT), value :: flags - end function fftwf_plan_r2r - - type(C_PTR) function fftwf_plan_r2r_1d(n,in,out,kind,flags) bind(C, name='fftwf_plan_r2r_1d') - import - integer(C_INT), value :: n - real(C_FLOAT), dimension(*), intent(out) :: in - real(C_FLOAT), dimension(*), intent(out) :: out - integer(C_FFTW_R2R_KIND), value :: kind - integer(C_INT), value :: flags - end function fftwf_plan_r2r_1d - - type(C_PTR) function fftwf_plan_r2r_2d(n0,n1,in,out,kind0,kind1,flags) bind(C, name='fftwf_plan_r2r_2d') - import - integer(C_INT), value :: n0 - integer(C_INT), value :: n1 - real(C_FLOAT), dimension(*), intent(out) :: in - real(C_FLOAT), dimension(*), intent(out) :: out - integer(C_FFTW_R2R_KIND), value :: kind0 - integer(C_FFTW_R2R_KIND), value :: kind1 - integer(C_INT), value :: flags - end function fftwf_plan_r2r_2d - - type(C_PTR) function fftwf_plan_r2r_3d(n0,n1,n2,in,out,kind0,kind1,kind2,flags) bind(C, name='fftwf_plan_r2r_3d') - import - integer(C_INT), value :: n0 - integer(C_INT), value :: n1 - integer(C_INT), value :: n2 - real(C_FLOAT), dimension(*), intent(out) :: in - real(C_FLOAT), dimension(*), intent(out) :: out - integer(C_FFTW_R2R_KIND), value :: kind0 - integer(C_FFTW_R2R_KIND), value :: kind1 - integer(C_FFTW_R2R_KIND), value :: kind2 - integer(C_INT), value :: flags - end function fftwf_plan_r2r_3d - - type(C_PTR) function fftwf_plan_guru_r2r(rank,dims,howmany_rank,howmany_dims,in,out,kind,flags) & - bind(C, name='fftwf_plan_guru_r2r') - import - integer(C_INT), value :: rank - type(fftwf_iodim), dimension(*), intent(in) :: dims - integer(C_INT), value :: howmany_rank - type(fftwf_iodim), dimension(*), intent(in) :: howmany_dims - real(C_FLOAT), dimension(*), intent(out) :: in - real(C_FLOAT), dimension(*), intent(out) :: out - integer(C_FFTW_R2R_KIND), dimension(*), intent(in) :: kind - integer(C_INT), value :: flags - end function fftwf_plan_guru_r2r - - type(C_PTR) function fftwf_plan_guru64_r2r(rank,dims,howmany_rank,howmany_dims,in,out,kind,flags) & - bind(C, name='fftwf_plan_guru64_r2r') - import - integer(C_INT), value :: rank - type(fftwf_iodim64), dimension(*), intent(in) :: dims - integer(C_INT), value :: howmany_rank - type(fftwf_iodim64), dimension(*), intent(in) :: howmany_dims - real(C_FLOAT), dimension(*), intent(out) :: in - real(C_FLOAT), dimension(*), intent(out) :: out - integer(C_FFTW_R2R_KIND), dimension(*), intent(in) :: kind - integer(C_INT), value :: flags - end function fftwf_plan_guru64_r2r - - subroutine fftwf_execute_r2r(p,in,out) bind(C, name='fftwf_execute_r2r') - import - type(C_PTR), value :: p - real(C_FLOAT), dimension(*), intent(inout) :: in - real(C_FLOAT), dimension(*), intent(out) :: out - end subroutine fftwf_execute_r2r - - subroutine fftwf_destroy_plan(p) bind(C, name='fftwf_destroy_plan') - import - type(C_PTR), value :: p - end subroutine fftwf_destroy_plan - - subroutine fftwf_forget_wisdom() bind(C, name='fftwf_forget_wisdom') - import - end subroutine fftwf_forget_wisdom - - subroutine fftwf_cleanup() bind(C, name='fftwf_cleanup') - import - end subroutine fftwf_cleanup - - subroutine fftwf_set_timelimit(t) bind(C, name='fftwf_set_timelimit') - import - real(C_DOUBLE), value :: t - end subroutine fftwf_set_timelimit - - subroutine fftwf_plan_with_nthreads(nthreads) bind(C, name='fftwf_plan_with_nthreads') - import - integer(C_INT), value :: nthreads - end subroutine fftwf_plan_with_nthreads - - integer(C_INT) function fftwf_init_threads() bind(C, name='fftwf_init_threads') - import - end function fftwf_init_threads - - subroutine fftwf_cleanup_threads() bind(C, name='fftwf_cleanup_threads') - import - end subroutine fftwf_cleanup_threads - - integer(C_INT) function fftwf_export_wisdom_to_filename(filename) bind(C, name='fftwf_export_wisdom_to_filename') - import - character(C_CHAR), dimension(*), intent(in) :: filename - end function fftwf_export_wisdom_to_filename - - subroutine fftwf_export_wisdom_to_file(output_file) bind(C, name='fftwf_export_wisdom_to_file') - import - type(C_PTR), value :: output_file - end subroutine fftwf_export_wisdom_to_file - - type(C_PTR) function fftwf_export_wisdom_to_string() bind(C, name='fftwf_export_wisdom_to_string') - import - end function fftwf_export_wisdom_to_string - - subroutine fftwf_export_wisdom(write_char,data) bind(C, name='fftwf_export_wisdom') - import - type(C_FUNPTR), value :: write_char - type(C_PTR), value :: data - end subroutine fftwf_export_wisdom - - integer(C_INT) function fftwf_import_system_wisdom() bind(C, name='fftwf_import_system_wisdom') - import - end function fftwf_import_system_wisdom - - integer(C_INT) function fftwf_import_wisdom_from_filename(filename) bind(C, name='fftwf_import_wisdom_from_filename') - import - character(C_CHAR), dimension(*), intent(in) :: filename - end function fftwf_import_wisdom_from_filename - - integer(C_INT) function fftwf_import_wisdom_from_file(input_file) bind(C, name='fftwf_import_wisdom_from_file') - import - type(C_PTR), value :: input_file - end function fftwf_import_wisdom_from_file - - integer(C_INT) function fftwf_import_wisdom_from_string(input_string) bind(C, name='fftwf_import_wisdom_from_string') - import - character(C_CHAR), dimension(*), intent(in) :: input_string - end function fftwf_import_wisdom_from_string - - integer(C_INT) function fftwf_import_wisdom(read_char,data) bind(C, name='fftwf_import_wisdom') - import - type(C_FUNPTR), value :: read_char - type(C_PTR), value :: data - end function fftwf_import_wisdom - - subroutine fftwf_fprint_plan(p,output_file) bind(C, name='fftwf_fprint_plan') - import - type(C_PTR), value :: p - type(C_PTR), value :: output_file - end subroutine fftwf_fprint_plan - - subroutine fftwf_print_plan(p) bind(C, name='fftwf_print_plan') - import - type(C_PTR), value :: p - end subroutine fftwf_print_plan - - type(C_PTR) function fftwf_malloc(n) bind(C, name='fftwf_malloc') - import - integer(C_SIZE_T), value :: n - end function fftwf_malloc - - type(C_PTR) function fftwf_alloc_real(n) bind(C, name='fftwf_alloc_real') - import - integer(C_SIZE_T), value :: n - end function fftwf_alloc_real - - type(C_PTR) function fftwf_alloc_complex(n) bind(C, name='fftwf_alloc_complex') - import - integer(C_SIZE_T), value :: n - end function fftwf_alloc_complex - - subroutine fftwf_free(p) bind(C, name='fftwf_free') - import - type(C_PTR), value :: p - end subroutine fftwf_free - - subroutine fftwf_flops(p,add,mul,fmas) bind(C, name='fftwf_flops') - import - type(C_PTR), value :: p - real(C_DOUBLE), intent(out) :: add - real(C_DOUBLE), intent(out) :: mul - real(C_DOUBLE), intent(out) :: fmas - end subroutine fftwf_flops - - real(C_DOUBLE) function fftwf_estimate_cost(p) bind(C, name='fftwf_estimate_cost') - import - type(C_PTR), value :: p - end function fftwf_estimate_cost - - real(C_DOUBLE) function fftwf_cost(p) bind(C, name='fftwf_cost') - import - type(C_PTR), value :: p - end function fftwf_cost - - end interface diff --git a/processing/post/marc_deformedGeometry.py b/processing/post/marc_deformedGeometry.py deleted file mode 100755 index f0fbee8b1..000000000 --- a/processing/post/marc_deformedGeometry.py +++ /dev/null @@ -1,144 +0,0 @@ -#!/usr/bin/env python -# -*- coding: UTF-8 no BOM -*- - -import os,sys,shutil -import numpy as np -import damask -from optparse import OptionParser - -scriptName = os.path.splitext(os.path.basename(__file__))[0] -scriptID = ' '.join([scriptName,damask.version]) - -# ----------------------------- -# MAIN FUNCTION STARTS HERE -# ----------------------------- - -# --- input parsing - -parser = OptionParser(usage='%prog [options] resultfile', description = """ -Create vtk files for the (deformed) geometry that belongs to a .t16 (MSC.Marc) results file. - -""", version = scriptID) - -parser.add_option('-d','--dir', dest='dir', \ - help='name of subdirectory to hold output [%default]') -parser.add_option('-r','--range', dest='range', type='int', nargs=3, \ - help='range of positions (or increments) to output (start, end, step) [all]') -parser.add_option('--increments', action='store_true', dest='getIncrements', \ - help='switch to increment range [%default]') -parser.add_option('-t','--type', dest='type', type='choice', choices=['ipbased','nodebased'], \ - help='processed geometry type [ipbased and nodebased]') - -parser.set_defaults(dir = 'vtk') -parser.set_defaults(getIncrements= False) - -(options, files) = parser.parse_args() - -# --- basic sanity checks - -if files == []: - parser.print_help() - parser.error('no file specified...') - -filename = os.path.splitext(files[0])[0] -if not os.path.exists(filename+'.t16'): - parser.print_help() - parser.error('invalid file "%s" specified...'%filename+'.t16') - -if not options.type : - options.type = ['nodebased', 'ipbased'] -else: - options.type = [options.type] - - -# --- more sanity checks - -sys.path.append(damask.solver.Marc().libraryPath('../../')) -try: - import py_post -except: - print('error: no valid Mentat release found') - sys.exit(-1) - - -# --------------------------- open results file and initialize mesh ---------- - -p = py_post.post_open(filename+'.t16') -p.moveto(0) -Nnodes = p.nodes() -Nincrements = p.increments() - 1 # t16 contains one "virtual" increment (at 0) -if damask.core.mesh.mesh_init_postprocessing(filename+'.mesh') > 0: - print('error: init not successful') - sys.exit(-1) -Ncellnodes = damask.core.mesh.mesh_get_Ncellnodes() -unitlength = damask.core.mesh.mesh_get_unitlength() - - -# --------------------------- create output dir -------------------------------- - -dirname = os.path.abspath(os.path.join(os.path.dirname(filename),options.dir)) -if not os.path.isdir(dirname): - os.mkdir(dirname,0755) - - -# --------------------------- get positions -------------------------------- - -incAtPosition = {} -positionOfInc = {} - -for position in range(Nincrements): - p.moveto(position+1) - incAtPosition[position] = p.increment # remember "real" increment at this position - positionOfInc[p.increment] = position # remember position of "real" increment - -if not options.range: - options.getIncrements = False - locations = range(Nincrements) # process all positions -else: - options.range = list(options.range) # convert to list - if options.getIncrements: - locations = [positionOfInc[x] for x in range(options.range[0],options.range[1]+1,options.range[2]) - if x in positionOfInc] - else: - locations = range( max(0,options.range[0]), - min(Nincrements,options.range[1]+1), - options.range[2] ) - -increments = [incAtPosition[x] for x in locations] # build list of increments to process - - - -# --------------------------- loop over positions -------------------------------- - -for incCount,position in enumerate(locations): # walk through locations - - p.moveto(position+1) # wind to correct position - -# --- get displacements - - node_displacement = [[0,0,0] for i in range(Nnodes)] - for n in range(Nnodes): - if p.node_displacements(): - node_displacement[n] = map(lambda x:x*unitlength,list(p.node_displacement(n))) - c = damask.core.mesh.mesh_build_cellnodes(np.array(node_displacement).T,Ncellnodes) - cellnode_displacement = [[c[i][n] for i in range(3)] for n in range(Ncellnodes)] - - -# --- append displacements to corresponding files - - for geomtype in options.type: - outFilename = eval('"'+eval("'%%s_%%s_inc%%0%ii.vtk'%(math.log10(max(increments+[1]))+1)")\ - +'"%(dirname + os.sep + os.path.split(filename)[1],geomtype,increments[incCount])') - print outFilename - shutil.copyfile('%s_%s.vtk'%(filename,geomtype),outFilename) - - with open(outFilename,'a') as myfile: - myfile.write("POINT_DATA %i\n"%{'nodebased':Nnodes,'ipbased':Ncellnodes}[geomtype]) - myfile.write("VECTORS displacement double\n") - coordinates = {'nodebased':node_displacement,'ipbased':cellnode_displacement}[geomtype] - for n in range({'nodebased':Nnodes,'ipbased':Ncellnodes}[geomtype]): - myfile.write("%.8e %.8e %.8e\n"%(coordinates[n][0],coordinates[n][1],coordinates[n][2])) - - - -# --------------------------- DONE -------------------------------- diff --git a/processing/post/marc_extractData.py b/processing/post/marc_extractData.py deleted file mode 100755 index b920a9cdd..000000000 --- a/processing/post/marc_extractData.py +++ /dev/null @@ -1,421 +0,0 @@ -#!/usr/bin/env python -# -*- coding: UTF-8 no BOM -*- - -import os,sys,string,re,time -from optparse import OptionParser, OptionGroup -import damask - -scriptName = os.path.splitext(os.path.basename(__file__))[0] -scriptID = ' '.join([scriptName,damask.version]) - -# ----------------------------- -def ParseOutputFormat(filename,homogID,crystID,phaseID): - """parse .output* files in order to get a list of outputs""" - myID = {'Homogenization': homogID, - 'Crystallite': crystID, - 'Constitutive': phaseID, - } - format = {} - - for what in ['Homogenization','Crystallite','Constitutive']: - content = [] - format[what] = {'outputs':{},'specials':{'brothers':[]}} - for prefix in ['']+map(str,range(1,17)): - if os.path.exists(prefix+filename+'.output'+what): - try: - file = open(prefix+filename+'.output'+what) - content = file.readlines() - file.close() - break - except: - pass - - if content == []: continue # nothing found... - - tag = '' - tagID = 0 - for line in content: - if re.match("\s*$",line) or re.match("#",line): # skip blank lines and comments - continue - m = re.match("\[(.+)\]",line) # look for block indicator - if m: # next section - tag = m.group(1) - tagID += 1 - format[what]['specials']['brothers'].append(tag) - if tag == myID[what] or (myID[what].isdigit() and tagID == int(myID[what])): - format[what]['specials']['_id'] = tagID - format[what]['outputs'] = [] - tag = myID[what] - else: # data from section - if tag == myID[what]: - (output,length) = line.split() - output.lower() - if length.isdigit(): - length = int(length) - if re.match("\((.+)\)",output): # special data, e.g. (Ngrains) - format[what]['specials'][output] = length - elif length > 0: - format[what]['outputs'].append([output,length]) - - if '_id' not in format[what]['specials']: - print "\nsection '%s' not found in <%s>"%(myID[what], what) - print '\n'.join(map(lambda x:' [%s]'%x, format[what]['specials']['brothers'])) - - return format - - -# ----------------------------- -def ParsePostfile(p,filename, outputFormat, legacyFormat): - """ - parse postfile in order to get position and labels of outputs - - needs "outputFormat" for mapping of output names to postfile output indices - """ - startVar = {True: 'GrainCount', - False:'HomogenizationCount'} - -# --- build statistics - - stat = { \ - 'IndexOfLabel': {}, \ - 'Title': p.title(), \ - 'Extrapolation': p.extrapolate, \ - 'NumberOfIncrements': p.increments() - 1, \ - 'NumberOfNodes': p.nodes(), \ - 'NumberOfNodalScalars': p.node_scalars(), \ - 'LabelOfNodalScalar': [None]*p.node_scalars() , \ - 'NumberOfElements': p.elements(), \ - 'NumberOfElementalScalars': p.element_scalars(), \ - 'LabelOfElementalScalar': [None]*p.element_scalars() , \ - 'NumberOfElementalTensors': p.element_tensors(), \ - 'LabelOfElementalTensor': [None]*p.element_tensors(), \ - } - -# --- find labels - - for labelIndex in range(stat['NumberOfNodalScalars']): - label = p.node_scalar_label(labelIndex) - stat['IndexOfLabel'][label] = labelIndex - stat['LabelOfNodalScalar'][labelIndex] = label - - for labelIndex in range(stat['NumberOfElementalScalars']): - label = p.element_scalar_label(labelIndex) - stat['IndexOfLabel'][label] = labelIndex - stat['LabelOfElementalScalar'][labelIndex] = label - - for labelIndex in range(stat['NumberOfElementalTensors']): - label = p.element_tensor_label(labelIndex) - stat['IndexOfLabel'][label] = labelIndex - stat['LabelOfElementalTensor'][labelIndex] = label - - if 'User Defined Variable 1' in stat['IndexOfLabel']: # output format without dedicated names? - stat['IndexOfLabel'][startVar[legacyFormat]] = stat['IndexOfLabel']['User Defined Variable 1'] # adjust first named entry - - if startVar[legacyFormat] in stat['IndexOfLabel']: # does the result file contain relevant user defined output at all? - startIndex = stat['IndexOfLabel'][startVar[legacyFormat]] - stat['LabelOfElementalScalar'][startIndex] = startVar[legacyFormat] - -# We now have to find a mapping for each output label as defined in the .output* files to the output position in the post file -# Since we know where the user defined outputs start ("startIndex"), we can simply assign increasing indices to the labels -# given in the .output* file - - offset = 1 - if legacyFormat: - stat['LabelOfElementalScalar'][startIndex + offset] = startVar[not legacyFormat] # add HomogenizationCount as second - offset += 1 - - for (name,N) in outputFormat['Homogenization']['outputs']: - for i in range(N): - label = {False: '%s'%( name), - True:'%i_%s'%(i+1,name)}[N > 1] - stat['IndexOfLabel'][label] = startIndex + offset - stat['LabelOfElementalScalar'][startIndex + offset] = label - offset += 1 - - if not legacyFormat: - stat['IndexOfLabel'][startVar[not legacyFormat]] = startIndex + offset - stat['LabelOfElementalScalar'][startIndex + offset] = startVar[not legacyFormat] # add GrainCount - offset += 1 - - if '(ngrains)' in outputFormat['Homogenization']['specials']: - for grain in range(outputFormat['Homogenization']['specials']['(ngrains)']): - - stat['IndexOfLabel']['%i_CrystalliteCount'%(grain+1)] = startIndex + offset # report crystallite count - stat['LabelOfElementalScalar'][startIndex + offset] = '%i_CrystalliteCount'%(grain+1) # add GrainCount - offset += 1 - - for (name,N) in outputFormat['Crystallite']['outputs']: # add crystallite outputs - for i in range(N): - label = {False: '%i_%s'%(grain+1, name), - True:'%i_%i_%s'%(grain+1,i+1,name)}[N > 1] - stat['IndexOfLabel'][label] = startIndex + offset - stat['LabelOfElementalScalar'][startIndex + offset] = label - offset += 1 - - stat['IndexOfLabel']['%i_ConstitutiveCount'%(grain+1)] = startIndex + offset # report constitutive count - stat['LabelOfElementalScalar'][startIndex + offset] = '%i_ConstitutiveCount'%(grain+1) # add GrainCount - offset += 1 - - for (name,N) in outputFormat['Constitutive']['outputs']: # add constitutive outputs - for i in range(N): - label = {False: '%i_%s'%(grain+1, name), - True:'%i_%i_%s'%(grain+1,i+1,name)}[N > 1] - stat['IndexOfLabel'][label] = startIndex + offset - try: - stat['LabelOfElementalScalar'][startIndex + offset] = label - except IndexError: - print 'trying to assign %s at position %i+%i'%(label,startIndex,offset) - sys.exit(1) - offset += 1 - - return stat - - -# ----------------------------- -def GetIncrementLocations(p,Nincrements,options): - """get mapping between positions in postfile and increment number""" - incAtPosition = {} - positionOfInc = {} - - for position in range(Nincrements): - p.moveto(position+1) - incAtPosition[position] = p.increment # remember "real" increment at this position - positionOfInc[p.increment] = position # remember position of "real" increment - - if not options.range: - options.getIncrements = False - locations = range(Nincrements) # process all positions - else: - options.range = list(options.range) # convert to list - if options.getIncrements: - locations = [positionOfInc[x] for x in range(options.range[0],options.range[1]+1,options.range[2]) - if x in positionOfInc] - else: - locations = range( max(0,options.range[0]), - min(Nincrements,options.range[1]+1), - options.range[2] ) - - increments = [incAtPosition[x] for x in locations] # build list of increments to process - - return [increments,locations] - - -# ----------------------------- -def SummarizePostfile(stat,where=sys.stdout): - - where.write('\n\n') - where.write('title:\t%s'%stat['Title'] + '\n\n') - where.write('extraplation:\t%s'%stat['Extrapolation'] + '\n\n') - where.write('increments:\t%i'%(stat['NumberOfIncrements']) + '\n\n') - where.write('nodes:\t%i'%stat['NumberOfNodes'] + '\n\n') - where.write('elements:\t%i'%stat['NumberOfElements'] + '\n\n') - where.write('nodal scalars:\t%i'%stat['NumberOfNodalScalars'] + '\n\n '\ - +'\n '.join(stat['LabelOfNodalScalar']) + '\n\n') - where.write('elemental scalars:\t%i'%stat['NumberOfElementalScalars'] + '\n\n '\ - + '\n '.join(stat['LabelOfElementalScalar']) + '\n\n') - where.write('elemental tensors:\t%i'%stat['NumberOfElementalTensors'] + '\n\n '\ - + '\n '.join(stat['LabelOfElementalTensor']) + '\n\n') - - return True - - -# ----------------------------- -def SummarizeOutputfile(format,where=sys.stdout): - - where.write('\nUser Defined Outputs') - for what in format.keys(): - where.write('\n\n %s:'%what) - for output in format[what]['outputs']: - where.write('\n %s'%output) - - return True - - -# ----------------------------- -def writeHeader(myfile,stat,geomtype): - - myfile.write('2\theader\n') - myfile.write(string.replace('$Id$','\n','\\n')+ - '\t' + ' '.join(sys.argv[1:]) + '\n') - if geomtype == 'nodebased': - myfile.write('node') - for i in range(stat['NumberOfNodalScalars']): - myfile.write('\t%s'%''.join(stat['LabelOfNodalScalar'][i].split())) - - elif geomtype == 'ipbased': - myfile.write('elem\tip') - for i in range(stat['NumberOfElementalScalars']): - myfile.write('\t%s'%''.join(stat['LabelOfElementalScalar'][i].split())) - - myfile.write('\n') - - return True - - -# -------------------------------------------------------------------- -# MAIN -# -------------------------------------------------------------------- - -parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [file[s]]', description = """ -Extract data from a .t16 (MSC.Marc) results file. - -""", version = scriptID) - -parser.add_option('-i','--info', action='store_true', dest='info', \ - help='list contents of resultfile [%default]') -parser.add_option('-l','--legacy', action='store_true', dest='legacy', \ - help='legacy user result block (starts with GrainCount) [%default]') -parser.add_option('-d','--dir', dest='dir', \ - help='name of subdirectory to hold output [%default]') -parser.add_option('-r','--range', dest='range', type='int', nargs=3, \ - help='range of positions (or increments) to output (start, end, step) [all]') -parser.add_option('--increments', action='store_true', dest='getIncrements', \ - help='switch to increment range [%default]') -parser.add_option('-t','--type', dest='type', type='choice', choices=['ipbased','nodebased'], \ - help='processed geometry type [ipbased and nodebased]') - -group_material = OptionGroup(parser,'Material identifier') - -group_material.add_option('--homogenization', dest='homog', \ - help='homogenization identifier (as string or integer [%default])', metavar='') -group_material.add_option('--crystallite', dest='cryst', \ - help='crystallite identifier (as string or integer [%default])', metavar='') -group_material.add_option('--phase', dest='phase', \ - help='phase identifier (as string or integer [%default])', metavar='') - -parser.add_option_group(group_material) - -parser.set_defaults(info = False) -parser.set_defaults(legacy = False) -parser.set_defaults(dir = 'vtk') -parser.set_defaults(getIncrements= False) -parser.set_defaults(homog = '1') -parser.set_defaults(cryst = '1') -parser.set_defaults(phase = '1') - -(options, files) = parser.parse_args() - - -# --- sanity checks - -if files == []: - parser.print_help() - parser.error('no file specified...') - -filename = os.path.splitext(files[0])[0] -if not os.path.exists(filename+'.t16'): - parser.print_help() - parser.error('invalid file "%s" specified...'%filename+'.t16') - -sys.path.append(damask.solver.Marc().libraryPath('../../')) -try: - import py_post -except: - print('error: no valid Mentat release found') - sys.exit(-1) - -if not options.type : - options.type = ['nodebased', 'ipbased'] -else: - options.type = [options.type] - - -# --- initialize mesh data - -if damask.core.mesh.mesh_init_postprocessing(filename+'.mesh'): - print('error: init not successful') - sys.exit(-1) - - -# --- check if ip data available for all elements; if not, then .t19 file is required - -p = py_post.post_open(filename+'.t16') -asciiFile = False -p.moveto(1) -for e in range(p.elements()): - if not damask.core.mesh.mesh_get_nodeAtIP(str(p.element(e).type),1): - if os.path.exists(filename+'.t19'): - p.close() - p = py_post.post_open(filename+'.t19') - asciiFile = True - break - - -# --- parse *.output and *.t16 file - -outputFormat = ParseOutputFormat(filename,options.homog,options.cryst,options.phase) -p.moveto(1) -p.extrapolation('translate') -stat = ParsePostfile(p,filename,outputFormat,options.legacy) - - -# --- output info - -if options.info: - print '\n\nMentat release %s'%damask.solver.Marc().version('../../') - SummarizePostfile(stat) - SummarizeOutputfile(outputFormat) - sys.exit(0) - - -# --- create output dir - -dirname = os.path.abspath(os.path.join(os.path.dirname(filename),options.dir)) -if not os.path.isdir(dirname): - os.mkdir(dirname,0755) - - -# --- get positions - -[increments,locations] = GetIncrementLocations(p,stat['NumberOfIncrements'],options) - - -# --- loop over positions - -time_start = time.time() -for incCount,position in enumerate(locations): # walk through locations - p.moveto(position+1) # wind to correct position - time_delta = (float(len(locations)) / float(incCount+1) - 1.0) * (time.time() - time_start) - sys.stdout.write("\r(%02i:%02i:%02i) processing increment %i of %i..."\ - %(time_delta//3600,time_delta%3600//60,time_delta%60,incCount+1,len(locations))) - sys.stdout.flush() - -# --- write header - - outFilename = {} - for geomtype in options.type: - outFilename[geomtype] = eval('"'+eval("'%%s_%%s_inc%%0%ii.txt'%(math.log10(max(increments+[1]))+1)")\ - +'"%(dirname + os.sep + os.path.split(filename)[1],geomtype,increments[incCount])') - with open(outFilename[geomtype],'w') as myfile: - writeHeader(myfile,stat,geomtype) - - # --- write node based data - - if geomtype == 'nodebased': - for n in range(stat['NumberOfNodes']): - myfile.write(str(n)) - for l in range(stat['NumberOfNodalScalars']): - myfile.write('\t'+str(p.node_scalar(n,l))) - myfile.write('\n') - - # --- write ip based data - - elif geomtype == 'ipbased': - for e in range(stat['NumberOfElements']): - if asciiFile: - print 'ascii postfile not yet supported' - sys.exit(-1) - else: - ipData = [[]] - for l in range(stat['NumberOfElementalScalars']): - data = p.element_scalar(e,l) - for i in range(len(data)): # at least as many nodes as ips - node = damask.core.mesh.mesh_get_nodeAtIP(str(p.element(e).type),i+1) # fortran indexing starts at 1 - if not node: break # no more ips - while i >= len(ipData): ipData.append([]) - ipData[i].extend([data[node-1].value]) # python indexing starts at 0 - for i in range(len(ipData)): - myfile.write('\t'.join(map(str,[e,i]+ipData[i]))+'\n') - -p.close() -sys.stdout.write("\n")