From 4592db8dfb5094eeabbea89ad027c2e7ae6e4e17 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 24 Mar 2016 10:37:15 +0100 Subject: [PATCH 01/37] added python based geometry reconstruction --- processing/post/3Dvisualize.py | 51 +++++++++++++++++++++++++++++++++- 1 file changed, 50 insertions(+), 1 deletion(-) diff --git a/processing/post/3Dvisualize.py b/processing/post/3Dvisualize.py index c18fbb694..fb5465d41 100755 --- a/processing/post/3Dvisualize.py +++ b/processing/post/3Dvisualize.py @@ -9,6 +9,46 @@ import damask scriptName = os.path.splitext(os.path.basename(__file__))[0] scriptID = ' '.join([scriptName,damask.version]) +def deformedCoordsFFT(size,F,scaling,Favg=None): + grid = np.array(np.shape(F)[:-2]) + N = grid.prod() + step = size/grid + k_s = np.zeros([3],'i') + + F_fourier = np.fft.fftpack.rfftn(F,s=grid,axes=(0,1,2)) + coords_fourier = np.zeros(F_fourier.shape[:-1],'c16') + if Favg is None: + Favg = np.real(F_fourier[0,0,0,:,:]/N) + + for i in xrange(grid[2]//2+1): + k_s[2] = i + if grid[2]%2 == 0 and i == grid[2]//2: k_s[2] = 0 # for even grid, set Nyquist freq to 0 (Johnson, MIT, 2011) + + for j in xrange(grid[1]): + k_s[1] = j + if grid[1]%2 == 0 and j == grid[1]//2: k_s[1] = 0 # for even grid, set Nyquist freq to 0 (Johnson, MIT, 2011) + elif j > grid[1]//2: k_s[1] -= grid[1] + + for k in xrange(grid[0]): + k_s[0] = k + if grid[0]%2 == 0 and k == grid[0]//2: k_s[0] = 0 # for even grid, set Nyquist freq to 0 (Johnson, MIT, 2011) + elif k > grid[0]//2: k_s[0] -= grid[0] + + xi = 0.0+(k_s*0.5j*size/math.pi) + for m in xrange(3): + coords_fourier[k,j,i,m] = np.sum(F_fourier[k,j,i,m,:]*xi) + + if (any(k_s != 0)): + coords_fourier[k,j,i,:]/=-np.linalg.norm(k_s)**2.0 + + coords = np.fft.fftpack.irfftn(coords_fourier,s=grid,axes=(0,1,2)) + offset_coords =np.dot(F[0,0,0,:,:],step/2.0) - scaling*coords[0,0,0,:] + + for z in xrange(grid[2]): + for y in xrange(grid[1]): + for x in xrange(grid[0]): + coords[x,y,z,:] += offset_coords + np.dot(Favg,[x,y,z]*step) + def outStdout(cmd,locals): if cmd[0:3] == '(!)': exec(cmd[3:]) @@ -314,7 +354,16 @@ for filename in args: F = np.reshape(np.transpose(values[:,column['tensor'][options.defgrad]: column['tensor'][options.defgrad]+9]), (3,3,grid[0],grid[1],grid[2])) + F2 = np.reshape(values[:,column['tensor'][options.defgrad]: + column['tensor'][options.defgrad]+9], + (grid[0],grid[1],grid[2],3,3)) + for z in xrange(grid[2]): + for y in xrange(grid[1]): + for x in xrange(grid[0]): + F2[x,y,z,:,:] = F2[x,y,z,:,:].T + centroids2 = deformedCoordsFFT(dim,F2,options.scaling,None) centroids = damask.core.mesh.deformedCoordsFFT(dim,F,Favg,options.scaling) + nodes = damask.core.mesh.nodesAroundCentres(dim,Favg,centroids) fields = {\ @@ -430,4 +479,4 @@ for filename in args: vtk = open(os.path.join(head,what+'_'+os.path.splitext(tail)[0]+'.vtk'), 'w') output(out[what],{'filepointer':vtk},'File') vtk.close() - print \ No newline at end of file + print From 022b089fa7b46b3a71e1e968bdb47c58ba4aed6a Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 24 Mar 2016 11:49:23 +0100 Subject: [PATCH 02/37] cleaned core module related stuff --- code/Makefile | 7 +- code/commercialFEM_fileList.f90 | 1 - code/libs.f90 | 12 - code/mesh.f90 | 263 +- configure | 159 +- lib/IR_Precision.f90 | 1230 ----- lib/Lib_Base64.f90 | 909 ---- lib/Lib_VTK_IO.f90 | 6070 ---------------------- lib/fftw3.f03 | 1226 ----- processing/post/marc_deformedGeometry.py | 144 - processing/post/marc_extractData.py | 421 -- 11 files changed, 9 insertions(+), 10433 deletions(-) delete mode 100644 code/libs.f90 delete mode 100644 lib/IR_Precision.f90 delete mode 100644 lib/Lib_Base64.f90 delete mode 100644 lib/Lib_VTK_IO.f90 delete mode 100644 lib/fftw3.f03 delete mode 100755 processing/post/marc_deformedGeometry.py delete mode 100755 processing/post/marc_extractData.py 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") From 7d6ebfb71cc78233694e430b16232e27d6a108eb Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 24 Mar 2016 11:58:56 +0100 Subject: [PATCH 03/37] removed core module fftw functionality --- code/math.f90 | 19 ------------------- 1 file changed, 19 deletions(-) diff --git a/code/math.f90 b/code/math.f90 index bf7460062..b92610d50 100644 --- a/code/math.f90 +++ b/code/math.f90 @@ -72,10 +72,6 @@ module math 3_pInt,3_pInt & ],[2,9]) !< arrangement in Plain notation -#ifdef Spectral - include 'fftw3.f03' -#endif - public :: & math_init, & math_qsort, & @@ -163,21 +159,6 @@ module math math_rotate_forward33, & math_rotate_backward33, & math_rotate_forward3333 -#ifdef Spectral - public :: & - fftw_set_timelimit, & - fftw_plan_dft_3d, & - fftw_plan_many_dft_r2c, & - fftw_plan_many_dft_c2r, & - fftw_plan_with_nthreads, & - fftw_init_threads, & - fftw_alloc_complex, & - fftw_execute_dft, & - fftw_execute_dft_r2c, & - fftw_execute_dft_c2r, & - fftw_destroy_plan, & - math_tensorAvg -#endif private :: & math_partition, & halton, & From 60a3ac5b0462dc6533c5cc27253ea5c9fd5335c1 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 24 Mar 2016 12:35:33 +0100 Subject: [PATCH 04/37] copied fortran code --- processing/post/addCompatibilityMismatch.py | 145 +++++++++++++++++++- 1 file changed, 144 insertions(+), 1 deletion(-) diff --git a/processing/post/addCompatibilityMismatch.py b/processing/post/addCompatibilityMismatch.py index f237f7d19..20cdd284c 100755 --- a/processing/post/addCompatibilityMismatch.py +++ b/processing/post/addCompatibilityMismatch.py @@ -9,6 +9,150 @@ import damask scriptName = os.path.splitext(os.path.basename(__file__))[0] scriptID = ' '.join([scriptName,damask.version]) + +def volTetrahedron(vertices=None, sides=None): + """ + Return the volume of the tetrahedron with given vertices or sides. If + vertices are given they must be in a NumPy array with shape (4,3): the + position vectors of the 4 vertices in 3 dimensions; if the six sides are + given, they must be an array of length 6. If both are given, the sides + will be used in the calculation. + + This method implements + Tartaglia's formula using the Cayley-Menger determinant: + |0 1 1 1 1 | + |1 0 s1^2 s2^2 s3^2| + 288 V^2 = |1 s1^2 0 s4^2 s5^2| + |1 s2^2 s4^2 0 s6^2| + |1 s3^2 s5^2 s6^2 0 | + where s1, s2, ..., s6 are the tetrahedron side lengths. + + from http://codereview.stackexchange.com/questions/77593/calculating-the-volume-of-a-tetrahedron + + """ + + # The indexes of rows in the vertices array corresponding to all + # possible pairs of vertices + vertex_pair_indexes = np.array(((0, 1), (0, 2), (0, 3), + (1, 2), (1, 3), (2, 3))) + + # Get all the squares of all side lengths from the differences between + # the 6 different pairs of vertex positions + vertex1, vertex2 = vertex_pair_indexes[:,0], vertex_pair_indexes[:,1] + sides_squared = np.sum((vertices[vertex1] - vertices[vertex2])**2,axis=-1) + + + # Set up the Cayley-Menger determinant + M = np.zeros((5,5)) + # Fill in the upper triangle of the matrix + M[0,1:] = 1 + # The squared-side length elements can be indexed using the vertex + # pair indices (compare with the determinant illustrated above) + M[tuple(zip(*(vertex_pair_indexes + 1)))] = sides_squared + + # The matrix is symmetric, so we can fill in the lower triangle by + # adding the transpose + M = M + M.T + return np.sqrt(det / 288) + + +def mesh_volumeMismatch(size,F,nodes): + """ + calculates the mismatch between volume of reconstructed (compatible) cube and + determinant of defgrad at the FP + """ + real(pReal), intent(in), dimension(:,:,:,:,:) :: & + F + real(pReal), dimension(size(F,3),size(F,4),size(F,5)) :: & + vMismatch + real(pReal), intent(in), dimension(:,:,:,:) :: & + nodes + real(pReal), dimension(3,8) :: coords + + volInitial = size.prod()/grid.prod() + +#-------------------------------------------------------------------------------------------------- +# calculate actual volume and volume resulting from deformation gradient + for k in xrange(grid[2]): + for j in xrange(grid[1]): + for i in xrange(grid[0]): + coords(0:3,0) = nodes[0:3,i, j, k ] + coords(0:3,1) = nodes[0:3,i+1,j, k ] + coords(0:3,2) = nodes[0:3,i+1,j+1,k ] + coords(0:3,3) = nodes[0:3,i, j+1,k ] + coords(0:3,4) = nodes[0:3,i, j, k+1] + coords(0:3,5) = nodes[0:3,i+1,j, k+1] + coords(0:3,6) = nodes[0:3,i+1,j+1,k+1] + coords(0:3,7) = nodes[0:3,i, j+1,k+1] + vMismatch[i,j,k] = & + abs(volTetrahedron(coords[0:3,6],coords[0:3,0],coords[0:3,7],coords[0:3,3])) & + + abs(volTetrahedron(coords[0:3,6],coords[0:3,0],coords[0:3,7],coords[0:3,4])) & + + abs(volTetrahedron(coords[0:3,6],coords[0:3,0],coords[0:3,2],coords[0:3,3])) & + + abs(volTetrahedron(coords[0:3,6],coords[0:3,0],coords[0:3,2],coords[0:3,1])) & + + abs(volTetrahedron(coords[0:3,6],coords[0:3,4],coords[0:3,1],coords[0:3,5])) & + + abs(volTetrahedron(coords[0:3,6],coords[0:3,4],coords[0:3,1],coords[0:3,0])) + vMismatch[i,j,k] = vMismatch[i,j,k]/math_det33(F(1:3,1:3,i,j,k)) + enddo; enddo; enddo + + return vMismatch/volInitial + + + +def mesh_shapeMismatch(gDim,F,nodes,centres): + """ + Routine to calculate the mismatch between the vectors from the central point to + the corners of reconstructed (combatible) volume element and the vectors calculated by deforming + the initial volume element with the current deformation gradient + """ + + implicit none + real(pReal), intent(in), dimension(:,:,:,:,:) :: & + F + real(pReal), dimension(size(F,3),size(F,4),size(F,5)) :: & + sMismatch + real(pReal), intent(in), dimension(:,:,:,:) :: & + nodes, & + centres + real(pReal), dimension(3,8) :: coordsInitial + integer(pInt) i,j,k + +!-------------------------------------------------------------------------------------------------- +! initial positions + coordsInitial(1:3,1) = [-gDim(1)/fRes(1),-gDim(2)/fRes(2),-gDim(3)/fRes(3)] + coordsInitial(1:3,2) = [+gDim(1)/fRes(1),-gDim(2)/fRes(2),-gDim(3)/fRes(3)] + coordsInitial(1:3,3) = [+gDim(1)/fRes(1),+gDim(2)/fRes(2),-gDim(3)/fRes(3)] + coordsInitial(1:3,4) = [-gDim(1)/fRes(1),+gDim(2)/fRes(2),-gDim(3)/fRes(3)] + coordsInitial(1:3,5) = [-gDim(1)/fRes(1),-gDim(2)/fRes(2),+gDim(3)/fRes(3)] + coordsInitial(1:3,6) = [+gDim(1)/fRes(1),-gDim(2)/fRes(2),+gDim(3)/fRes(3)] + coordsInitial(1:3,7) = [+gDim(1)/fRes(1),+gDim(2)/fRes(2),+gDim(3)/fRes(3)] + coordsInitial(1:3,8) = [-gDim(1)/fRes(1),+gDim(2)/fRes(2),+gDim(3)/fRes(3)] + coordsInitial = coordsInitial/2.0_pReal + +!-------------------------------------------------------------------------------------------------- +! compare deformed original and deformed positions to actual positions + do k = 1_pInt,iRes(3) + do j = 1_pInt,iRes(2) + do i = 1_pInt,iRes(1) + sMismatch(i,j,k) = & + sqrt(sum((nodes(1:3,i, j, k ) - centres(1:3,i,j,k)& + - math_mul33x3(F(1:3,1:3,i,j,k), coordsInitial(1:3,1)))**2.0_pReal))& + + sqrt(sum((nodes(1:3,i+1_pInt,j, k ) - centres(1:3,i,j,k)& + - math_mul33x3(F(1:3,1:3,i,j,k), coordsInitial(1:3,2)))**2.0_pReal))& + + sqrt(sum((nodes(1:3,i+1_pInt,j+1_pInt,k ) - centres(1:3,i,j,k)& + - math_mul33x3(F(1:3,1:3,i,j,k), coordsInitial(1:3,3)))**2.0_pReal))& + + sqrt(sum((nodes(1:3,i, j+1_pInt,k ) - centres(1:3,i,j,k)& + - math_mul33x3(F(1:3,1:3,i,j,k), coordsInitial(1:3,4)))**2.0_pReal))& + + sqrt(sum((nodes(1:3,i, j, k+1_pInt) - centres(1:3,i,j,k)& + - math_mul33x3(F(1:3,1:3,i,j,k), coordsInitial(1:3,5)))**2.0_pReal))& + + sqrt(sum((nodes(1:3,i+1_pInt,j, k+1_pInt) - centres(1:3,i,j,k)& + - math_mul33x3(F(1:3,1:3,i,j,k), coordsInitial(1:3,6)))**2.0_pReal))& + + sqrt(sum((nodes(1:3,i+1_pInt,j+1_pInt,k+1_pInt) - centres(1:3,i,j,k)& + - math_mul33x3(F(1:3,1:3,i,j,k), coordsInitial(1:3,7)))**2.0_pReal))& + + sqrt(sum((nodes(1:3,i, j+1_pInt,k+1_pInt) - centres(1:3,i,j,k)& + - math_mul33x3(F(1:3,1:3,i,j,k), coordsInitial(1:3,8)))**2.0_pReal)) + enddo; enddo; enddo + return sMismatch + # -------------------------------------------------------------------- # MAIN # -------------------------------------------------------------------- @@ -117,7 +261,6 @@ for name in filenames: idx += 1 F[0:3,0:3,x,y,z] = np.array(map(float,table.data[column:column+9]),'d').reshape(3,3) - Favg = damask.core.math.tensorAvg(F) centres = damask.core.mesh.deformedCoordsFFT(size,F,Favg,[1.0,1.0,1.0]) nodes = damask.core.mesh.nodesAroundCentres(size,Favg,centres) From 8b8906311317061dd5f68ba15d9414fb65dd7b64 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 24 Mar 2016 14:19:00 +0100 Subject: [PATCH 05/37] less core module --- processing/post/addCompatibilityMismatch.py | 141 +++++++++----------- 1 file changed, 60 insertions(+), 81 deletions(-) diff --git a/processing/post/addCompatibilityMismatch.py b/processing/post/addCompatibilityMismatch.py index 20cdd284c..8c9e479ec 100755 --- a/processing/post/addCompatibilityMismatch.py +++ b/processing/post/addCompatibilityMismatch.py @@ -10,7 +10,7 @@ scriptName = os.path.splitext(os.path.basename(__file__))[0] scriptID = ' '.join([scriptName,damask.version]) -def volTetrahedron(vertices=None, sides=None): +def volTetrahedron(coords): """ Return the volume of the tetrahedron with given vertices or sides. If vertices are given they must be in a NumPy array with shape (4,3): the @@ -38,6 +38,7 @@ def volTetrahedron(vertices=None, sides=None): # Get all the squares of all side lengths from the differences between # the 6 different pairs of vertex positions + vertices = np.concatenate((coords[0],coords[1],coords[2],coords[3])).reshape([4,3]) vertex1, vertex2 = vertex_pair_indexes[:,0], vertex_pair_indexes[:,1] sides_squared = np.sum((vertices[vertex1] - vertices[vertex2])**2,axis=-1) @@ -53,105 +54,83 @@ def volTetrahedron(vertices=None, sides=None): # The matrix is symmetric, so we can fill in the lower triangle by # adding the transpose M = M + M.T - return np.sqrt(det / 288) + return np.sqrt(np.linalg.det(M) / 288) -def mesh_volumeMismatch(size,F,nodes): +def volumeMismatch(size,F,nodes): """ calculates the mismatch between volume of reconstructed (compatible) cube and determinant of defgrad at the FP """ - real(pReal), intent(in), dimension(:,:,:,:,:) :: & - F - real(pReal), dimension(size(F,3),size(F,4),size(F,5)) :: & - vMismatch - real(pReal), intent(in), dimension(:,:,:,:) :: & - nodes - real(pReal), dimension(3,8) :: coords - volInitial = size.prod()/grid.prod() + coords = np.empty([8,3]) + vMismatch = np.empty(grid) + volInitial = size.prod()/grid.prod() #-------------------------------------------------------------------------------------------------- # calculate actual volume and volume resulting from deformation gradient - for k in xrange(grid[2]): - for j in xrange(grid[1]): - for i in xrange(grid[0]): - coords(0:3,0) = nodes[0:3,i, j, k ] - coords(0:3,1) = nodes[0:3,i+1,j, k ] - coords(0:3,2) = nodes[0:3,i+1,j+1,k ] - coords(0:3,3) = nodes[0:3,i, j+1,k ] - coords(0:3,4) = nodes[0:3,i, j, k+1] - coords(0:3,5) = nodes[0:3,i+1,j, k+1] - coords(0:3,6) = nodes[0:3,i+1,j+1,k+1] - coords(0:3,7) = nodes[0:3,i, j+1,k+1] - vMismatch[i,j,k] = & - abs(volTetrahedron(coords[0:3,6],coords[0:3,0],coords[0:3,7],coords[0:3,3])) & - + abs(volTetrahedron(coords[0:3,6],coords[0:3,0],coords[0:3,7],coords[0:3,4])) & - + abs(volTetrahedron(coords[0:3,6],coords[0:3,0],coords[0:3,2],coords[0:3,3])) & - + abs(volTetrahedron(coords[0:3,6],coords[0:3,0],coords[0:3,2],coords[0:3,1])) & - + abs(volTetrahedron(coords[0:3,6],coords[0:3,4],coords[0:3,1],coords[0:3,5])) & - + abs(volTetrahedron(coords[0:3,6],coords[0:3,4],coords[0:3,1],coords[0:3,0])) - vMismatch[i,j,k] = vMismatch[i,j,k]/math_det33(F(1:3,1:3,i,j,k)) - enddo; enddo; enddo + for k in xrange(grid[2]): + for j in xrange(grid[1]): + for i in xrange(grid[0]): + coords[0,0:3] = nodes[0:3,i, j, k ] + coords[1,0:3] = nodes[0:3,i+1,j, k ] + coords[2,0:3] = nodes[0:3,i+1,j+1,k ] + coords[3,0:3] = nodes[0:3,i, j+1,k ] + coords[4,0:3] = nodes[0:3,i, j, k+1] + coords[5,0:3] = nodes[0:3,i+1,j, k+1] + coords[6,0:3] = nodes[0:3,i+1,j+1,k+1] + coords[7,0:3] = nodes[0:3,i, j+1,k+1] + vMismatch[i,j,k] = \ + abs(volTetrahedron([coords[6,0:3],coords[0,0:3],coords[7,0:3],coords[3,0:3]])) \ + + abs(volTetrahedron([coords[6,0:3],coords[0,0:3],coords[7,0:3],coords[4,0:3]])) \ + + abs(volTetrahedron([coords[6,0:3],coords[0,0:3],coords[2,0:3],coords[3,0:3]])) \ + + abs(volTetrahedron([coords[6,0:3],coords[0,0:3],coords[2,0:3],coords[1,0:3]])) \ + + abs(volTetrahedron([coords[6,0:3],coords[4,0:3],coords[1,0:3],coords[5,0:3]])) \ + + abs(volTetrahedron([coords[6,0:3],coords[4,0:3],coords[1,0:3],coords[0,0:3]])) + vMismatch[i,j,k] = vMismatch[i,j,k]/np.linalg.det(F[0:3,0:3,i,j,k]) - return vMismatch/volInitial + return vMismatch/volInitial -def mesh_shapeMismatch(gDim,F,nodes,centres): +def shapeMismatch(size,F,nodes,centres): """ Routine to calculate the mismatch between the vectors from the central point to the corners of reconstructed (combatible) volume element and the vectors calculated by deforming the initial volume element with the current deformation gradient """ - implicit none - real(pReal), intent(in), dimension(:,:,:,:,:) :: & - F - real(pReal), dimension(size(F,3),size(F,4),size(F,5)) :: & - sMismatch - real(pReal), intent(in), dimension(:,:,:,:) :: & - nodes, & - centres - real(pReal), dimension(3,8) :: coordsInitial - integer(pInt) i,j,k + coordsInitial = np.empty([8,3]) + sMismatch = np.empty(grid) -!-------------------------------------------------------------------------------------------------- -! initial positions - coordsInitial(1:3,1) = [-gDim(1)/fRes(1),-gDim(2)/fRes(2),-gDim(3)/fRes(3)] - coordsInitial(1:3,2) = [+gDim(1)/fRes(1),-gDim(2)/fRes(2),-gDim(3)/fRes(3)] - coordsInitial(1:3,3) = [+gDim(1)/fRes(1),+gDim(2)/fRes(2),-gDim(3)/fRes(3)] - coordsInitial(1:3,4) = [-gDim(1)/fRes(1),+gDim(2)/fRes(2),-gDim(3)/fRes(3)] - coordsInitial(1:3,5) = [-gDim(1)/fRes(1),-gDim(2)/fRes(2),+gDim(3)/fRes(3)] - coordsInitial(1:3,6) = [+gDim(1)/fRes(1),-gDim(2)/fRes(2),+gDim(3)/fRes(3)] - coordsInitial(1:3,7) = [+gDim(1)/fRes(1),+gDim(2)/fRes(2),+gDim(3)/fRes(3)] - coordsInitial(1:3,8) = [-gDim(1)/fRes(1),+gDim(2)/fRes(2),+gDim(3)/fRes(3)] - coordsInitial = coordsInitial/2.0_pReal +#-------------------------------------------------------------------------------------------------- +# initial positions + coordsInitial[0,0:3] = [-size[0]/grid[0],-size[1]/grid[1],-size[2]/grid[2]] + coordsInitial[1,0:3] = [+size[0]/grid[0],-size[1]/grid[1],-size[2]/grid[2]] + coordsInitial[2,0:3] = [+size[0]/grid[0],+size[1]/grid[1],-size[2]/grid[2]] + coordsInitial[3,0:3] = [-size[0]/grid[0],+size[1]/grid[1],-size[2]/grid[2]] + coordsInitial[4,0:3] = [-size[0]/grid[0],-size[1]/grid[1],+size[2]/grid[2]] + coordsInitial[5,0:3] = [+size[0]/grid[0],-size[1]/grid[1],+size[2]/grid[2]] + coordsInitial[6,0:3] = [+size[0]/grid[0],+size[1]/grid[1],+size[2]/grid[2]] + coordsInitial[7,0:3] = [-size[0]/grid[0],+size[1]/grid[1],+size[2]/grid[2]] + coordsInitial = coordsInitial/2.0 -!-------------------------------------------------------------------------------------------------- -! compare deformed original and deformed positions to actual positions - do k = 1_pInt,iRes(3) - do j = 1_pInt,iRes(2) - do i = 1_pInt,iRes(1) - sMismatch(i,j,k) = & - sqrt(sum((nodes(1:3,i, j, k ) - centres(1:3,i,j,k)& - - math_mul33x3(F(1:3,1:3,i,j,k), coordsInitial(1:3,1)))**2.0_pReal))& - + sqrt(sum((nodes(1:3,i+1_pInt,j, k ) - centres(1:3,i,j,k)& - - math_mul33x3(F(1:3,1:3,i,j,k), coordsInitial(1:3,2)))**2.0_pReal))& - + sqrt(sum((nodes(1:3,i+1_pInt,j+1_pInt,k ) - centres(1:3,i,j,k)& - - math_mul33x3(F(1:3,1:3,i,j,k), coordsInitial(1:3,3)))**2.0_pReal))& - + sqrt(sum((nodes(1:3,i, j+1_pInt,k ) - centres(1:3,i,j,k)& - - math_mul33x3(F(1:3,1:3,i,j,k), coordsInitial(1:3,4)))**2.0_pReal))& - + sqrt(sum((nodes(1:3,i, j, k+1_pInt) - centres(1:3,i,j,k)& - - math_mul33x3(F(1:3,1:3,i,j,k), coordsInitial(1:3,5)))**2.0_pReal))& - + sqrt(sum((nodes(1:3,i+1_pInt,j, k+1_pInt) - centres(1:3,i,j,k)& - - math_mul33x3(F(1:3,1:3,i,j,k), coordsInitial(1:3,6)))**2.0_pReal))& - + sqrt(sum((nodes(1:3,i+1_pInt,j+1_pInt,k+1_pInt) - centres(1:3,i,j,k)& - - math_mul33x3(F(1:3,1:3,i,j,k), coordsInitial(1:3,7)))**2.0_pReal))& - + sqrt(sum((nodes(1:3,i, j+1_pInt,k+1_pInt) - centres(1:3,i,j,k)& - - math_mul33x3(F(1:3,1:3,i,j,k), coordsInitial(1:3,8)))**2.0_pReal)) - enddo; enddo; enddo - return sMismatch +#-------------------------------------------------------------------------------------------------- +# compare deformed original and deformed positions to actual positions + for k in xrange(grid[2]): + for j in xrange(grid[1]): + for i in xrange(grid[0]): + sMismatch[i,j,k] = \ + np.linalg.norm(nodes[0:3,i, j, k] - centres[0:3,i,j,k] - np.dot(F[:,:,i,j,k], coordsInitial[0,0:3]))\ + + np.linalg.norm(nodes[0:3,i+1,j, k] - centres[0:3,i,j,k] - np.dot(F[:,:,i,j,k], coordsInitial[1,0:3]))\ + + np.linalg.norm(nodes[0:3,i+1,j+1,k ] - centres[0:3,i,j,k] - np.dot(F[:,:,i,j,k], coordsInitial[2,0:3]))\ + + np.linalg.norm(nodes[0:3,i, j+1,k ] - centres[0:3,i,j,k] - np.dot(F[:,:,i,j,k], coordsInitial[3,0:3]))\ + + np.linalg.norm(nodes[0:3,i, j, k+1] - centres[0:3,i,j,k] - np.dot(F[:,:,i,j,k], coordsInitial[4,0:3]))\ + + np.linalg.norm(nodes[0:3,i+1,j, k+1] - centres[0:3,i,j,k] - np.dot(F[:,:,i,j,k], coordsInitial[5,0:3]))\ + + np.linalg.norm(nodes[0:3,i+1,j+1,k+1] - centres[0:3,i,j,k] - np.dot(F[:,:,i,j,k], coordsInitial[6,0:3]))\ + + np.linalg.norm(nodes[0:3,i, j+1,k+1] - centres[0:3,i,j,k] - np.dot(F[:,:,i,j,k], coordsInitial[7,0:3])) + return sMismatch + # -------------------------------------------------------------------- # MAIN @@ -260,12 +239,12 @@ for name in filenames: (x,y,z) = damask.util.gridLocation(idx,grid) # figure out (x,y,z) position from line count idx += 1 F[0:3,0:3,x,y,z] = np.array(map(float,table.data[column:column+9]),'d').reshape(3,3) - + Favg = damask.core.math.tensorAvg(F) centres = damask.core.mesh.deformedCoordsFFT(size,F,Favg,[1.0,1.0,1.0]) nodes = damask.core.mesh.nodesAroundCentres(size,Favg,centres) - if options.shape: shapeMismatch = damask.core.mesh.shapeMismatch( size,F,nodes,centres) - if options.volume: volumeMismatch = damask.core.mesh.volumeMismatch(size,F,nodes) + if options.shape: shapeMismatch = shapeMismatch( size,F,nodes,centres) + if options.volume: volumeMismatch = volumeMismatch(size,F,nodes) # ------------------------------------------ process data ------------------------------------------ table.data_rewind() From d765282165ee598891bc8b27ff25cd35e20ddb2a Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 24 Mar 2016 14:20:18 +0100 Subject: [PATCH 06/37] save fortran code --- lib/damask/util.py | 90 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 90 insertions(+) diff --git a/lib/damask/util.py b/lib/damask/util.py index 244aaa25c..81eb30713 100644 --- a/lib/damask/util.py +++ b/lib/damask/util.py @@ -451,3 +451,93 @@ def curve_fit_bound(f, xdata, ydata, p0=None, sigma=None, bounds=None, **kw): pcov = np.inf return (popt, pcov, infodict, errmsg, ier) if return_full else (popt, pcov) + + +!-------------------------------------------------------------------------------------------------- +!> @brief builds mesh of (distorted) cubes for given coordinates (= center of the cubes) +!-------------------------------------------------------------------------------------------------- +function mesh_nodesAroundCentres(gDim,Favg,centres) result(nodes) + use debug, only: & + debug_mesh, & + debug_level, & + debug_levelBasic + use math, only: & + math_mul33x3 + + implicit none + real(pReal), intent(in), dimension(:,:,:,:) :: & + centres + real(pReal), dimension(3,size(centres,2)+1,size(centres,3)+1,size(centres,4)+1) :: & + nodes + real(pReal), intent(in), dimension(3) :: & + gDim + real(pReal), intent(in), dimension(3,3) :: & + Favg + real(pReal), dimension(3,size(centres,2)+2,size(centres,3)+2,size(centres,4)+2) :: & + wrappedCentres + + integer(pInt) :: & + i,j,k,n + integer(pInt), dimension(3), parameter :: & + diag = 1_pInt + integer(pInt), dimension(3) :: & + shift = 0_pInt, & + lookup = 0_pInt, & + me = 0_pInt, & + iRes = 0_pInt + integer(pInt), dimension(3,8) :: & + neighbor = reshape([ & + 0_pInt, 0_pInt, 0_pInt, & + 1_pInt, 0_pInt, 0_pInt, & + 1_pInt, 1_pInt, 0_pInt, & + 0_pInt, 1_pInt, 0_pInt, & + 0_pInt, 0_pInt, 1_pInt, & + 1_pInt, 0_pInt, 1_pInt, & + 1_pInt, 1_pInt, 1_pInt, & + 0_pInt, 1_pInt, 1_pInt ], [3,8]) + +!-------------------------------------------------------------------------------------------------- +! initializing variables + iRes = [size(centres,2),size(centres,3),size(centres,4)] + nodes = 0.0_pReal + wrappedCentres = 0.0_pReal + +!-------------------------------------------------------------------------------------------------- +! report + if (iand(debug_level(debug_mesh),debug_levelBasic) /= 0_pInt) then + write(6,'(a)') ' Meshing cubes around centroids' + write(6,'(a,3(e12.5))') ' Dimension: ', gDim + write(6,'(a,3(i5))') ' Resolution:', iRes + endif + +!-------------------------------------------------------------------------------------------------- +! building wrappedCentres = centroids + ghosts + wrappedCentres(1:3,2_pInt:iRes(1)+1_pInt,2_pInt:iRes(2)+1_pInt,2_pInt:iRes(3)+1_pInt) = centres + do k = 0_pInt,iRes(3)+1_pInt + do j = 0_pInt,iRes(2)+1_pInt + do i = 0_pInt,iRes(1)+1_pInt + if (k==0_pInt .or. k==iRes(3)+1_pInt .or. & ! z skin + j==0_pInt .or. j==iRes(2)+1_pInt .or. & ! y skin + i==0_pInt .or. i==iRes(1)+1_pInt ) then ! x skin + me = [i,j,k] ! me on skin + shift = sign(abs(iRes+diag-2_pInt*me)/(iRes+diag),iRes+diag-2_pInt*me) + lookup = me-diag+shift*iRes + wrappedCentres(1:3,i+1_pInt, j+1_pInt, k+1_pInt) = & + centres(1:3,lookup(1)+1_pInt,lookup(2)+1_pInt,lookup(3)+1_pInt) - & + math_mul33x3(Favg, shift*gDim) + endif + enddo; enddo; enddo + +!-------------------------------------------------------------------------------------------------- +! averaging + do k = 0_pInt,iRes(3); do j = 0_pInt,iRes(2); do i = 0_pInt,iRes(1) + do n = 1_pInt,8_pInt + nodes(1:3,i+1_pInt,j+1_pInt,k+1_pInt) = & + nodes(1:3,i+1_pInt,j+1_pInt,k+1_pInt) + wrappedCentres(1:3,i+1_pInt+neighbor(1,n), & + j+1_pInt+neighbor(2,n), & + k+1_pInt+neighbor(3,n) ) + enddo + enddo; enddo; enddo + nodes = nodes/8.0_pReal + +end function mesh_nodesAroundCentres From c73382e51f62adeba2f2afb6e8484a45c7dce4f9 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 24 Mar 2016 14:36:24 +0100 Subject: [PATCH 07/37] further cleaning --- Makefile | 1 - lib/damask/__init__.py | 32 -------------------------------- 2 files changed, 33 deletions(-) diff --git a/Makefile b/Makefile index 8be738090..1850f6cca 100755 --- a/Makefile +++ b/Makefile @@ -25,7 +25,6 @@ processing: rm -rv build; \ rm *.c; \ fi - @./installation/compile_CoreModule.py ${MAKEFLAGS} .PHONY: tidy tidy: diff --git a/lib/damask/__init__.py b/lib/damask/__init__.py index 1b6ec409d..c25fc0bd8 100644 --- a/lib/damask/__init__.py +++ b/lib/damask/__init__.py @@ -22,35 +22,3 @@ from .geometry import Geometry # noqa from .solver import Solver # noqa from .test import Test # noqa from .util import extendableOption # noqa - -try: - from . import core -# cleaning up namespace -################################################################################################### -# capitalize according to convention - core.IO = core.io - core.FEsolving = core.fesolving - core.DAMASK_interface = core.damask_interface -# remove modulePrefix_ - core.prec.init = core.prec.prec_init - core.DAMASK_interface.init = core.DAMASK_interface.DAMASK_interface_init - core.IO.init = core.IO.IO_init - core.numerics.init = core.numerics.numerics_init - core.debug.init = core.debug.debug_init - core.math.init = core.math.math_init - core.math.tensorAvg = core.math.math_tensorAvg - core.FEsolving.init = core.FEsolving.FE_init - core.mesh.init = core.mesh.mesh_init - core.mesh.nodesAroundCentres = core.mesh.mesh_nodesAroundCentres - core.mesh.deformedCoordsFFT = core.mesh.mesh_deformedCoordsFFT - core.mesh.volumeMismatch = core.mesh.mesh_volumeMismatch - core.mesh.shapeMismatch = core.mesh.mesh_shapeMismatch - -except (ImportError,AttributeError) as e: - core = None # from http://www.python.org/dev/peps/pep-0008/ - if os.path.split(sys.argv[0])[1] not in ('symLink_Processing.py', - 'compile_CoreModule.py', - ): - sys.stderr.write('\nWARNING: Core module (Fortran code) not available, \n'\ - "try to run 'make processing'\n"\ - 'Error message when importing core.so: %s\n\n'%e) From 3824b683bcf3f246f565bef9348f73b61f5f7740 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 24 Mar 2016 15:06:04 +0100 Subject: [PATCH 08/37] removed extra cython file, symlink to standard orientation instead --- Makefile | 1 + lib/damask/.gitignore | 1 + lib/damask/__init__.py | 11 +- lib/damask/corientation.pyx | 1277 ----------------------------------- 4 files changed, 7 insertions(+), 1283 deletions(-) delete mode 100644 lib/damask/corientation.pyx diff --git a/Makefile b/Makefile index 1850f6cca..6c63d01f6 100755 --- a/Makefile +++ b/Makefile @@ -21,6 +21,7 @@ marc: processing: @if hash cython 2>/dev/null; then \ cd ./lib/damask; \ + ln -s orientation.py corientation.pyx; \ CC=gcc python setup_corientation.py build_ext --inplace; \ rm -rv build; \ rm *.c; \ diff --git a/lib/damask/.gitignore b/lib/damask/.gitignore index 00feaa11f..1b8936623 100644 --- a/lib/damask/.gitignore +++ b/lib/damask/.gitignore @@ -1,2 +1,3 @@ core.so corientation.so +*.pyx diff --git a/lib/damask/__init__.py b/lib/damask/__init__.py index c25fc0bd8..dc40920fa 100644 --- a/lib/damask/__init__.py +++ b/lib/damask/__init__.py @@ -10,12 +10,11 @@ from .environment import Environment # noqa from .asciitable import ASCIItable # noqa from .config import Material # noqa from .colormaps import Colormap, Color # noqa -from .orientation import Quaternion, Rodrigues, Symmetry, Orientation # noqa -# try: -# from .corientation import Quaternion, Rodrigues, Symmetry, Orientation -# print "Import Cython version of Orientation module" -# except: -# from .orientation import Quaternion, Rodrigues, Symmetry, Orientation +try: + from .corientation import Quaternion, Rodrigues, Symmetry, Orientation + print "Import Cython version of Orientation module" +except: + from .orientation import Quaternion, Rodrigues, Symmetry, Orientation #from .block import Block # only one class from .result import Result # noqa from .geometry import Geometry # noqa diff --git a/lib/damask/corientation.pyx b/lib/damask/corientation.pyx deleted file mode 100644 index 6da6ba8a5..000000000 --- a/lib/damask/corientation.pyx +++ /dev/null @@ -1,1277 +0,0 @@ -#!/usr/bin/env python -# encoding: utf-8 -# filename: corientation.pyx - -# __ __ __________ ____ __ ____ ______ ____ -# / //_// ____/ __ \/ __ \/ //_/ / / / __ \/ __ \ -# / ,< / __/ / / / / / / / ,< / / / / / / / / / / -# / /| |/ /___/ /_/ / /_/ / /| / /_/ / /_/ / /_/ / -# /_/ |_/_____/_____/\____/_/ |_\____/_____/\____/ - - -###################################################### -# This is a Cython implementation of original DAMASK # -# orientation class, mainly for speed improvement. # -###################################################### - -""" -NOTE ----- -The static method in Cython is different from Python, need more -time to figure out details. -""" - -import math, random, os -import numpy as np -cimport numpy as np - - -## -# This Rodrigues class is odd, not sure if it will function -# properly or not -cdef class Rodrigues: - """Rodrigues representation of orientation """ - cdef public double[3] r - - def __init__(self, vector): - if isinstance(vector, Rodrigues): - self.r[0] = vector.r[0] - self.r[1] = vector.r[1] - self.r[2] = vector.r[2] - else: - self.r[0] = vector[0] - self.r[1] = vector[1] - self.r[2] = vector[2] - - def asQuaternion(self): - cdef double norm, halfAngle - cdef double[4] q - - norm = np.linalg.norm(self.vector) - halfAngle = np.arctan(norm) - q[0] = np.cos(halfAngle) - tmp = np.sin(halfAngle)*self.vector/norm - q[1],q[2],q[3] = tmp[0],tmp[1],tmp[2] - - return Quaternion(q) - - def asAngleAxis(self): - cdef double norm, halfAngle - - norm = np.linalg.norm(self.vector) - halfAngle = np.arctan(norm) - - return (2.0*halfAngle,self.vector/norm) - - -## -# The Quaternion class do the heavy lifting of orientation -# calculation -cdef class Quaternion: - """ Quaternion representation of orientation """ - # All methods and naming conventions based off - # http://www.euclideanspace.com/maths/algebra/realNormedAlgebra/quaternions - cdef public double w,x,y,z - - def __init__(self, data): - """ - @description - ------------ - copy constructor friendly - @parameters - ----------- - data: array - """ - cdef double[4] q - - if isinstance(data, Quaternion): - q[0] = data.w - q[1] = data.x - q[2] = data.y - q[3] = data.z - else: - q[0] = data[0] - q[1] = data[1] - q[2] = data[2] - q[3] = data[3] - - self.Quaternion(q) - - cdef Quaternion(self, double* quatArray): - """ - @description - ------------ - internal constructor for Quaternion - @parameters - ----------- - quatArray: double[4] // - w is the real part, (x, y, z) are the imaginary parts - """ - if quatArray[0] < 0: - self.w = -quatArray[0] - self.x = -quatArray[1] - self.y = -quatArray[2] - self.z = -quatArray[3] - else: - self.w = quatArray[0] - self.x = quatArray[1] - self.y = quatArray[2] - self.z = quatArray[3] - - def __copy__(self): - cdef double[4] q = [self.w,self.x,self.y,self.z] - return Quaternion(q) - - copy = __copy__ - - def __iter__(self): - return iter([self.w,self.x,self.y,self.z]) - - def __repr__(self): - return 'Quaternion(real={:.4f},imag=<{:.4f},{:.4f}, {:.4f}>)'.format(self.w, - self.x, - self.y, - self.z) - - def __pow__(self, exponent, modulo): - # declare local var for speed gain - cdef double omega, vRescale - cdef double[4] q - - omega = math.acos(self.w) - vRescale = math.sin(exponent*omega)/math.sin(omega) - - q[0] = math.cos(exponent*omega) - q[1] = self.x*vRescale - q[2] = self.y*vRescale - q[3] = self.z*vRescale - return Quaternion(q) - - def __ipow__(self, exponent): - self = self.__pow__(self, exponent, 1.0) - return self - - def __mul__(self, other): - # declare local var for speed gain - cdef double Aw,Ax,Ay,Az,Bw,Bx,By,Bz - cdef double w,x,y,z,Vx,Vy,Vz - cdef double[4] q - - # quaternion * quaternion - try: - Aw = self.w - Ax = self.x - Ay = self.y - Az = self.z - Bw = other.w - Bx = other.x - By = other.y - Bz = other.z - q[0] = - Ax * Bx - Ay * By - Az * Bz + Aw * Bw - q[1] = + Ax * Bw + Ay * Bz - Az * By + Aw * Bx - q[2] = - Ax * Bz + Ay * Bw + Az * Bx + Aw * By - q[3] = + Ax * By - Ay * Bx + Az * Bw + Aw * Bz - return Quaternion(q) - except: - pass - # vector (perform active rotation, i.e. q*v*q.conjugated) - try: - w = self.w - x = self.x - y = self.y - z = self.z - Vx = other[0] - Vy = other[1] - Vz = other[2] - return np.array([\ - w * w * Vx + 2 * y * w * Vz - 2 * z * w * Vy + \ - x * x * Vx + 2 * y * x * Vy + 2 * z * x * Vz - \ - z * z * Vx - y * y * Vx, - 2 * x * y * Vx + y * y * Vy + 2 * z * y * Vz + \ - 2 * w * z * Vx - z * z * Vy + w * w * Vy - \ - 2 * x * w * Vz - x * x * Vy, - 2 * x * z * Vx + 2 * y * z * Vy + \ - z * z * Vz - 2 * w * y * Vx - y * y * Vz + \ - 2 * w * x * Vy - x * x * Vz + w * w * Vz ]) - except: - pass - # quaternion * scalar - try: - Q = self.copy() - Q.w *= other - Q.x *= other - Q.y *= other - Q.z *= other - return Q - except: - return self.copy() - - def __imul__(self, other): - if isinstance(other, Quaternion): - self = self.__mul__(other) - return self - else: - return NotImplemented - - def __div__(self, other): - cdef double[4] q - - if isinstance(other, (int,float,long)): - q[0] = self.w / other - q[1] = self.x / other - q[2] = self.y / other - q[3] = self.z / other - return Quaternion(q) - else: - NotImplemented - - def __idiv__(self, other): - self = self.__div__(other) - return self - - def __add__(self, other): - cdef double[4] q - - if isinstance(other, Quaternion): - q[0] = self.w + other.w - q[1] = self.x + other.x - q[2] = self.y + other.y - q[3] = self.z + other.z - return self.__class__(q) - else: - return NotImplemented - - def __iadd__(self, other): - self = self.__add__(other) - return self - - def __sub__(self, other): - cdef double[4] q - - if isinstance(other, Quaternion): - q[0] = self.w - other.w - q[1] = self.x - other.x - q[2] = self.y - other.y - q[3] = self.z - other.z - return self.__class__(q) - else: - return NotImplemented - - def __isub__(self, other): - self = self.__sub__(other) - return self - - def __neg__(self): - cdef double[4] q - - q[0] = -self.w - q[1] = -self.x - q[2] = -self.y - q[3] = -self.z - - return self.__class__(q) - - def __abs__(self): - cdef double tmp - - tmp = self.w**2 + self.x**2 + self.y**2 + self.z**2 - tmp = math.sqrt(tmp) - return tmp - - magnitude = __abs__ - - def __richcmp__(Quaternion self, Quaternion other, int op): - cdef bint tmp - - tmp = (abs(self.w-other.w) < 1e-8 and \ - abs(self.x-other.x) < 1e-8 and \ - abs(self.y-other.y) < 1e-8 and \ - abs(self.z-other.z) < 1e-8) \ - or \ - (abs(-self.w-other.w) < 1e-8 and \ - abs(-self.x-other.x) < 1e-8 and \ - abs(-self.y-other.y) < 1e-8 and \ - abs(-self.z-other.z) < 1e-8) - if op == 2: #__eq__ - return tmp - elif op ==3: #__ne__ - return not tmp - else: - return NotImplemented - - def __cmp__(self,other): - # not sure if this actually works or not - return cmp(self.Rodrigues(),other.Rodrigues()) - - def magnitude_squared(self): - cdef double tmp - - tmp = self.w**2 + self.x**2 + self.y**2 + self.z**2 - return tmp - - def identity(self): - self.w = 1.0 - self.x = 0.0 - self.y = 0.0 - self.z = 0.0 - return self - - def normalize(self): - cdef double d - - d = self.magnitude() - if d > 0.0: - self /= d - return self - - def conjugate(self): - self.x = -self.x - self.y = -self.y - self.z = -self.z - return self - - def inverse(self): - cdef double d - - d = self.magnitude() - if d > 0.0: - self.conjugate() - self /= d - return self - - def homomorph(self): - if self.w < 0.0: - self.w = -self.w - self.x = -self.x - self.y = -self.y - self.z = -self.z - return self - - # return a copy of me - def normalized(self): - cdef Quaternion q - - q = Quaternion(self.normalize()) - return q - - def conjugated(self): - cdef Quaternion q - - q = Quaternion(self.conjugate()) - return q - - def asList(self): - cdef double[4] q = [self.w, self.x, self.y, self.z] - - return list(q) - - def asM(self): # to find Averaging Quaternions (see F. Landis Markley et al.) - return np.outer([i for i in self],[i for i in self]) - - def asMatrix(self): - return np.array([[1.0-2.0*(self.y*self.y+self.z*self.z), 2.0*(self.x*self.y-self.z*self.w), 2.0*(self.x*self.z+self.y*self.w)], - [ 2.0*(self.x*self.y+self.z*self.w), 1.0-2.0*(self.x*self.x+self.z*self.z), 2.0*(self.y*self.z-self.x*self.w)], - [ 2.0*(self.x*self.z-self.y*self.w), 2.0*(self.x*self.w+self.y*self.z), 1.0-2.0*(self.x*self.x+self.y*self.y)]]) - - def asAngleAxis(self): - # keep the return as radians for simplicity - cdef double s,x,y - - if self.w > 1: - self.normalize() - - s = math.sqrt(1. - self.w**2) - x = 2*self.w**2 - 1. - y = 2*self.w * s - - angle = math.atan2(y,x) - if angle < 0.0: - angle *= -1.0 - s *= -1.0 - - return (angle, - np.array([1.0, 0.0, 0.0] if np.abs(angle) < 1e-3 else [self.x/s, self.y/s, self.z/s]) ) - - def asRodrigues(self): - if self.w != 0.0: - return np.array([self.x, self.y, self.z])/self.w - else: - return np.array([float('inf')]*3) - - def asEulers(self, - type='bunge', - degrees=False, - standardRange=False): - """ - CONVERSION TAKEN FROM: - Melcher, A.; Unser, A.; Reichhardt, M.; Nestler, B.; Pötschke, M.; Selzer, M. - Conversion of EBSD data by a quaternion based algorithm to be used for grain structure simulations - Technische Mechanik 30 (2010) pp 401--413 - """ - cdef double x,y - - angles = [0.0,0.0,0.0] - - if type.lower() == 'bunge' or type.lower() == 'zxz': - if abs(self.x) < 1e-4 and abs(self.y) < 1e-4: - x = self.w**2 - self.z**2 - y = 2.*self.w*self.z - angles[0] = math.atan2(y,x) - elif abs(self.w) < 1e-4 and abs(self.z) < 1e-4: - x = self.x**2 - self.y**2 - y = 2.*self.x*self.y - angles[0] = math.atan2(y,x) - angles[1] = math.pi - else: - chi = math.sqrt((self.w**2 + self.z**2)*(self.x**2 + self.y**2)) - - x = (self.w * self.x - self.y * self.z)/2./chi - y = (self.w * self.y + self.x * self.z)/2./chi - angles[0] = math.atan2(y,x) - - x = self.w**2 + self.z**2 - (self.x**2 + self.y**2) - y = 2.*chi - angles[1] = math.atan2(y,x) - - x = (self.w * self.x + self.y * self.z)/2./chi - y = (self.z * self.x - self.y * self.w)/2./chi - angles[2] = math.atan2(y,x) - if standardRange: - angles[0] %= 2*math.pi - if angles[1] < 0.0: - angles[1] += math.pi - angles[2] *= -1.0 - angles[2] %= 2*math.pi - - return np.degrees(angles) if degrees else angles - - @staticmethod - def fromIdentity(): - cdef double[4] q = [1.0, 0.0, 0.0, 0.0] - - return Quaternion(q) - - @staticmethod - def fromRandom(randomSeed=None): - cdef double r1,r2,r3 - cdef double[4] q - - if randomSeed == None: - randomSeed = int(os.urandom(4).encode('hex'), 16) - random.seed(randomSeed) - - r1 = random.random() - r2 = random.random() - r3 = random.random() - q[0] = math.cos(2.0*math.pi*r1)*math.sqrt(r3) - q[1] = math.sin(2.0*math.pi*r2)*math.sqrt(1.0-r3) - q[2] = math.cos(2.0*math.pi*r2)*math.sqrt(1.0-r3) - q[3] = math.sin(2.0*math.pi*r1)*math.sqrt(r3) - return Quaternion(q) - - @staticmethod - def fromRodrigues(rodrigues): - if not isinstance(rodrigues, np.ndarray): rodrigues = np.array(rodrigues) - halfangle = math.atan(np.linalg.norm(rodrigues)) - c = math.cos(halfangle) - w = c - x,y,z = c*rodrigues - return Quaternion([w,x,y,z]) - - @staticmethod - def fromAngleAxis(angle, axis): - if not isinstance(axis, np.ndarray): axis = np.array(axis) - axis /= np.linalg.norm(axis) - s = math.sin(angle / 2.0) - w = math.cos(angle / 2.0) - x = axis[0] * s - y = axis[1] * s - z = axis[2] * s - return Quaternion([w,x,y,z]) - - @staticmethod - def fromEulers(eulers, type = 'Bunge'): - cdef double c1,s1,c2,s2,c3,s3 - cdef double[4] q - cdef double[3] halfEulers - cdef int i - - for i in range(3): - halfEulers[i] = eulers[i] * 0.5 # reduce to half angles - - - c1 = math.cos(halfEulers[0]) - s1 = math.sin(halfEulers[0]) - c2 = math.cos(halfEulers[1]) - s2 = math.sin(halfEulers[1]) - c3 = math.cos(halfEulers[2]) - s3 = math.sin(halfEulers[2]) - - if type.lower() == 'bunge' or type.lower() == 'zxz': - q[0] = c1 * c2 * c3 - s1 * c2 * s3 - q[1] = c1 * s2 * c3 + s1 * s2 * s3 - q[2] = - c1 * s2 * s3 + s1 * s2 * c3 - q[3] = c1 * c2 * s3 + s1 * c2 * c3 - else: - q[0] = c1 * c2 * c3 - s1 * s2 * s3 - q[1] = s1 * s2 * c3 + c1 * c2 * s3 - q[2] = s1 * c2 * c3 + c1 * s2 * s3 - q[3] = c1 * s2 * c3 - s1 * c2 * s3 - return Quaternion(q) - - ## Modified Method to calculate Quaternion from Orientation Matrix, Source: http://www.euclideanspace.com/maths/geometry/rotations/conversions/matrixToQuaternion/ - - @staticmethod - def fromMatrix(m): - # This is a slow implementation - if m.shape != (3,3) and np.prod(m.shape) == 9: - m = m.reshape(3,3) - - tr=np.trace(m) - if tr > 0.00000001: - s = math.sqrt(tr + 1.0)*2.0 - - return Quaternion( - [ s*0.25, - (m[2,1] - m[1,2])/s, - (m[0,2] - m[2,0])/s, - (m[1,0] - m[0,1])/s - ]) - - elif m[0,0] > m[1,1] and m[0,0] > m[2,2]: - t = m[0,0] - m[1,1] - m[2,2] + 1.0 - s = 2.0*math.sqrt(t) - - return Quaternion( - [ (m[2,1] - m[1,2])/s, - s*0.25, - (m[0,1] + m[1,0])/s, - (m[2,0] + m[0,2])/s, - ]) - - elif m[1,1] > m[2,2]: - t = -m[0,0] + m[1,1] - m[2,2] + 1.0 - s = 2.0*math.sqrt(t) - - return Quaternion( - [ (m[0,2] - m[2,0])/s, - (m[0,1] + m[1,0])/s, - s*0.25, - (m[1,2] + m[2,1])/s, - ]) - - else: - t = -m[0,0] - m[1,1] + m[2,2] + 1.0 - s = 2.0*math.sqrt(t) - - return Quaternion( - [ (m[1,0] - m[0,1])/s, - (m[2,0] + m[0,2])/s, - (m[1,2] + m[2,1])/s, - s*0.25, - ]) - - @staticmethod - def new_interpolate(q1, q2, t): - # see http://ntrs.nasa.gov/archive/nasa/casi.ntrs.nasa.gov/20070017872_2007014421.pdf for (another?) way to interpolate quaternions - - assert isinstance(q1, Quaternion) and isinstance(q2, Quaternion) - Q = Quaternion.fromIdentity() - - costheta = q1.w * q2.w + q1.x * q2.x + q1.y * q2.y + q1.z * q2.z - if costheta < 0.: - costheta = -costheta - q1 = q1.conjugated() - elif costheta > 1: - costheta = 1 - - theta = math.acos(costheta) - if abs(theta) < 0.01: - Q.w = q2.w - Q.x = q2.x - Q.y = q2.y - Q.z = q2.z - return Q - - sintheta = math.sqrt(1.0 - costheta * costheta) - if abs(sintheta) < 0.01: - Q.w = (q1.w + q2.w) * 0.5 - Q.x = (q1.x + q2.x) * 0.5 - Q.y = (q1.y + q2.y) * 0.5 - Q.z = (q1.z + q2.z) * 0.5 - return Q - - ratio1 = math.sin((1 - t) * theta) / sintheta - ratio2 = math.sin(t * theta) / sintheta - - Q.w = q1.w * ratio1 + q2.w * ratio2 - Q.x = q1.x * ratio1 + q2.x * ratio2 - Q.y = q1.y * ratio1 + q2.y * ratio2 - Q.z = q1.z * ratio1 + q2.z * ratio2 - return Q - -## -# Define lattice_type to make it easier for future -# development -cdef enum lattice_type: - NONE = 0 - ORTHORHOMBIC= 1 - TETRAGONAL = 2 - HEXAGONAL = 3 - CUBIC = 4 -## -# Symmetry class -cdef class Symmetry: - cdef public lattice_type lattice - # cdef enum LATTICES: - # NONE = 0 - # ORTHORHOMBIC= 1 - # TETRAGONAL = 2 - # HEXAGONAL = 3 - # CUBIC = 4 - - def __init__(self, symmetry): - if symmetry == 0 or symmetry == None: - self.lattice = NONE - elif symmetry == 1 or symmetry == 'orthorhombic': - self.lattice = ORTHORHOMBIC - elif symmetry == 2 or symmetry == 'tetragonal': - self.lattice = TETRAGONAL - elif symmetry == 3 or symmetry == 'hexagonal': - self.lattice = HEXAGONAL - elif symmetry == 4 or symmetry == 'cubic': - self.lattice = CUBIC - else: - self.lattice = NONE - - def __copy__(self): - return self.__class__(self.lattice) - - copy = __copy__ - - def __repr__(self): - return '{}'.format(self.lattice) - - def __richcmp__(Symmetry self, Symmetry other, int op): - cdef bint tmp - - tmp = self.lattice == other.lattice - if op == 2: #__eq__ - return tmp - elif op ==3: #__ne__ - return not tmp - else: - return NotImplemented - - def __cmp__(self,other): - return cmp(self.lattice,other.lattice) - - def symmetryQuats(self): - ''' - List of symmetry operations as quaternions. - ''' - if self.lattice == 'cubic': - symQuats = [ - [ 1.0, 0.0, 0.0, 0.0 ], - [ 0.0, 1.0, 0.0, 0.0 ], - [ 0.0, 0.0, 1.0, 0.0 ], - [ 0.0, 0.0, 0.0, 1.0 ], - [ 0.0, 0.0, 0.5*math.sqrt(2), 0.5*math.sqrt(2) ], - [ 0.0, 0.0, 0.5*math.sqrt(2),-0.5*math.sqrt(2) ], - [ 0.0, 0.5*math.sqrt(2), 0.0, 0.5*math.sqrt(2) ], - [ 0.0, 0.5*math.sqrt(2), 0.0, -0.5*math.sqrt(2) ], - [ 0.0, 0.5*math.sqrt(2),-0.5*math.sqrt(2), 0.0 ], - [ 0.0, -0.5*math.sqrt(2),-0.5*math.sqrt(2), 0.0 ], - [ 0.5, 0.5, 0.5, 0.5 ], - [-0.5, 0.5, 0.5, 0.5 ], - [-0.5, 0.5, 0.5, -0.5 ], - [-0.5, 0.5, -0.5, 0.5 ], - [-0.5, -0.5, 0.5, 0.5 ], - [-0.5, -0.5, 0.5, -0.5 ], - [-0.5, -0.5, -0.5, 0.5 ], - [-0.5, 0.5, -0.5, -0.5 ], - [-0.5*math.sqrt(2), 0.0, 0.0, 0.5*math.sqrt(2) ], - [ 0.5*math.sqrt(2), 0.0, 0.0, 0.5*math.sqrt(2) ], - [-0.5*math.sqrt(2), 0.0, 0.5*math.sqrt(2), 0.0 ], - [-0.5*math.sqrt(2), 0.0, -0.5*math.sqrt(2), 0.0 ], - [-0.5*math.sqrt(2), 0.5*math.sqrt(2), 0.0, 0.0 ], - [-0.5*math.sqrt(2),-0.5*math.sqrt(2), 0.0, 0.0 ], - ] - elif self.lattice == 'hexagonal': - symQuats = [ - [ 1.0,0.0,0.0,0.0 ], - [-0.5*math.sqrt(3), 0.0, 0.0,-0.5 ], - [ 0.5, 0.0, 0.0, 0.5*math.sqrt(3) ], - [ 0.0,0.0,0.0,1.0 ], - [-0.5, 0.0, 0.0, 0.5*math.sqrt(3) ], - [-0.5*math.sqrt(3), 0.0, 0.0, 0.5 ], - [ 0.0,1.0,0.0,0.0 ], - [ 0.0,-0.5*math.sqrt(3), 0.5, 0.0 ], - [ 0.0, 0.5,-0.5*math.sqrt(3), 0.0 ], - [ 0.0,0.0,1.0,0.0 ], - [ 0.0,-0.5,-0.5*math.sqrt(3), 0.0 ], - [ 0.0, 0.5*math.sqrt(3), 0.5, 0.0 ], - ] - elif self.lattice == 'tetragonal': - symQuats = [ - [ 1.0,0.0,0.0,0.0 ], - [ 0.0,1.0,0.0,0.0 ], - [ 0.0,0.0,1.0,0.0 ], - [ 0.0,0.0,0.0,1.0 ], - [ 0.0, 0.5*math.sqrt(2), 0.5*math.sqrt(2), 0.0 ], - [ 0.0,-0.5*math.sqrt(2), 0.5*math.sqrt(2), 0.0 ], - [ 0.5*math.sqrt(2), 0.0, 0.0, 0.5*math.sqrt(2) ], - [-0.5*math.sqrt(2), 0.0, 0.0, 0.5*math.sqrt(2) ], - ] - elif self.lattice == 'orthorhombic': - symQuats = [ - [ 1.0,0.0,0.0,0.0 ], - [ 0.0,1.0,0.0,0.0 ], - [ 0.0,0.0,1.0,0.0 ], - [ 0.0,0.0,0.0,1.0 ], - ] - else: - symQuats = [ - [ 1.0,0.0,0.0,0.0 ], - ] - - return map(Quaternion,symQuats) - - def equivalentQuaternions(self,quaternion): - ''' - List of symmetrically equivalent quaternions based on own symmetry. - ''' - return [quaternion*Quaternion(q) for q in self.symmetryQuats()] - - def inFZ(self,R): - ''' - Check whether given Rodrigues vector falls into fundamental zone of own symmetry. - ''' - if isinstance(R, Quaternion): R = R.asRodrigues() # translate accidentially passed quaternion - R = abs(R) # fundamental zone in Rodrigues space is point symmetric around origin - if self.lattice == CUBIC: - return math.sqrt(2.0)-1.0 >= R[0] \ - and math.sqrt(2.0)-1.0 >= R[1] \ - and math.sqrt(2.0)-1.0 >= R[2] \ - and 1.0 >= R[0] + R[1] + R[2] - elif self.lattice == HEXAGONAL: - return 1.0 >= R[0] and 1.0 >= R[1] and 1.0 >= R[2] \ - and 2.0 >= math.sqrt(3)*R[0] + R[1] \ - and 2.0 >= math.sqrt(3)*R[1] + R[0] \ - and 2.0 >= math.sqrt(3) + R[2] - elif self.lattice == TETRAGONAL: - return 1.0 >= R[0] and 1.0 >= R[1] \ - and math.sqrt(2.0) >= R[0] + R[1] \ - and math.sqrt(2.0) >= R[2] + 1.0 - elif self.lattice == ORTHORHOMBIC: - return 1.0 >= R[0] and 1.0 >= R[1] and 1.0 >= R[2] - else: - return True - - def inDisorientationSST(self,R): - ''' - Check whether given Rodrigues vector (of misorientation) falls into standard stereographic triangle of own symmetry. - Determination of disorientations follow the work of A. Heinz and P. Neumann: - Representation of Orientation and Disorientation Data for Cubic, Hexagonal, Tetragonal and Orthorhombic Crystals - Acta Cryst. (1991). A47, 780-789 - ''' - if isinstance(R, Quaternion): R = R.asRodrigues() # translate accidentally passed quaternion - - cdef double epsilon = 0.0 - - if self.lattice == CUBIC: - return R[0] >= R[1]+epsilon and R[1] >= R[2]+epsilon and R[2] >= epsilon - - elif self.lattice == HEXAGONAL: - return R[0] >= math.sqrt(3)*(R[1]+epsilon) and R[1] >= epsilon and R[2] >= epsilon - - elif self.lattice == TETRAGONAL: - return R[0] >= R[1]+epsilon and R[1] >= epsilon and R[2] >= epsilon - - elif self.lattice == ORTHORHOMBIC: - return R[0] >= epsilon and R[1] >= epsilon and R[2] >= epsilon - - else: - return True - - def inSST(self, - vector, - color = False): - ''' - Check whether given vector falls into standard stereographic triangle of own symmetry. - Return inverse pole figure color if requested. - ''' -# basis = {4 : np.linalg.inv(np.array([[0.,0.,1.], # direction of red -# [1.,0.,1.]/np.sqrt(2.), # direction of green -# [1.,1.,1.]/np.sqrt(3.)]).transpose()), # direction of blue -# 3 : np.linalg.inv(np.array([[0.,0.,1.], # direction of red -# [1.,0.,0.], # direction of green -# [np.sqrt(3.),1.,0.]/np.sqrt(4.)]).transpose()), # direction of blue -# 2 : np.linalg.inv(np.array([[0.,0.,1.], # direction of red -# [1.,0.,0.], # direction of green -# [1.,1.,0.]/np.sqrt(2.)]).transpose()), # direction of blue -# 1 : np.linalg.inv(np.array([[0.,0.,1.], # direction of red -# [1.,0.,0.], # direction of green -# [0.,1.,0.]]).transpose()), # direction of blue -# } - if self.lattice == CUBIC: - basis = np.array([ [-1. , 0. , 1. ], - [ np.sqrt(2.), -np.sqrt(2.), 0. ], - [ 0. , np.sqrt(3.), 0. ] ]) - elif self.lattice == HEXAGONAL: - basis = np.array([ [ 0. , 0. , 1. ], - [ 1. , -np.sqrt(3.), 0. ], - [ 0. , 2. , 0. ] ]) - elif self.lattice == TETRAGONAL: - basis = np.array([ [ 0. , 0. , 1. ], - [ 1. , -1. , 0. ], - [ 0. , np.sqrt(2.), 0. ] ]) - elif self.lattice == ORTHORHOMBIC: - basis = np.array([ [ 0., 0., 1.], - [ 1., 0., 0.], - [ 0., 1., 0.] ]) - else: - basis = np.zeros((3,3),dtype=float) - - if np.all(basis == 0.0): - theComponents = -np.ones(3,'d') - else: - v = np.array(vector,dtype = float) - v[2] = abs(v[2]) # z component projects identical for positive and negative values - theComponents = np.dot(basis,v) - - inSST = np.all(theComponents >= 0.0) - - if color: # have to return color array - if inSST: - rgb = np.power(theComponents/np.linalg.norm(theComponents),0.5) # smoothen color ramps - rgb = np.minimum(np.ones(3,'d'),rgb) # limit to maximum intensity - rgb /= max(rgb) # normalize to (HS)V = 1 - else: - rgb = np.zeros(3,'d') - return (inSST,rgb) - else: - return inSST - -# code derived from http://pyeuclid.googlecode.com/svn/trunk/euclid.py -# suggested reading: http://web.mit.edu/2.998/www/QuaternionReport1.pdf - - -## -# Orientation class is a composite class of Symmetry and Quaternion -cdef class Orientation: - cdef public Quaternion quaternion - cdef public Symmetry symmetry - - def __init__(self, - quaternion = Quaternion.fromIdentity(), - Rodrigues = None, - angleAxis = None, - matrix = None, - Eulers = None, - random = False, # put any integer to have a fixed seed or True for real random - symmetry = None - ): - if random: # produce random orientation - if isinstance(random, bool ): - self.quaternion = Quaternion.fromRandom() - else: - self.quaternion = Quaternion.fromRandom(randomSeed=random) - elif isinstance(Eulers, np.ndarray) and Eulers.shape == (3,): # based on given Euler angles - self.quaternion = Quaternion.fromEulers(Eulers, type='bunge') - elif isinstance(matrix, np.ndarray) : # based on given rotation matrix - self.quaternion = Quaternion.fromMatrix(matrix) - elif isinstance(angleAxis, np.ndarray) and angleAxis.shape == (4,): # based on given angle and rotation axis - self.quaternion = Quaternion.fromAngleAxis(angleAxis[0],angleAxis[1:4]) - elif isinstance(Rodrigues, np.ndarray) and Rodrigues.shape == (3,): # based on given Rodrigues vector - self.quaternion = Quaternion.fromRodrigues(Rodrigues) - elif isinstance(quaternion, Quaternion): # based on given quaternion - self.quaternion = quaternion.homomorph() - elif isinstance(quaternion, np.ndarray) and quaternion.shape == (4,): # based on given quaternion - self.quaternion = Quaternion(quaternion).homomorph() - - self.symmetry = Symmetry(symmetry) - - def __copy__(self): - return self.__class__(quaternion=self.quaternion,symmetry=self.symmetry.lattice) - - copy = __copy__ - - def __repr__(self): - return 'Symmetry: %s\n' % (self.symmetry) + \ - 'Quaternion: %s\n' % (self.quaternion) + \ - 'Matrix:\n%s\n' % ( '\n'.join(['\t'.join(map(str,self.asMatrix()[i,:])) for i in range(3)]) ) + \ - 'Bunge Eulers / deg: %s' % ('\t'.join(map(lambda x:str(np.degrees(x)),self.asEulers('bunge'))) ) - - def asQuaternion(self): - return self.quaternion.asList() - - def asEulers(self,type='bunge'): - return self.quaternion.asEulers(type) - - def asRodrigues(self): - return self.quaternion.asRodrigues() - - def asAngleAxis(self): - return self.quaternion.asAngleAxis() - - def asMatrix(self): - return self.quaternion.asMatrix() - - def inFZ(self): - return self.symmetry.inFZ(self.quaternion.asRodrigues()) - - def equivalentQuaternions(self): - return self.symmetry.equivalentQuaternions(self.quaternion) - - def equivalentOrientations(self): - return map(lambda q: Orientation(quaternion=q,symmetry=self.symmetry.lattice), - self.equivalentQuaternions()) - - - def reduced(self): - '''Transform orientation to fall into fundamental zone according to symmetry''' - for me in self.symmetry.equivalentQuaternions(self.quaternion): - if self.symmetry.inFZ(me.asRodrigues()): break - - return Orientation(quaternion=me,symmetry=self.symmetry.lattice) - - def disorientation_old(self,other): - ''' - Disorientation between myself and given other orientation - (either reduced according to my own symmetry or given one) - ''' - - lowerSymmetry = min(self.symmetry,other.symmetry) - breaker = False - - for me in self.symmetry.equivalentQuaternions(self.quaternion): - me.conjugate() - for they in other.symmetry.equivalentQuaternions(other.quaternion): - theQ = they * me - breaker = lowerSymmetry.inDisorientationSST(theQ.asRodrigues()) #\ -# or lowerSymmetry.inDisorientationSST(theQ.conjugated().asRodrigues()) - if breaker: break - if breaker: break - - return Orientation(quaternion=theQ,symmetry=self.symmetry.lattice) #, me.conjugated(), they - - def disorientation(self,other): - ''' - Disorientation between myself and given other orientation - (currently needs to be of same symmetry. - look into A. Heinz and P. Neumann 1991 for cases with differing sym.) - ''' - if self.symmetry != other.symmetry: - raise TypeError('disorientation between different symmetry classes not supported yet.') - - misQ = self.quaternion.conjugated()*other.quaternion - - for i,sA in enumerate(self.symmetry.symmetryQuats()): - for j,sB in enumerate(other.symmetry.symmetryQuats()): - theQ = sA.conjugated()*misQ*sB - for k in xrange(2): - theQ.conjugate() - hitSST = other.symmetry.inDisorientationSST(theQ) - hitFZ = self.symmetry.inFZ(theQ) - breaker = hitSST and hitFZ - if breaker: break - if breaker: break - if breaker: break - return Orientation(quaternion=theQ,symmetry=self.symmetry.lattice) # disorientation, own sym, other sym, self-->other: True, self<--other: False - - def inversePole(self,axis,SST = True): - ''' - axis rotated according to orientation (using crystal symmetry to ensure location falls into SST) - ''' - - if SST: # pole requested to be within SST - for i,q in enumerate(self.symmetry.equivalentQuaternions(self.quaternion)): # test all symmetric equivalent quaternions - pole = q.conjugated()*axis # align crystal direction to axis - if self.symmetry.inSST(pole): break # found SST version - else: - pole = self.quaternion.conjugated()*axis # align crystal direction to axis - - return pole - - def IPFcolor(self,axis): - ''' TSL color of inverse pole figure for given axis ''' - color = np.zeros(3,'d') - for q in self.symmetry.equivalentQuaternions(self.quaternion): - pole = q.conjugated()*axis # align crystal direction to axis - inSST,color = self.symmetry.inSST(pole,color=True) - if inSST: break - - return color - - @staticmethod - def getAverageOrientation(orientationList): - """ - RETURN THE AVERAGE ORIENTATION - ref: F. Landis Markley, Yang Cheng, John Lucas Crassidis, and Yaakov Oshman. - Averaging Quaternions, - Journal of Guidance, Control, and Dynamics, Vol. 30, No. 4 (2007), pp. 1193-1197. - doi: 10.2514/1.28949 - sample usage: - a = Orientation(Eulers=np.radians([10, 10, 0]), symmetry=3) - b = Orientation(Eulers=np.radians([20, 0, 0]), symmetry=3) - avg = Orientation.getAverageOrientation([a,b]) - NOTE - ---- - No symmetry information is available for the average orientation. - """ - - if not all(isinstance(item, Orientation) for item in orientationList): - raise TypeError("Only instances of Orientation can be averaged.") - - N = len(orientationList) - M = orientationList.pop(0).quaternion.asM() - for o in orientationList: - M += o.quaternion.asM() - eig, vec = np.linalg.eig(M/N) - - return Orientation(quaternion = Quaternion(vec.T[eig.argmax()])) - - def related(self, relationModel, direction, targetSymmetry = None): - - if relationModel not in ['KS','GT','GTdash','NW','Pitsch','Bain']: return None - if int(direction) == 0: return None - - # KS from S. Morito et al./Journal of Alloys and Compounds 5775 (2013) S587-S592 - # GT from Y. He et al./Journal of Applied Crystallography (2006). 39, 72-81 - # GT' from Y. He et al./Journal of Applied Crystallography (2006). 39, 72-81 - # NW from H. Kitahara et al./Materials Characterization 54 (2005) 378-386 - # Pitsch from Y. He et al./Acta Materialia 53 (2005) 1179-1190 - # Bain from Y. He et al./Journal of Applied Crystallography (2006). 39, 72-81 - - variant = int(abs(direction))-1 - (me,other) = (0,1) if direction > 0 else (1,0) - - planes = {'KS': \ - np.array([[[ 1, 1, 1],[ 0, 1, 1]],\ - [[ 1, 1, 1],[ 0, 1, 1]],\ - [[ 1, 1, 1],[ 0, 1, 1]],\ - [[ 1, 1, 1],[ 0, 1, 1]],\ - [[ 1, 1, 1],[ 0, 1, 1]],\ - [[ 1, 1, 1],[ 0, 1, 1]],\ - [[ 1, -1, 1],[ 0, 1, 1]],\ - [[ 1, -1, 1],[ 0, 1, 1]],\ - [[ 1, -1, 1],[ 0, 1, 1]],\ - [[ 1, -1, 1],[ 0, 1, 1]],\ - [[ 1, -1, 1],[ 0, 1, 1]],\ - [[ 1, -1, 1],[ 0, 1, 1]],\ - [[ -1, 1, 1],[ 0, 1, 1]],\ - [[ -1, 1, 1],[ 0, 1, 1]],\ - [[ -1, 1, 1],[ 0, 1, 1]],\ - [[ -1, 1, 1],[ 0, 1, 1]],\ - [[ -1, 1, 1],[ 0, 1, 1]],\ - [[ -1, 1, 1],[ 0, 1, 1]],\ - [[ 1, 1, -1],[ 0, 1, 1]],\ - [[ 1, 1, -1],[ 0, 1, 1]],\ - [[ 1, 1, -1],[ 0, 1, 1]],\ - [[ 1, 1, -1],[ 0, 1, 1]],\ - [[ 1, 1, -1],[ 0, 1, 1]],\ - [[ 1, 1, -1],[ 0, 1, 1]]]), - 'GT': \ - np.array([[[ 1, 1, 1],[ 1, 0, 1]],\ - [[ 1, 1, 1],[ 1, 1, 0]],\ - [[ 1, 1, 1],[ 0, 1, 1]],\ - [[ -1, -1, 1],[ -1, 0, 1]],\ - [[ -1, -1, 1],[ -1, -1, 0]],\ - [[ -1, -1, 1],[ 0, -1, 1]],\ - [[ -1, 1, 1],[ -1, 0, 1]],\ - [[ -1, 1, 1],[ -1, 1, 0]],\ - [[ -1, 1, 1],[ 0, 1, 1]],\ - [[ 1, -1, 1],[ 1, 0, 1]],\ - [[ 1, -1, 1],[ 1, -1, 0]],\ - [[ 1, -1, 1],[ 0, -1, 1]],\ - [[ 1, 1, 1],[ 1, 1, 0]],\ - [[ 1, 1, 1],[ 0, 1, 1]],\ - [[ 1, 1, 1],[ 1, 0, 1]],\ - [[ -1, -1, 1],[ -1, -1, 0]],\ - [[ -1, -1, 1],[ 0, -1, 1]],\ - [[ -1, -1, 1],[ -1, 0, 1]],\ - [[ -1, 1, 1],[ -1, 1, 0]],\ - [[ -1, 1, 1],[ 0, 1, 1]],\ - [[ -1, 1, 1],[ -1, 0, 1]],\ - [[ 1, -1, 1],[ 1, -1, 0]],\ - [[ 1, -1, 1],[ 0, -1, 1]],\ - [[ 1, -1, 1],[ 1, 0, 1]]]), - 'GTdash': \ - np.array([[[ 7, 17, 17],[ 12, 5, 17]],\ - [[ 17, 7, 17],[ 17, 12, 5]],\ - [[ 17, 17, 7],[ 5, 17, 12]],\ - [[ -7,-17, 17],[-12, -5, 17]],\ - [[-17, -7, 17],[-17,-12, 5]],\ - [[-17,-17, 7],[ -5,-17, 12]],\ - [[ 7,-17,-17],[ 12, -5,-17]],\ - [[ 17, -7,-17],[ 17,-12, -5]],\ - [[ 17,-17, -7],[ 5,-17,-12]],\ - [[ -7, 17,-17],[-12, 5,-17]],\ - [[-17, 7,-17],[-17, 12, -5]],\ - [[-17, 17, -7],[ -5, 17,-12]],\ - [[ 7, 17, 17],[ 12, 17, 5]],\ - [[ 17, 7, 17],[ 5, 12, 17]],\ - [[ 17, 17, 7],[ 17, 5, 12]],\ - [[ -7,-17, 17],[-12,-17, 5]],\ - [[-17, -7, 17],[ -5,-12, 17]],\ - [[-17,-17, 7],[-17, -5, 12]],\ - [[ 7,-17,-17],[ 12,-17, -5]],\ - [[ 17, -7,-17],[ 5, -12,-17]],\ - [[ 17,-17, 7],[ 17, -5,-12]],\ - [[ -7, 17,-17],[-12, 17, -5]],\ - [[-17, 7,-17],[ -5, 12,-17]],\ - [[-17, 17, -7],[-17, 5,-12]]]), - 'NW': \ - np.array([[[ 1, 1, 1],[ 0, 1, 1]],\ - [[ 1, 1, 1],[ 0, 1, 1]],\ - [[ 1, 1, 1],[ 0, 1, 1]],\ - [[ -1, 1, 1],[ 0, 1, 1]],\ - [[ -1, 1, 1],[ 0, 1, 1]],\ - [[ -1, 1, 1],[ 0, 1, 1]],\ - [[ 1, -1, 1],[ 0, 1, 1]],\ - [[ 1, -1, 1],[ 0, 1, 1]],\ - [[ 1, -1, 1],[ 0, 1, 1]],\ - [[ -1, -1, 1],[ 0, 1, 1]],\ - [[ -1, -1, 1],[ 0, 1, 1]],\ - [[ -1, -1, 1],[ 0, 1, 1]]]), - 'Pitsch': \ - np.array([[[ 0, 1, 0],[ -1, 0, 1]],\ - [[ 0, 0, 1],[ 1, -1, 0]],\ - [[ 1, 0, 0],[ 0, 1, -1]],\ - [[ 1, 0, 0],[ 0, -1, -1]],\ - [[ 0, 1, 0],[ -1, 0, -1]],\ - [[ 0, 0, 1],[ -1, -1, 0]],\ - [[ 0, 1, 0],[ -1, 0, -1]],\ - [[ 0, 0, 1],[ -1, -1, 0]],\ - [[ 1, 0, 0],[ 0, -1, -1]],\ - [[ 1, 0, 0],[ 0, -1, 1]],\ - [[ 0, 1, 0],[ 1, 0, -1]],\ - [[ 0, 0, 1],[ -1, 1, 0]]]), - 'Bain': \ - np.array([[[ 1, 0, 0],[ 1, 0, 0]],\ - [[ 0, 1, 0],[ 0, 1, 0]],\ - [[ 0, 0, 1],[ 0, 0, 1]]]), - } - - normals = {'KS': \ - np.array([[[ -1, 0, 1],[ -1, -1, 1]],\ - [[ -1, 0, 1],[ -1, 1, -1]],\ - [[ 0, 1, -1],[ -1, -1, 1]],\ - [[ 0, 1, -1],[ -1, 1, -1]],\ - [[ 1, -1, 0],[ -1, -1, 1]],\ - [[ 1, -1, 0],[ -1, 1, -1]],\ - [[ 1, 0, -1],[ -1, -1, 1]],\ - [[ 1, 0, -1],[ -1, 1, -1]],\ - [[ -1, -1, 0],[ -1, -1, 1]],\ - [[ -1, -1, 0],[ -1, 1, -1]],\ - [[ 0, 1, 1],[ -1, -1, 1]],\ - [[ 0, 1, 1],[ -1, 1, -1]],\ - [[ 0, -1, 1],[ -1, -1, 1]],\ - [[ 0, -1, 1],[ -1, 1, -1]],\ - [[ -1, 0, -1],[ -1, -1, 1]],\ - [[ -1, 0, -1],[ -1, 1, -1]],\ - [[ 1, 1, 0],[ -1, -1, 1]],\ - [[ 1, 1, 0],[ -1, 1, -1]],\ - [[ -1, 1, 0],[ -1, -1, 1]],\ - [[ -1, 1, 0],[ -1, 1, -1]],\ - [[ 0, -1, -1],[ -1, -1, 1]],\ - [[ 0, -1, -1],[ -1, 1, -1]],\ - [[ 1, 0, 1],[ -1, -1, 1]],\ - [[ 1, 0, 1],[ -1, 1, -1]]]), - 'GT': \ - np.array([[[ -5,-12, 17],[-17, -7, 17]],\ - [[ 17, -5,-12],[ 17,-17, -7]],\ - [[-12, 17, -5],[ -7, 17,-17]],\ - [[ 5, 12, 17],[ 17, 7, 17]],\ - [[-17, 5,-12],[-17, 17, -7]],\ - [[ 12,-17, -5],[ 7,-17,-17]],\ - [[ -5, 12,-17],[-17, 7,-17]],\ - [[ 17, 5, 12],[ 17, 17, 7]],\ - [[-12,-17, 5],[ -7,-17, 17]],\ - [[ 5,-12,-17],[ 17, -7,-17]],\ - [[-17, -5, 12],[-17,-17, 7]],\ - [[ 12, 17, 5],[ 7, 17, 17]],\ - [[ -5, 17,-12],[-17, 17, -7]],\ - [[-12, -5, 17],[ -7,-17, 17]],\ - [[ 17,-12, -5],[ 17, -7,-17]],\ - [[ 5,-17,-12],[ 17,-17, -7]],\ - [[ 12, 5, 17],[ 7, 17, 17]],\ - [[-17, 12, -5],[-17, 7,-17]],\ - [[ -5,-17, 12],[-17,-17, 7]],\ - [[-12, 5,-17],[ -7, 17,-17]],\ - [[ 17, 12, 5],[ 17, 7, 17]],\ - [[ 5, 17, 12],[ 17, 17, 7]],\ - [[ 12, -5,-17],[ 7,-17,-17]],\ - [[-17,-12, 5],[-17, 7, 17]]]), - 'GTdash': \ - np.array([[[ 0, 1, -1],[ 1, 1, -1]],\ - [[ -1, 0, 1],[ -1, 1, 1]],\ - [[ 1, -1, 0],[ 1, -1, 1]],\ - [[ 0, -1, -1],[ -1, -1, -1]],\ - [[ 1, 0, 1],[ 1, -1, 1]],\ - [[ 1, -1, 0],[ 1, -1, -1]],\ - [[ 0, 1, -1],[ -1, 1, -1]],\ - [[ 1, 0, 1],[ 1, 1, 1]],\ - [[ -1, -1, 0],[ -1, -1, 1]],\ - [[ 0, -1, -1],[ 1, -1, -1]],\ - [[ -1, 0, 1],[ -1, -1, 1]],\ - [[ -1, -1, 0],[ -1, -1, -1]],\ - [[ 0, -1, 1],[ 1, -1, 1]],\ - [[ 1, 0, -1],[ 1, 1, -1]],\ - [[ -1, 1, 0],[ -1, 1, 1]],\ - [[ 0, 1, 1],[ -1, 1, 1]],\ - [[ -1, 0, -1],[ -1, -1, -1]],\ - [[ -1, 1, 0],[ -1, 1, -1]],\ - [[ 0, -1, 1],[ -1, -1, 1]],\ - [[ -1, 0, -1],[ -1, 1, -1]],\ - [[ 1, 1, 0],[ 1, 1, 1]],\ - [[ 0, 1, 1],[ 1, 1, 1]],\ - [[ 1, 0, -1],[ 1, -1, -1]],\ - [[ 1, 1, 0],[ 1, 1, -1]]]), - 'NW': \ - np.array([[[ 2, -1, -1],[ 0, -1, 1]],\ - [[ -1, 2, -1],[ 0, -1, 1]],\ - [[ -1, -1, 2],[ 0, -1, 1]],\ - [[ -2, -1, -1],[ 0, -1, 1]],\ - [[ 1, 2, -1],[ 0, -1, 1]],\ - [[ 1, -1, 2],[ 0, -1, 1]],\ - [[ 2, 1, -1],[ 0, -1, 1]],\ - [[ -1, -2, -1],[ 0, -1, 1]],\ - [[ -1, 1, 2],[ 0, -1, 1]],\ - [[ -1, 2, 1],[ 0, -1, 1]],\ - [[ -1, 2, 1],[ 0, -1, 1]],\ - [[ -1, -1, -2],[ 0, -1, 1]]]), - 'Pitsch': \ - np.array([[[ 1, 0, 1],[ 1, -1, 1]],\ - [[ 1, 1, 0],[ 1, 1, -1]],\ - [[ 0, 1, 1],[ -1, 1, 1]],\ - [[ 0, 1, -1],[ -1, 1, -1]],\ - [[ -1, 0, 1],[ -1, -1, 1]],\ - [[ 1, -1, 0],[ 1, -1, -1]],\ - [[ 1, 0, -1],[ 1, -1, -1]],\ - [[ -1, 1, 0],[ -1, 1, -1]],\ - [[ 0, -1, 1],[ -1, -1, 1]],\ - [[ 0, 1, 1],[ -1, 1, 1]],\ - [[ 1, 0, 1],[ 1, -1, 1]],\ - [[ 1, 1, 0],[ 1, 1, -1]]]), - 'Bain': \ - np.array([[[ 0, 1, 0],[ 0, 1, 1]], - [[ 0, 0, 1],[ 1, 0, 1]], - [[ 1, 0, 0],[ 1, 1, 0]]]), - } - myPlane = [float(i) for i in planes[relationModel][variant,me]] # map(float, planes[...]) does not work in python 3 - myPlane /= np.linalg.norm(myPlane) - myNormal = [float(i) for i in normals[relationModel][variant,me]] # map(float, planes[...]) does not work in python 3 - myNormal /= np.linalg.norm(myNormal) - myMatrix = np.array([myPlane,myNormal,np.cross(myPlane,myNormal)]) - - otherPlane = [float(i) for i in planes[relationModel][variant,other]] # map(float, planes[...]) does not work in python 3 - otherPlane /= np.linalg.norm(otherPlane) - otherNormal = [float(i) for i in normals[relationModel][variant,other]] # map(float, planes[...]) does not work in python 3 - otherNormal /= np.linalg.norm(otherNormal) - otherMatrix = np.array([otherPlane,otherNormal,np.cross(otherPlane,otherNormal)]) - - rot=np.dot(otherMatrix.T,myMatrix) - - return Orientation(matrix=np.dot(rot,self.asMatrix())) # no symmetry information ?? \ No newline at end of file From ea28bc8f062e3629c300084c766019cfa1410ba6 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 24 Mar 2016 16:19:49 +0100 Subject: [PATCH 09/37] restored script for calculation of nodal positions --- processing/post/nodesAroundCentres.py | 152 ++++++++++++++++++++++++++ 1 file changed, 152 insertions(+) create mode 100644 processing/post/nodesAroundCentres.py diff --git a/processing/post/nodesAroundCentres.py b/processing/post/nodesAroundCentres.py new file mode 100644 index 000000000..3a2624b16 --- /dev/null +++ b/processing/post/nodesAroundCentres.py @@ -0,0 +1,152 @@ +#!/usr/bin/env python +# -*- coding: UTF-8 no BOM -*- + +import os,sys,math,string +import numpy as np +from optparse import OptionParser +import damask + +scriptID = string.replace('$Id: addDeformedConfiguration.py 4500 2015-09-24 09:24:42Z MPIE\m.diehl $','\n','\\n') +scriptName = os.path.splitext(scriptID.split()[1])[0] + +#-------------------------------------------------------------------------------------------------- +def nodesAroundCentres(gDim,Favg,centres): +#-------------------------------------------------------------------------------------------------- + neighbor = np.array([0, 0, 0, + 1, 0, 0, + 1, 1, 0, + 0, 1, 0, + 0, 0, 1, + 1, 0, 1, + 1, 1, 1, + 0, 1, 1]).reshape(8,3) + +#-------------------------------------------------------------------------------------------------- +# building wrappedCentres = centroids + ghosts + diag = np.ones([3]) + wrappedCentres = np.zeros([3,grid[0]+2,grid[1]+2,grid[2]+2]) + wrappedCentres[0:3,1:grid[0]+1,1:grid[1]+1,1:grid[2]+1] = centres + for k in xrange(grid[2]+2): + for j in xrange(grid[1]+2): + for i in xrange(grid[0]+2): + if (k in [0,grid[2]+1] or j in [0,grid[1]+1] or i in[0,grid[0]+1]): + me = np.array([i,j,k],'i') # me on skin + shift = abs(grid+np.ones([3],'i')-2*me)/(grid+np.ones([3],'i'))*\ + np.sign(grid+np.ones([3],'i')-2*me) + lookup = np.array(me-diag+shift*grid,'i') + wrappedCentres[0:3,i, j, k] = \ + centres[0:3,lookup[0],lookup[1],lookup[2]] - np.dot(Favg, shift*gDim) + +#-------------------------------------------------------------------------------------------------- +# averaging + nodes = np.zeros([3,grid[0]+1,grid[1]+1,grid[2]+1]) + for k in xrange(grid[2]+1): + for j in xrange(grid[1]+1): + for i in xrange(grid[0]+1): + for n in xrange(8): + nodes[0:3,i,j,k] = \ + nodes[0:3,i,j,k] + wrappedCentres[0:3,i+neighbor[n,0],j+neighbor[n,1],k+neighbor[n,2] ] + + return nodes/8.0 + +# -------------------------------------------------------------------- +# MAIN +# -------------------------------------------------------------------- + +parser = OptionParser(option_class=damask.extendableOption, usage='%prog options file[s]', description = """ +Add deformed configuration of given initial coordinates. +Operates on periodic three-dimensional x,y,z-ordered data sets. + +""", version = scriptID) + +parser.add_option('-f', '--defgrad',dest='defgrad', metavar = 'string', + help='heading of deformation gradient columns [%default]') +parser.add_option('-u', '--unitlength', dest='unitlength', type='float', metavar = 'float', + help='set unit length for 2D model [%default]') + +parser.set_defaults(deformed = 'ipinitialcoord') +parser.set_defaults(unitlength = 0.0) + +(options,filenames) = parser.parse_args() + +options.scaling += [1.0 for i in xrange(max(0,3-len(options.scaling)))] +scaling = map(float, options.scaling) + + +# --- loop over input files ------------------------------------------------------------------------- + +if filenames == []: filenames = [None] + +for name in filenames: + try: + table = damask.ASCIItable(name = name, + buffered = False) + except: continue + damask.util.report(scriptName,name) + +# ------------------------------------------ read header ------------------------------------------ + + table.head_read() + +# ------------------------------------------ sanity checks ---------------------------------------- + + errors = [] + remarks = [] + + if table.label_dimension(options.coords) != 3: errors.append('coordinates {} are not a vector.'.format(options.coords)) + else: colCoord = table.label_index(options.coords) + + if table.label_dimension(options.defgrad) != 9: errors.append('deformation gradient {} is not a tensor.'.format(options.defgrad)) + else: colF = table.label_index(options.defgrad) + + if remarks != []: damask.util.croak(remarks) + if errors != []: + damask.util.croak(errors) + table.close(dismiss = True) + continue + +# --------------- figure out size and grid --------------------------------------------------------- + + table.data_readArray() + + coords = [np.unique(table.data[:,colCoord+i]) for i in xrange(3)] + mincorner = np.array(map(min,coords)) + maxcorner = np.array(map(max,coords)) + grid = np.array(map(len,coords),'i') + size = grid/np.maximum(np.ones(3,'d'), grid-1.0) * (maxcorner-mincorner) # size from edge to edge = dim * n/(n-1) + size = np.where(grid > 1, size, min(size[grid > 1]/grid[grid > 1])) # spacing for grid==1 equal to smallest among other spacings + + N = grid.prod() + + if N != len(table.data): errors.append('data count {} does not match grid {}x{}x{}.'.format(N,*grid)) + if errors != []: + damask.util.croak(errors) + table.close(dismiss = True) + continue + +# ------------------------------------------ assemble header --------------------------------------- + + table.info_append(scriptID + '\t' + ' '.join(sys.argv[1:])) + for coord in xrange(3): + label = '{}_{}_{}'.format(coord+1,options.defgrad,options.coords) + if np.any(scaling) != 1.0: label+='_{}_{}_{}'.format(scaling) + if options.undeformed: label+='_undeformed' + table.labels_append([label]) # extend ASCII header with new labels + table.head_write() + +# ------------------------------------------ read deformation gradient field ----------------------- + centroids,Favg = deformedCoordsFFT(table.data[:,colF:colF+9].reshape(grid[0],grid[1],grid[2],3,3)) + +# ------------------------------------------ process data ------------------------------------------ + table.data_rewind() + idx = 0 + outputAlive = True + while outputAlive and table.data_read(): # read next data line of ASCII table + (x,y,z) = damask.util.gridLocation(idx,grid) # figure out (x,y,z) position from line count + idx += 1 + table.data_append(list(centroids[z,y,x,:])) + outputAlive = table.data_write() + +# ------------------------------------------ output finalization ----------------------------------- + + table.close() # close ASCII tables From 6aa6b418eacccfc0f6986ce34d18d36db64b0af1 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 15 Apr 2016 00:08:01 +0200 Subject: [PATCH 10/37] not needed (Philip has different names) --- processing/post/addDeformedConfiguration.py | 164 -------------------- processing/post/nodesAroundCentres.py | 152 ------------------ 2 files changed, 316 deletions(-) delete mode 100755 processing/post/addDeformedConfiguration.py delete mode 100644 processing/post/nodesAroundCentres.py diff --git a/processing/post/addDeformedConfiguration.py b/processing/post/addDeformedConfiguration.py deleted file mode 100755 index 3fb39ee0d..000000000 --- a/processing/post/addDeformedConfiguration.py +++ /dev/null @@ -1,164 +0,0 @@ -#!/usr/bin/env python -# -*- coding: UTF-8 no BOM -*- - -import os,sys,math -import numpy as np -from optparse import OptionParser -import damask - -scriptName = os.path.splitext(os.path.basename(__file__))[0] -scriptID = ' '.join([scriptName,damask.version]) - -#-------------------------------------------------------------------------------------------------- -def deformedCoordsFFT(F,undeformed=False): - - wgt = 1.0/grid.prod() - integrator = np.array([0.+1.j,0.+1.j,0.+1.j],'c16') * size/ 2.0 / math.pi - step = size/grid - - F_fourier = np.fft.rfftn(F,axes=(0,1,2)) - coords_fourier = np.zeros(F_fourier.shape[0:4],'c16') - - if undeformed: - Favg=np.eye(3) - else: - Favg=np.real(F_fourier[0,0,0,:,:])*wgt -#-------------------------------------------------------------------------------------------------- -# integration in Fourier space - k_s = np.zeros([3],'i') - for i in xrange(grid[2]): - k_s[2] = i - if(i > grid[2]//2 ): k_s[2] = k_s[2] - grid[2] - for j in xrange(grid[1]): - k_s[1] = j - if(j > grid[1]//2 ): k_s[1] = k_s[1] - grid[1] - for k in xrange(grid[0]//2+1): - k_s[0] = k - for m in xrange(3): - coords_fourier[i,j,k,m] = sum(F_fourier[i,j,k,m,0:3]*k_s*integrator) - if (any(k_s != 0)): - coords_fourier[i,j,k,0:3] /= -sum(k_s*k_s) - -#-------------------------------------------------------------------------------------------------- -# add average to scaled fluctuation and put (0,0,0) on (0,0,0) - coords = np.fft.irfftn(coords_fourier,F.shape[0:3],axes=(0,1,2)) - - offset_coords = np.dot(F[0,0,0,:,:],step/2.0) - scaling*coords[0,0,0,0:3] - for z in xrange(grid[2]): - for y in xrange(grid[1]): - for x in xrange(grid[0]): - coords[z,y,x,0:3] = scaling*coords[z,y,x,0:3] \ - + offset_coords \ - + np.dot(Favg,step*np.array([x,y,z])) - - return coords - -# -------------------------------------------------------------------- -# MAIN -# -------------------------------------------------------------------- - -parser = OptionParser(option_class=damask.extendableOption, usage='%prog options file[s]', description = """ -Add deformed configuration of given initial coordinates. -Operates on periodic three-dimensional x,y,z-ordered data sets. - -""", version = scriptID) - -parser.add_option('-f', '--defgrad',dest='defgrad', metavar = 'string', - help='heading of deformation gradient columns [%default]') -parser.add_option('--reference', dest='undeformed', action='store_true', - help='map results to reference (undeformed) average configuration [%default]') -parser.add_option('--scaling', dest='scaling', action='extend', metavar = '', - help='scaling of fluctuation') -parser.add_option('-u', '--unitlength', dest='unitlength', type='float', metavar = 'float', - help='set unit length for 2D model [%default]') -parser.add_option('--coordinates', dest='coords', metavar='string', - help='column heading for coordinates [%default]') - -parser.set_defaults(defgrad = 'f') -parser.set_defaults(coords = 'ipinitialcoord') -parser.set_defaults(scaling = []) -parser.set_defaults(undeformed = False) -parser.set_defaults(unitlength = 0.0) - -(options,filenames) = parser.parse_args() - -options.scaling += [1.0 for i in xrange(max(0,3-len(options.scaling)))] -scaling = map(float, options.scaling) - - -# --- loop over input files ------------------------------------------------------------------------- - -if filenames == []: filenames = [None] - -for name in filenames: - try: - table = damask.ASCIItable(name = name, - buffered = False) - except: continue - damask.util.report(scriptName,name) - -# ------------------------------------------ read header ------------------------------------------ - - table.head_read() - -# ------------------------------------------ sanity checks ---------------------------------------- - - errors = [] - remarks = [] - - if table.label_dimension(options.coords) != 3: errors.append('coordinates {} are not a vector.'.format(options.coords)) - else: colCoord = table.label_index(options.coords) - - if table.label_dimension(options.defgrad) != 9: errors.append('deformation gradient {} is not a tensor.'.format(options.defgrad)) - else: colF = table.label_index(options.defgrad) - - if remarks != []: damask.util.croak(remarks) - if errors != []: - damask.util.croak(errors) - table.close(dismiss = True) - continue - -# --------------- figure out size and grid --------------------------------------------------------- - - table.data_readArray() - - coords = [np.unique(table.data[:,colCoord+i]) for i in xrange(3)] - mincorner = np.array(map(min,coords)) - maxcorner = np.array(map(max,coords)) - grid = np.array(map(len,coords),'i') - size = grid/np.maximum(np.ones(3,'d'), grid-1.0) * (maxcorner-mincorner) # size from edge to edge = dim * n/(n-1) - size = np.where(grid > 1, size, min(size[grid > 1]/grid[grid > 1])) # spacing for grid==1 set to smallest among other spacings - - N = grid.prod() - - if N != len(table.data): errors.append('data count {} does not match grid {}x{}x{}.'.format(N,*grid)) - if errors != []: - damask.util.croak(errors) - table.close(dismiss = True) - continue - -# ------------------------------------------ assemble header --------------------------------------- - - table.info_append(scriptID + '\t' + ' '.join(sys.argv[1:])) - for coord in xrange(3): - label = '{}_{}_{}'.format(coord+1,options.defgrad,options.coords) - if np.any(scaling) != 1.0: label+='_{}_{}_{}'.format(scaling) - if options.undeformed: label+='_undeformed' - table.labels_append([label]) # extend ASCII header with new labels - table.head_write() - -# ------------------------------------------ read deformation gradient field ----------------------- - centroids = deformedCoordsFFT(table.data[:,colF:colF+9].reshape(grid[2],grid[1],grid[0],3,3), - options.undeformed) -# ------------------------------------------ process data ------------------------------------------ - table.data_rewind() - for z in xrange(grid[2]): - for y in xrange(grid[1]): - for x in xrange(grid[0]): - table.data_read() - table.data_append(list(centroids[z,y,x,:])) - table.data_write() - -# ------------------------------------------ output finalization ----------------------------------- - - table.close() # close ASCII tables \ No newline at end of file diff --git a/processing/post/nodesAroundCentres.py b/processing/post/nodesAroundCentres.py deleted file mode 100644 index 3a2624b16..000000000 --- a/processing/post/nodesAroundCentres.py +++ /dev/null @@ -1,152 +0,0 @@ -#!/usr/bin/env python -# -*- coding: UTF-8 no BOM -*- - -import os,sys,math,string -import numpy as np -from optparse import OptionParser -import damask - -scriptID = string.replace('$Id: addDeformedConfiguration.py 4500 2015-09-24 09:24:42Z MPIE\m.diehl $','\n','\\n') -scriptName = os.path.splitext(scriptID.split()[1])[0] - -#-------------------------------------------------------------------------------------------------- -def nodesAroundCentres(gDim,Favg,centres): -#-------------------------------------------------------------------------------------------------- - neighbor = np.array([0, 0, 0, - 1, 0, 0, - 1, 1, 0, - 0, 1, 0, - 0, 0, 1, - 1, 0, 1, - 1, 1, 1, - 0, 1, 1]).reshape(8,3) - -#-------------------------------------------------------------------------------------------------- -# building wrappedCentres = centroids + ghosts - diag = np.ones([3]) - wrappedCentres = np.zeros([3,grid[0]+2,grid[1]+2,grid[2]+2]) - wrappedCentres[0:3,1:grid[0]+1,1:grid[1]+1,1:grid[2]+1] = centres - for k in xrange(grid[2]+2): - for j in xrange(grid[1]+2): - for i in xrange(grid[0]+2): - if (k in [0,grid[2]+1] or j in [0,grid[1]+1] or i in[0,grid[0]+1]): - me = np.array([i,j,k],'i') # me on skin - shift = abs(grid+np.ones([3],'i')-2*me)/(grid+np.ones([3],'i'))*\ - np.sign(grid+np.ones([3],'i')-2*me) - lookup = np.array(me-diag+shift*grid,'i') - wrappedCentres[0:3,i, j, k] = \ - centres[0:3,lookup[0],lookup[1],lookup[2]] - np.dot(Favg, shift*gDim) - -#-------------------------------------------------------------------------------------------------- -# averaging - nodes = np.zeros([3,grid[0]+1,grid[1]+1,grid[2]+1]) - for k in xrange(grid[2]+1): - for j in xrange(grid[1]+1): - for i in xrange(grid[0]+1): - for n in xrange(8): - nodes[0:3,i,j,k] = \ - nodes[0:3,i,j,k] + wrappedCentres[0:3,i+neighbor[n,0],j+neighbor[n,1],k+neighbor[n,2] ] - - return nodes/8.0 - -# -------------------------------------------------------------------- -# MAIN -# -------------------------------------------------------------------- - -parser = OptionParser(option_class=damask.extendableOption, usage='%prog options file[s]', description = """ -Add deformed configuration of given initial coordinates. -Operates on periodic three-dimensional x,y,z-ordered data sets. - -""", version = scriptID) - -parser.add_option('-f', '--defgrad',dest='defgrad', metavar = 'string', - help='heading of deformation gradient columns [%default]') -parser.add_option('-u', '--unitlength', dest='unitlength', type='float', metavar = 'float', - help='set unit length for 2D model [%default]') - -parser.set_defaults(deformed = 'ipinitialcoord') -parser.set_defaults(unitlength = 0.0) - -(options,filenames) = parser.parse_args() - -options.scaling += [1.0 for i in xrange(max(0,3-len(options.scaling)))] -scaling = map(float, options.scaling) - - -# --- loop over input files ------------------------------------------------------------------------- - -if filenames == []: filenames = [None] - -for name in filenames: - try: - table = damask.ASCIItable(name = name, - buffered = False) - except: continue - damask.util.report(scriptName,name) - -# ------------------------------------------ read header ------------------------------------------ - - table.head_read() - -# ------------------------------------------ sanity checks ---------------------------------------- - - errors = [] - remarks = [] - - if table.label_dimension(options.coords) != 3: errors.append('coordinates {} are not a vector.'.format(options.coords)) - else: colCoord = table.label_index(options.coords) - - if table.label_dimension(options.defgrad) != 9: errors.append('deformation gradient {} is not a tensor.'.format(options.defgrad)) - else: colF = table.label_index(options.defgrad) - - if remarks != []: damask.util.croak(remarks) - if errors != []: - damask.util.croak(errors) - table.close(dismiss = True) - continue - -# --------------- figure out size and grid --------------------------------------------------------- - - table.data_readArray() - - coords = [np.unique(table.data[:,colCoord+i]) for i in xrange(3)] - mincorner = np.array(map(min,coords)) - maxcorner = np.array(map(max,coords)) - grid = np.array(map(len,coords),'i') - size = grid/np.maximum(np.ones(3,'d'), grid-1.0) * (maxcorner-mincorner) # size from edge to edge = dim * n/(n-1) - size = np.where(grid > 1, size, min(size[grid > 1]/grid[grid > 1])) # spacing for grid==1 equal to smallest among other spacings - - N = grid.prod() - - if N != len(table.data): errors.append('data count {} does not match grid {}x{}x{}.'.format(N,*grid)) - if errors != []: - damask.util.croak(errors) - table.close(dismiss = True) - continue - -# ------------------------------------------ assemble header --------------------------------------- - - table.info_append(scriptID + '\t' + ' '.join(sys.argv[1:])) - for coord in xrange(3): - label = '{}_{}_{}'.format(coord+1,options.defgrad,options.coords) - if np.any(scaling) != 1.0: label+='_{}_{}_{}'.format(scaling) - if options.undeformed: label+='_undeformed' - table.labels_append([label]) # extend ASCII header with new labels - table.head_write() - -# ------------------------------------------ read deformation gradient field ----------------------- - centroids,Favg = deformedCoordsFFT(table.data[:,colF:colF+9].reshape(grid[0],grid[1],grid[2],3,3)) - -# ------------------------------------------ process data ------------------------------------------ - table.data_rewind() - idx = 0 - outputAlive = True - while outputAlive and table.data_read(): # read next data line of ASCII table - (x,y,z) = damask.util.gridLocation(idx,grid) # figure out (x,y,z) position from line count - idx += 1 - table.data_append(list(centroids[z,y,x,:])) - outputAlive = table.data_write() - -# ------------------------------------------ output finalization ----------------------------------- - - table.close() # close ASCII tables From 5682d8f6270635cbbb4ef475af3e800d1008cb25 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 15 Apr 2016 00:11:03 +0200 Subject: [PATCH 11/37] also not needed --- processing/post/3Dvisualize.py | 482 --------------------------------- 1 file changed, 482 deletions(-) delete mode 100755 processing/post/3Dvisualize.py diff --git a/processing/post/3Dvisualize.py b/processing/post/3Dvisualize.py deleted file mode 100755 index fb5465d41..000000000 --- a/processing/post/3Dvisualize.py +++ /dev/null @@ -1,482 +0,0 @@ -#!/usr/bin/env python -# -*- coding: UTF-8 no BOM -*- - -import os,sys,re,fnmatch,vtk -import numpy as np -from optparse import OptionParser -import damask - -scriptName = os.path.splitext(os.path.basename(__file__))[0] -scriptID = ' '.join([scriptName,damask.version]) - -def deformedCoordsFFT(size,F,scaling,Favg=None): - grid = np.array(np.shape(F)[:-2]) - N = grid.prod() - step = size/grid - k_s = np.zeros([3],'i') - - F_fourier = np.fft.fftpack.rfftn(F,s=grid,axes=(0,1,2)) - coords_fourier = np.zeros(F_fourier.shape[:-1],'c16') - if Favg is None: - Favg = np.real(F_fourier[0,0,0,:,:]/N) - - for i in xrange(grid[2]//2+1): - k_s[2] = i - if grid[2]%2 == 0 and i == grid[2]//2: k_s[2] = 0 # for even grid, set Nyquist freq to 0 (Johnson, MIT, 2011) - - for j in xrange(grid[1]): - k_s[1] = j - if grid[1]%2 == 0 and j == grid[1]//2: k_s[1] = 0 # for even grid, set Nyquist freq to 0 (Johnson, MIT, 2011) - elif j > grid[1]//2: k_s[1] -= grid[1] - - for k in xrange(grid[0]): - k_s[0] = k - if grid[0]%2 == 0 and k == grid[0]//2: k_s[0] = 0 # for even grid, set Nyquist freq to 0 (Johnson, MIT, 2011) - elif k > grid[0]//2: k_s[0] -= grid[0] - - xi = 0.0+(k_s*0.5j*size/math.pi) - for m in xrange(3): - coords_fourier[k,j,i,m] = np.sum(F_fourier[k,j,i,m,:]*xi) - - if (any(k_s != 0)): - coords_fourier[k,j,i,:]/=-np.linalg.norm(k_s)**2.0 - - coords = np.fft.fftpack.irfftn(coords_fourier,s=grid,axes=(0,1,2)) - offset_coords =np.dot(F[0,0,0,:,:],step/2.0) - scaling*coords[0,0,0,:] - - for z in xrange(grid[2]): - for y in xrange(grid[1]): - for x in xrange(grid[0]): - coords[x,y,z,:] += offset_coords + np.dot(Favg,[x,y,z]*step) - -def outStdout(cmd,locals): - if cmd[0:3] == '(!)': - exec(cmd[3:]) - elif cmd[0:3] == '(?)': - cmd = eval(cmd[3:]) - print cmd - else: - print cmd - return - -def outFile(cmd,locals): - if cmd[0:3] == '(!)': - exec(cmd[3:]) - elif cmd[0:3] == '(?)': - cmd = eval(cmd[3:]) - locals['filepointer'].write(cmd+'\n') - else: - locals['filepointer'].write(cmd+'\n') - return - - -def output(cmds,locals,dest): - for cmd in cmds: - if isinstance(cmd,list): - output(cmd,locals,dest) - else: - {\ - 'File': outFile,\ - 'Stdout': outStdout,\ - }[dest](str(cmd),locals) - return - - -def transliterateToFloat(x): - try: - return float(x) - except: - return 0.0 - - -def unravel(item): - if hasattr(item,'__contains__'): return ' '.join(map(unravel,item)) - else: return str(item) - - -# ++++++++++++++++++++++++++++++++++++++++++++++++++++ -def vtk_writeASCII_mesh(mesh,data,res,sep): - """function writes data array defined on a hexahedral mesh (geometry)""" - info = {\ - 'tensor': {'name':'tensor','len':9},\ - 'vector': {'name':'vector','len':3},\ - 'scalar': {'name':'scalar','len':1},\ - 'double': {'name':'scalar','len':2},\ - 'triple': {'name':'scalar','len':3},\ - 'quadruple': {'name':'scalar','len':4},\ - } - N1 = (res[0]+1)*(res[1]+1)*(res[2]+1) - N = res[0]*res[1]*res[2] - - cmds = [\ - '# vtk DataFile Version 3.1', - 'powered by %s'%scriptID, - 'ASCII', - 'DATASET UNSTRUCTURED_GRID', - 'POINTS %i double'%N1, - [[['\t'.join(map(str,mesh[:,i,j,k])) for i in range(res[0]+1)] for j in range(res[1]+1)] for k in range(res[2]+1)], - 'CELLS %i %i'%(N,N*9), - ] - -# cells - for z in range (res[2]): - for y in range (res[1]): - for x in range (res[0]): - base = z*(res[1]+1)*(res[0]+1)+y*(res[0]+1)+x - cmds.append('8 '+'\t'.join(map(str,[ \ - base, - base+1, - base+res[0]+2, - base+res[0]+1, - base+(res[1]+1)*(res[0]+1), - base+(res[1]+1)*(res[0]+1)+1, - base+(res[1]+1)*(res[0]+1)+res[0]+2, - base+(res[1]+1)*(res[0]+1)+res[0]+1, - ]))) - cmds += [\ - 'CELL_TYPES %i'%N, - ['12']*N, - 'CELL_DATA %i'%N, - ] - - for type in data: - plural = {True:'',False:'S'}[type.lower().endswith('s')] - for item in data[type]['_order_']: - cmds += [\ - '%s %s double'%(info[type]['name'].upper()+plural,item), - {True:'LOOKUP_TABLE default',False:''}[info[type]['name'][:3]=='sca'], - [[[sep.join(map(unravel,data[type][item][:,j,k]))] for j in range(res[1])] for k in range(res[2])], - ] - - return cmds - -#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -def vtk_writeASCII_points(coordinates,data,res,sep): - """function writes data array defined on a point field""" - N = res[0]*res[1]*res[2] - - cmds = [\ - '# vtk DataFile Version 3.1', - 'powered by %s'%scriptID, - 'ASCII', - 'DATASET UNSTRUCTURED_GRID', - 'POINTS %i double'%N, - [[['\t'.join(map(str,coordinates[i,j,k])) for i in range(res[0])] for j in range(res[1])] for k in range(res[2])], - 'CELLS %i %i'%(N,N*2), - ['1\t%i'%i for i in range(N)], - 'CELL_TYPES %i'%N, - ['1']*N, - 'POINT_DATA %i'%N, - ] - - for type in data: - plural = {True:'',False:'S'}[type.lower().endswith('s')] - for item in data[type]: - cmds += [\ - '%s %s double'%(type.upper()+plural,item), - {True:'LOOKUP_TABLE default',False:''}[type.lower()[:3]=='sca'], - [[[sep.join(map(unravel,data[type][item][:,j,k]))] for j in range(res[1])] for k in range(res[2])], - ] - - return cmds - - -# ----------------------- MAIN ------------------------------- - -parser = OptionParser(option_class=damask.extendableOption, usage='%prog [options] datafile[s]', description = """ -Produce VTK file from data field. -Coordinates are taken from (consecutive) x, y, and z columns. - -""", version = scriptID) - -sepChoices = ['n','t','s'] -parser.add_option('-s', '--scalar', dest='scalar', action='extend', metavar = '', - help='list of single scalars to visualize') -parser.add_option( '--double', dest='double', action='extend', metavar = '', - help='list of two scalars to visualize') -parser.add_option( '--triple', dest='triple', action='extend', metavar = '', - help='list of three scalars to visualize') -parser.add_option( '--quadruple', dest='quadruple', action='extend', metavar = '', - help='list of four scalars to visualize') -parser.add_option('-v', '--vector', dest='vector', action='extend', metavar = '', - help='list of vectors to visualize') -parser.add_option('-t', '--tensor', dest='tensor', action='extend', metavar = '', - help='list of tensors to visualize') -parser.add_option('-d', '--deformation', dest='defgrad', metavar = 'string', - help='heading of deformation gradient columns [%default]') -parser.add_option('--reference', dest='undeformed', action='store_true', - help='map results to reference (undeformed) configuration [%default]') -parser.add_option('-c','--cell', dest='cell', action='store_true', - help='data is cell-centered [%default]') -parser.add_option('-p','--vertex', dest='cell', action='store_false', - help='data is vertex-centered') -parser.add_option('--mesh', dest='output_mesh', action='store_true', - help='produce VTK mesh file [%default]') -parser.add_option('--nomesh', dest='output_mesh', action='store_false', - help='omit VTK mesh file') -parser.add_option('--points', dest='output_points', action='store_true', - help='produce VTK points file [%default]') -parser.add_option('--nopoints', dest='output_points', action='store_false', - help='omit VTK points file') -parser.add_option('--separator', dest='separator', type='choice', choices=sepChoices, metavar='string', - help='data separator {%s} [t]'%(' '.join(map(str,sepChoices)))) -parser.add_option('--scaling', dest='scaling', action='extend', metavar = '', - help='scaling of fluctuation') -parser.add_option('-u', '--unitlength', dest='unitlength', type='float', metavar = 'float', - help='set unit length for 2D model [%default]') - -parser.set_defaults(defgrad = 'f') -parser.set_defaults(separator = 't') -parser.set_defaults(scalar = []) -parser.set_defaults(double = []) -parser.set_defaults(triple = []) -parser.set_defaults(quadruple = []) -parser.set_defaults(vector = []) -parser.set_defaults(tensor = []) -parser.set_defaults(output_mesh = True) -parser.set_defaults(output_points = False) -parser.set_defaults(scaling = []) -parser.set_defaults(undeformed = False) -parser.set_defaults(unitlength = 0.0) -parser.set_defaults(cell = True) - -sep = {'n': '\n', 't': '\t', 's': ' '} - -(options, args) = parser.parse_args() - -options.scaling += [1.0 for i in xrange(max(0,3-len(options.scaling)))] -options.scaling = map(float, options.scaling) - -for filename in args: - if not os.path.exists(filename): - continue - file = open(filename) - content = file.readlines() - file.close() - m = re.search('(\d+)\s*head', content[0].lower()) - if m is None: - continue - print filename,'\n' - sys.stdout.flush() - - headrow = int(m.group(1)) - headings = content[headrow].split() - column = {} - matches = {} - maxcol = 0 - locol = -1 - - for col,head in enumerate(headings): - if head == {True:'1_ipinitialcoord',False:'1_nodeinitialcoord'}[options.cell]: - locol = col - maxcol = max(maxcol,col+3) - break - - if locol < 0: - print 'missing coordinates..!' - continue - - column['tensor'] = {} - matches['tensor'] = {} - for label in [options.defgrad] + options.tensor: - column['tensor'][label] = -1 - for col,head in enumerate(headings): - if head == label or head == '1_'+label: - column['tensor'][label] = col - maxcol = max(maxcol,col+9) - matches['tensor'][label] = [label] - break - - if not options.undeformed and column['tensor'][options.defgrad] < 0: - print 'missing deformation gradient "%s"..!'%options.defgrad - continue - - column['vector'] = {} - matches['vector'] = {} - for label in options.vector: - column['vector'][label] = -1 - for col,head in enumerate(headings): - if head == label or head == '1_'+label: - column['vector'][label] = col - maxcol = max(maxcol,col+3) - matches['vector'][label] = [label] - break - - for length,what in enumerate(['scalar','double','triple','quadruple']): - column[what] = {} - labels = eval("options.%s"%what) - matches[what] = {} - for col,head in enumerate(headings): - for needle in labels: - if fnmatch.fnmatch(head,needle): - column[what][head] = col - maxcol = max(maxcol,col+1+length) - if needle not in matches[what]: - matches[what][needle] = [head] - else: - matches[what][needle] += [head] - - - values = np.array(sorted([map(transliterateToFloat,line.split()[:maxcol]) for line in content[headrow+1:]], - key=lambda x:(x[locol+0],x[locol+1],x[locol+2])),'d') # sort with z as fastest and x as slowest index - values2 = np.array([map(transliterateToFloat,line.split()[:maxcol]) for line in content[headrow+1:]],'d') # sort with x as fastest and z as slowest index - - N = len(values) - - tempGrid = [{},{},{}] - for j in xrange(3): - for i in xrange(N): - tempGrid[j][str(values[i,locol+j])] = True - - grid = np.array([len(tempGrid[0]),\ - len(tempGrid[1]),\ - len(tempGrid[2]),],'i') - - dim = np.ones(3) - - for i,r in enumerate(grid): - if r > 1: - dim[i] = (max(map(float,tempGrid[i].keys()))-min(map(float,tempGrid[i].keys())))*r/(r-1.0) - if grid[2]==1: # for 2D case set undefined dimension to given unitlength or alternatively give it the length of the smallest element - if options.unitlength == 0.0: - dim[2] = min(dim/grid) - else: - dim[2] = options.unitlength - print dim - if options.undeformed: - Favg = np.eye(3) - else: - Favg = damask.core.math.tensorAvg( - np.reshape(np.transpose(values[:,column['tensor'][options.defgrad]: - column['tensor'][options.defgrad]+9]), - (3,3,grid[0],grid[1],grid[2]))) - - F = np.reshape(np.transpose(values[:,column['tensor'][options.defgrad]: - column['tensor'][options.defgrad]+9]), - (3,3,grid[0],grid[1],grid[2])) - F2 = np.reshape(values[:,column['tensor'][options.defgrad]: - column['tensor'][options.defgrad]+9], - (grid[0],grid[1],grid[2],3,3)) - for z in xrange(grid[2]): - for y in xrange(grid[1]): - for x in xrange(grid[0]): - F2[x,y,z,:,:] = F2[x,y,z,:,:].T - centroids2 = deformedCoordsFFT(dim,F2,options.scaling,None) - centroids = damask.core.mesh.deformedCoordsFFT(dim,F,Favg,options.scaling) - - nodes = damask.core.mesh.nodesAroundCentres(dim,Favg,centroids) - - fields = {\ - 'tensor': {},\ - 'vector': {},\ - 'scalar': {},\ - 'double': {},\ - 'triple': {},\ - 'quadruple': {},\ - } - reshape = {\ - 'tensor': [3,3],\ - 'vector': [3],\ - 'scalar': [],\ - 'double': [2],\ - 'triple': [3],\ - 'quadruple': [4],\ - } - length = {\ - 'tensor': 9,\ - 'vector': 3,\ - 'scalar': 1,\ - 'double': 2,\ - 'triple': 3,\ - 'quadruple': 4,\ - } - - -# vtk lib out - if False: - points = vtk.vtkPoints() - for z in range (grid[2]+1): - for y in range (grid[1]+1): - for x in range (grid[0]+1): - points.InsertNextPoint(nodes[:,x,y,z]) - - data=[] - j=0 - for datatype in fields.keys(): - for what in eval('options.'+datatype): - for label in matches[datatype][what]: - col = column[datatype][label] - if col != -1: - data.append(vtk.vtkFloatArray()) - data[j].SetNumberOfComponents(length[datatype]) - for i in xrange(grid[2]*grid[1]*grid[0]): - for k in xrange(length[datatype]): - data[j].InsertNextValue(values2[i,col+k]) - data[j].SetName(label) - j+=1 - - if options.output_mesh: - hexs = vtk.vtkCellArray() - i = 0 - elems=[] - for z in range (grid[2]): - for y in range (grid[1]): - for x in range (grid[0]): - - elems.append(vtk.vtkHexahedron()) - base = z*(grid[1]+1)*(grid[0]+1)+y*(grid[0]+1)+x - elems[i].GetPointIds().SetId(0, base) - elems[i].GetPointIds().SetId(1, base+1) - elems[i].GetPointIds().SetId(2, base+grid[0]+2) - elems[i].GetPointIds().SetId(3, base+grid[0]+1) - elems[i].GetPointIds().SetId(4, base+(grid[1]+1)*(grid[0]+1)) - elems[i].GetPointIds().SetId(5, base+(grid[1]+1)*(grid[0]+1)+1) - elems[i].GetPointIds().SetId(6, base+(grid[1]+1)*(grid[0]+1)+grid[0]+2) - elems[i].GetPointIds().SetId(7, base+(grid[1]+1)*(grid[0]+1)+grid[0]+1) - hexs.InsertNextCell(elems[i]) - i+=1 - - uGrid = vtk.vtkUnstructuredGrid() - uGrid.SetPoints(points) - i = 0 - for z in range (grid[2]): - for y in range (grid[1]): - for x in range (grid[0]): - uGrid.InsertNextCell(elems[i].GetCellType(), elems[i].GetPointIds()) - i+=1 - - for i in xrange(len(data)): - uGrid.GetCellData().AddArray(data[i]) - - outWriter = vtk.vtkXMLUnstructuredGridWriter() - outWriter.SetDataModeToBinary() - outWriter.SetCompressorTypeToZLib() - (head,tail) = os.path.split(filename) - outWriter.SetFileName(os.path.join(head,'mesh_'+os.path.splitext(tail)[0]+'.vtu')) - outWriter.SetInput(uGrid) - outWriter.Write() - - - for datatype in fields.keys(): - print '\n%s:'%datatype, - fields[datatype]['_order_'] = [] - for what in eval('options.'+datatype): - for label in matches[datatype][what]: - col = column[datatype][label] - if col != -1: - print label, - fields[datatype][label] = np.reshape(values[:,col:col+length[datatype]],[grid[0],grid[1],grid[2]]+reshape[datatype]) - fields[datatype]['_order_'] += [label] - print '\n' - - out = {} - if options.output_mesh: out['mesh'] = vtk_writeASCII_mesh(nodes,fields,grid,sep[options.separator]) - if options.output_points: out['points'] = vtk_writeASCII_points(centroids,fields,grid,sep[options.separator]) - - for what in out.keys(): - print what - (head,tail) = os.path.split(filename) - vtk = open(os.path.join(head,what+'_'+os.path.splitext(tail)[0]+'.vtk'), 'w') - output(out[what],{'filepointer':vtk},'File') - vtk.close() - print From 0632dc1308e5061c4d8e6ea99e5f16ff58aea503 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 15 Apr 2016 00:21:45 +0200 Subject: [PATCH 12/37] pyflakes complained --- lib/damask/__init__.py | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lib/damask/__init__.py b/lib/damask/__init__.py index dc40920fa..3edaa9efa 100644 --- a/lib/damask/__init__.py +++ b/lib/damask/__init__.py @@ -1,7 +1,7 @@ # -*- coding: UTF-8 no BOM -*- """Main aggregator""" -import sys, os +import os with open(os.path.join(os.path.dirname(__file__),'../../VERSION')) as f: version = f.readline()[:-1] @@ -11,10 +11,10 @@ from .asciitable import ASCIItable # noqa from .config import Material # noqa from .colormaps import Colormap, Color # noqa try: - from .corientation import Quaternion, Rodrigues, Symmetry, Orientation + from .corientation import Quaternion, Rodrigues, Symmetry, Orientation # noqa print "Import Cython version of Orientation module" except: - from .orientation import Quaternion, Rodrigues, Symmetry, Orientation + from .orientation import Quaternion, Rodrigues, Symmetry, Orientation # noqa #from .block import Block # only one class from .result import Result # noqa from .geometry import Geometry # noqa From 72639d174b90fdd9b0a216bd3a718becc98843c2 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 15 Apr 2016 00:25:12 +0200 Subject: [PATCH 13/37] fortran code was translated by philip --- lib/damask/util.py | 92 +--------------------------------------------- 1 file changed, 1 insertion(+), 91 deletions(-) diff --git a/lib/damask/util.py b/lib/damask/util.py index 81eb30713..07bb55865 100644 --- a/lib/damask/util.py +++ b/lib/damask/util.py @@ -450,94 +450,4 @@ def curve_fit_bound(f, xdata, ydata, p0=None, sigma=None, bounds=None, **kw): else: pcov = np.inf - return (popt, pcov, infodict, errmsg, ier) if return_full else (popt, pcov) - - -!-------------------------------------------------------------------------------------------------- -!> @brief builds mesh of (distorted) cubes for given coordinates (= center of the cubes) -!-------------------------------------------------------------------------------------------------- -function mesh_nodesAroundCentres(gDim,Favg,centres) result(nodes) - use debug, only: & - debug_mesh, & - debug_level, & - debug_levelBasic - use math, only: & - math_mul33x3 - - implicit none - real(pReal), intent(in), dimension(:,:,:,:) :: & - centres - real(pReal), dimension(3,size(centres,2)+1,size(centres,3)+1,size(centres,4)+1) :: & - nodes - real(pReal), intent(in), dimension(3) :: & - gDim - real(pReal), intent(in), dimension(3,3) :: & - Favg - real(pReal), dimension(3,size(centres,2)+2,size(centres,3)+2,size(centres,4)+2) :: & - wrappedCentres - - integer(pInt) :: & - i,j,k,n - integer(pInt), dimension(3), parameter :: & - diag = 1_pInt - integer(pInt), dimension(3) :: & - shift = 0_pInt, & - lookup = 0_pInt, & - me = 0_pInt, & - iRes = 0_pInt - integer(pInt), dimension(3,8) :: & - neighbor = reshape([ & - 0_pInt, 0_pInt, 0_pInt, & - 1_pInt, 0_pInt, 0_pInt, & - 1_pInt, 1_pInt, 0_pInt, & - 0_pInt, 1_pInt, 0_pInt, & - 0_pInt, 0_pInt, 1_pInt, & - 1_pInt, 0_pInt, 1_pInt, & - 1_pInt, 1_pInt, 1_pInt, & - 0_pInt, 1_pInt, 1_pInt ], [3,8]) - -!-------------------------------------------------------------------------------------------------- -! initializing variables - iRes = [size(centres,2),size(centres,3),size(centres,4)] - nodes = 0.0_pReal - wrappedCentres = 0.0_pReal - -!-------------------------------------------------------------------------------------------------- -! report - if (iand(debug_level(debug_mesh),debug_levelBasic) /= 0_pInt) then - write(6,'(a)') ' Meshing cubes around centroids' - write(6,'(a,3(e12.5))') ' Dimension: ', gDim - write(6,'(a,3(i5))') ' Resolution:', iRes - endif - -!-------------------------------------------------------------------------------------------------- -! building wrappedCentres = centroids + ghosts - wrappedCentres(1:3,2_pInt:iRes(1)+1_pInt,2_pInt:iRes(2)+1_pInt,2_pInt:iRes(3)+1_pInt) = centres - do k = 0_pInt,iRes(3)+1_pInt - do j = 0_pInt,iRes(2)+1_pInt - do i = 0_pInt,iRes(1)+1_pInt - if (k==0_pInt .or. k==iRes(3)+1_pInt .or. & ! z skin - j==0_pInt .or. j==iRes(2)+1_pInt .or. & ! y skin - i==0_pInt .or. i==iRes(1)+1_pInt ) then ! x skin - me = [i,j,k] ! me on skin - shift = sign(abs(iRes+diag-2_pInt*me)/(iRes+diag),iRes+diag-2_pInt*me) - lookup = me-diag+shift*iRes - wrappedCentres(1:3,i+1_pInt, j+1_pInt, k+1_pInt) = & - centres(1:3,lookup(1)+1_pInt,lookup(2)+1_pInt,lookup(3)+1_pInt) - & - math_mul33x3(Favg, shift*gDim) - endif - enddo; enddo; enddo - -!-------------------------------------------------------------------------------------------------- -! averaging - do k = 0_pInt,iRes(3); do j = 0_pInt,iRes(2); do i = 0_pInt,iRes(1) - do n = 1_pInt,8_pInt - nodes(1:3,i+1_pInt,j+1_pInt,k+1_pInt) = & - nodes(1:3,i+1_pInt,j+1_pInt,k+1_pInt) + wrappedCentres(1:3,i+1_pInt+neighbor(1,n), & - j+1_pInt+neighbor(2,n), & - k+1_pInt+neighbor(3,n) ) - enddo - enddo; enddo; enddo - nodes = nodes/8.0_pReal - -end function mesh_nodesAroundCentres + return (popt, pcov, infodict, errmsg, ier) if return_full else (popt, pcov) \ No newline at end of file From 91753d53228a26504c371b8df485f776b3a8b8fa Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 15 Apr 2016 00:32:30 +0200 Subject: [PATCH 14/37] more style related changes --- processing/post/addCompatibilityMismatch.py | 21 +++++++++++---------- 1 file changed, 11 insertions(+), 10 deletions(-) diff --git a/processing/post/addCompatibilityMismatch.py b/processing/post/addCompatibilityMismatch.py index 8c9e479ec..a8f9dfd2b 100755 --- a/processing/post/addCompatibilityMismatch.py +++ b/processing/post/addCompatibilityMismatch.py @@ -12,8 +12,9 @@ scriptID = ' '.join([scriptName,damask.version]) def volTetrahedron(coords): """ - Return the volume of the tetrahedron with given vertices or sides. If - vertices are given they must be in a NumPy array with shape (4,3): the + Return the volume of the tetrahedron with given vertices or sides. + + Ifvertices are given they must be in a NumPy array with shape (4,3): the position vectors of the 4 vertices in 3 dimensions; if the six sides are given, they must be an array of length 6. If both are given, the sides will be used in the calculation. @@ -28,9 +29,7 @@ def volTetrahedron(coords): where s1, s2, ..., s6 are the tetrahedron side lengths. from http://codereview.stackexchange.com/questions/77593/calculating-the-volume-of-a-tetrahedron - """ - # The indexes of rows in the vertices array corresponding to all # possible pairs of vertices vertex_pair_indexes = np.array(((0, 1), (0, 2), (0, 3), @@ -59,10 +58,11 @@ def volTetrahedron(coords): def volumeMismatch(size,F,nodes): """ - calculates the mismatch between volume of reconstructed (compatible) cube and - determinant of defgrad at the FP + calculates the volume mismatch + + volume mismatch is defined as the difference between volume of reconstructed + (compatible) cube and determinant of defgrad at the FP """ - coords = np.empty([8,3]) vMismatch = np.empty(grid) volInitial = size.prod()/grid.prod() @@ -95,11 +95,12 @@ def volumeMismatch(size,F,nodes): def shapeMismatch(size,F,nodes,centres): """ - Routine to calculate the mismatch between the vectors from the central point to + Routine to calculate the shape mismatch + + shape mismatch is defined as difference between the vectors from the central point to the corners of reconstructed (combatible) volume element and the vectors calculated by deforming the initial volume element with the current deformation gradient """ - coordsInitial = np.empty([8,3]) sMismatch = np.empty(grid) @@ -121,7 +122,7 @@ def shapeMismatch(size,F,nodes,centres): for j in xrange(grid[1]): for i in xrange(grid[0]): sMismatch[i,j,k] = \ - np.linalg.norm(nodes[0:3,i, j, k] - centres[0:3,i,j,k] - np.dot(F[:,:,i,j,k], coordsInitial[0,0:3]))\ + + np.linalg.norm(nodes[0:3,i, j, k] - centres[0:3,i,j,k] - np.dot(F[:,:,i,j,k], coordsInitial[0,0:3]))\ + np.linalg.norm(nodes[0:3,i+1,j, k] - centres[0:3,i,j,k] - np.dot(F[:,:,i,j,k], coordsInitial[1,0:3]))\ + np.linalg.norm(nodes[0:3,i+1,j+1,k ] - centres[0:3,i,j,k] - np.dot(F[:,:,i,j,k], coordsInitial[2,0:3]))\ + np.linalg.norm(nodes[0:3,i, j+1,k ] - centres[0:3,i,j,k] - np.dot(F[:,:,i,j,k], coordsInitial[3,0:3]))\ From a3a36ead39f39400a98eaf35c5077c593b795926 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 27 Jun 2016 15:43:04 +0200 Subject: [PATCH 15/37] Libs not needed (got back during merge) --- code/Makefile | 7 +- code/spectral_interface.f90 | 163 +++++++++++++++++------------------- 2 files changed, 79 insertions(+), 91 deletions(-) diff --git a/code/Makefile b/code/Makefile index 110d595f3..a0f419ce0 100644 --- a/code/Makefile +++ b/code/Makefile @@ -351,7 +351,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 = C_routines.o system_routines.o prec.o DAMASK_interface.o IO.o libs.o numerics.o debug.o math.o \ +SPECTRAL_FILES = C_routines.o system_routines.o 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 \ @@ -401,7 +401,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 \ @@ -612,9 +612,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/spectral_interface.f90 b/code/spectral_interface.f90 index b10399cbd..862b8e849 100644 --- a/code/spectral_interface.f90 +++ b/code/spectral_interface.f90 @@ -44,13 +44,10 @@ contains !> @brief initializes the solver by interpreting the command line arguments. Also writes !! information on computation to screen !-------------------------------------------------------------------------------------------------- -subroutine DAMASK_interface_init(loadCaseParameterIn,geometryParameterIn) +subroutine DAMASK_interface_init() use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) implicit none - character(len=1024), optional, intent(in) :: & - loadCaseParameterIn, & !< if using the f2py variant, the -l argument of DAMASK_spectral.exe - geometryParameterIn !< if using the f2py variant, the -g argument of DAMASK_spectral.exe character(len=1024) :: & commandLine, & !< command line call as string loadCaseArg ='', & !< -l argument given to DAMASK_spectral.exe @@ -105,88 +102,82 @@ subroutine DAMASK_interface_init(loadCaseParameterIn,geometryParameterIn) write(6,'(/,a)') ' <<<+- DAMASK_interface init -+>>>' #include "compilation_info.f90" endif mainProcess - if ( present(loadcaseParameterIn) .and. present(geometryParameterIn)) then ! both mandatory parameters given in function call - geometryArg = geometryParameterIn - loadcaseArg = loadcaseParameterIn - commandLine = 'n/a' - else if ( .not.( present(loadcaseParameterIn) .and. present(geometryParameterIn))) then ! none parameters given in function call, trying to get them from command line - call get_command(commandLine) - chunkPos = IIO_stringPos(commandLine) - do i = 1, chunkPos(1) - tag = IIO_lc(IIO_stringValue(commandLine,chunkPos,i)) ! extract key - select case(tag) - case ('-h','--help') - mainProcess2: if (worldrank == 0) then - write(6,'(a)') ' #######################################################################' - write(6,'(a)') ' DAMASK_spectral:' - write(6,'(a)') ' The spectral method boundary value problem solver for' - write(6,'(a)') ' the Düsseldorf Advanced Material Simulation Kit' - write(6,'(a,/)')' #######################################################################' - write(6,'(a,/)')' Valid command line switches:' - write(6,'(a)') ' --geom (-g, --geometry)' - write(6,'(a)') ' --load (-l, --loadcase)' - write(6,'(a)') ' --workingdir (-w, --wd, --workingdirectory, -d, --directory)' - write(6,'(a)') ' --restart (-r, --rs)' - write(6,'(a)') ' --regrid (--rg)' - write(6,'(a)') ' --help (-h)' - write(6,'(/,a)')' -----------------------------------------------------------------------' - write(6,'(a)') ' Mandatory arguments:' - write(6,'(/,a)')' --geom PathToGeomFile/NameOfGeom.geom' - write(6,'(a)') ' Specifies the location of the geometry definition file,' - write(6,'(a)') ' if no extension is given, .geom will be appended.' - write(6,'(a)') ' "PathToGeomFile" will be the working directory if not specified' - write(6,'(a)') ' via --workingdir.' - write(6,'(a)') ' Make sure the file "material.config" exists in the working' - write(6,'(a)') ' directory.' - write(6,'(a)') ' For further configuration place "numerics.config"' - write(6,'(a)')' and "numerics.config" in that directory.' - write(6,'(/,a)')' --load PathToLoadFile/NameOfLoadFile.load' - write(6,'(a)') ' Specifies the location of the load case definition file,' - write(6,'(a)') ' if no extension is given, .load will be appended.' - write(6,'(/,a)')' -----------------------------------------------------------------------' - write(6,'(a)') ' Optional arguments:' - write(6,'(/,a)')' --workingdirectory PathToWorkingDirectory' - write(6,'(a)') ' Specifies the working directory and overwrites the default' - write(6,'(a)') ' "PathToGeomFile".' - write(6,'(a)') ' Make sure the file "material.config" exists in the working' - write(6,'(a)') ' directory.' - write(6,'(a)') ' For further configuration place "numerics.config"' - write(6,'(a)')' and "numerics.config" in that directory.' - write(6,'(/,a)')' --restart XX' - write(6,'(a)') ' Reads in total increment No. XX-1 and continues to' - write(6,'(a)') ' calculate total increment No. XX.' - write(6,'(a)') ' Appends to existing results file ' - write(6,'(a)') ' "NameOfGeom_NameOfLoadFile.spectralOut".' - write(6,'(a)') ' Works only if the restart information for total increment' - write(6,'(a)') ' No. XX-1 is available in the working directory.' - write(6,'(/,a)')' --regrid XX' - write(6,'(a)') ' Reads in total increment No. XX-1 and continues to' - write(6,'(a)') ' calculate total increment No. XX.' - write(6,'(a)') ' Attention: Overwrites existing results file ' - write(6,'(a)') ' "NameOfGeom_NameOfLoadFile.spectralOut".' - write(6,'(a)') ' Works only if the restart information for total increment' - write(6,'(a)') ' No. XX-1 is available in the working directory.' - write(6,'(/,a)')' -----------------------------------------------------------------------' - write(6,'(a)') ' Help:' - write(6,'(/,a)')' --help' - write(6,'(a,/)')' Prints this message and exits' - call quit(0_pInt) ! normal Termination - endif mainProcess2 - case ('-l', '--load', '--loadcase') - loadcaseArg = IIO_stringValue(commandLine,chunkPos,i+1_pInt) - case ('-g', '--geom', '--geometry') - geometryArg = IIO_stringValue(commandLine,chunkPos,i+1_pInt) - case ('-w', '-d', '--wd', '--directory', '--workingdir', '--workingdirectory') - workingDirArg = IIO_stringValue(commandLine,chunkPos,i+1_pInt) - case ('-r', '--rs', '--restart') - spectralRestartInc = IIO_IntValue(commandLine,chunkPos,i+1_pInt) - appendToOutFile = .true. - case ('--rg', '--regrid') - spectralRestartInc = IIO_IntValue(commandLine,chunkPos,i+1_pInt) - appendToOutFile = .false. - end select - enddo - endif + call get_command(commandLine) + chunkPos = IIO_stringPos(commandLine) + do i = 1, chunkPos(1) + tag = IIO_lc(IIO_stringValue(commandLine,chunkPos,i)) ! extract key + select case(tag) + case ('-h','--help') + mainProcess2: if (worldrank == 0) then + write(6,'(a)') ' #######################################################################' + write(6,'(a)') ' DAMASK_spectral:' + write(6,'(a)') ' The spectral method boundary value problem solver for' + write(6,'(a)') ' the Düsseldorf Advanced Material Simulation Kit' + write(6,'(a,/)')' #######################################################################' + write(6,'(a,/)')' Valid command line switches:' + write(6,'(a)') ' --geom (-g, --geometry)' + write(6,'(a)') ' --load (-l, --loadcase)' + write(6,'(a)') ' --workingdir (-w, --wd, --workingdirectory, -d, --directory)' + write(6,'(a)') ' --restart (-r, --rs)' + write(6,'(a)') ' --regrid (--rg)' + write(6,'(a)') ' --help (-h)' + write(6,'(/,a)')' -----------------------------------------------------------------------' + write(6,'(a)') ' Mandatory arguments:' + write(6,'(/,a)')' --geom PathToGeomFile/NameOfGeom.geom' + write(6,'(a)') ' Specifies the location of the geometry definition file,' + write(6,'(a)') ' if no extension is given, .geom will be appended.' + write(6,'(a)') ' "PathToGeomFile" will be the working directory if not specified' + write(6,'(a)') ' via --workingdir.' + write(6,'(a)') ' Make sure the file "material.config" exists in the working' + write(6,'(a)') ' directory.' + write(6,'(a)') ' For further configuration place "numerics.config"' + write(6,'(a)')' and "numerics.config" in that directory.' + write(6,'(/,a)')' --load PathToLoadFile/NameOfLoadFile.load' + write(6,'(a)') ' Specifies the location of the load case definition file,' + write(6,'(a)') ' if no extension is given, .load will be appended.' + write(6,'(/,a)')' -----------------------------------------------------------------------' + write(6,'(a)') ' Optional arguments:' + write(6,'(/,a)')' --workingdirectory PathToWorkingDirectory' + write(6,'(a)') ' Specifies the working directory and overwrites the default' + write(6,'(a)') ' "PathToGeomFile".' + write(6,'(a)') ' Make sure the file "material.config" exists in the working' + write(6,'(a)') ' directory.' + write(6,'(a)') ' For further configuration place "numerics.config"' + write(6,'(a)')' and "numerics.config" in that directory.' + write(6,'(/,a)')' --restart XX' + write(6,'(a)') ' Reads in total increment No. XX-1 and continues to' + write(6,'(a)') ' calculate total increment No. XX.' + write(6,'(a)') ' Appends to existing results file ' + write(6,'(a)') ' "NameOfGeom_NameOfLoadFile.spectralOut".' + write(6,'(a)') ' Works only if the restart information for total increment' + write(6,'(a)') ' No. XX-1 is available in the working directory.' + write(6,'(/,a)')' --regrid XX' + write(6,'(a)') ' Reads in total increment No. XX-1 and continues to' + write(6,'(a)') ' calculate total increment No. XX.' + write(6,'(a)') ' Attention: Overwrites existing results file ' + write(6,'(a)') ' "NameOfGeom_NameOfLoadFile.spectralOut".' + write(6,'(a)') ' Works only if the restart information for total increment' + write(6,'(a)') ' No. XX-1 is available in the working directory.' + write(6,'(/,a)')' -----------------------------------------------------------------------' + write(6,'(a)') ' Help:' + write(6,'(/,a)')' --help' + write(6,'(a,/)')' Prints this message and exits' + call quit(0_pInt) ! normal Termination + endif mainProcess2 + case ('-l', '--load', '--loadcase') + loadcaseArg = IIO_stringValue(commandLine,chunkPos,i+1_pInt) + case ('-g', '--geom', '--geometry') + geometryArg = IIO_stringValue(commandLine,chunkPos,i+1_pInt) + case ('-w', '-d', '--wd', '--directory', '--workingdir', '--workingdirectory') + workingDirArg = IIO_stringValue(commandLine,chunkPos,i+1_pInt) + case ('-r', '--rs', '--restart') + spectralRestartInc = IIO_IntValue(commandLine,chunkPos,i+1_pInt) + appendToOutFile = .true. + case ('--rg', '--regrid') + spectralRestartInc = IIO_IntValue(commandLine,chunkPos,i+1_pInt) + appendToOutFile = .false. + end select + enddo if (len(trim(loadcaseArg)) == 0 .or. len(trim(geometryArg)) == 0) then write(6,'(a)') ' Please specify geometry AND load case (-h for help)' From de614f5ce7619448023432096ca36de5af6fdb37 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 27 Jun 2016 17:50:43 +0200 Subject: [PATCH 16/37] declaring external only where needed --- code/spectral_damage.f90 | 55 ++++++++++------- code/spectral_mech_AL.f90 | 67 +++++++++++--------- code/spectral_mech_Basic.f90 | 95 +++++++++++++++++------------ code/spectral_mech_Polarisation.f90 | 67 +++++++++++--------- code/spectral_thermal.f90 | 50 +++++++++------ 5 files changed, 196 insertions(+), 138 deletions(-) diff --git a/code/spectral_damage.f90 b/code/spectral_damage.f90 index 27d513175..6260fe43a 100644 --- a/code/spectral_damage.f90 +++ b/code/spectral_damage.f90 @@ -42,7 +42,6 @@ module spectral_damage integer(pInt), private :: totalIter = 0_pInt !< total iteration in current increment real(pReal), dimension(3,3), private :: D_ref real(pReal), private :: mobility_ref - character(len=1024), private :: incInfo public :: & spectral_damage_init, & @@ -50,21 +49,7 @@ module spectral_damage spectral_damage_forward, & spectral_damage_destroy external :: & - VecDestroy, & - DMDestroy, & - DMDACreate3D, & - DMCreateGlobalVector, & - DMDASNESSetFunctionLocal, & PETScFinalize, & - SNESDestroy, & - SNESGetNumberFunctionEvals, & - SNESGetIterationNumber, & - SNESSolve, & - SNESSetDM, & - SNESGetConvergedReason, & - SNESSetConvergenceTest, & - SNESSetFromOptions, & - SNESCreate, & MPI_Abort, & MPI_Bcast, & MPI_Allreduce @@ -90,15 +75,30 @@ subroutine spectral_damage_init() damage_nonlocal_getMobility implicit none + integer(pInt), dimension(:), allocatable :: localK + integer(pInt) :: proc + integer(pInt) :: i, j, k, cell DM :: damage_grid Vec :: uBound, lBound PetscErrorCode :: ierr PetscObject :: dummy - integer(pInt), dimension(:), allocatable :: localK - integer(pInt) :: proc - integer(pInt) :: i, j, k, cell character(len=100) :: snes_type + external :: & + SNESCreate, & + SNESSetOptionsPrefix, & + DMDACreate3D, & + SNESSetDM, & + DMDAGetCorners, & + DMCreateGlobalVector, & + DMDASNESSetFunctionLocal, & + SNESSetFromOptions, & + SNESGetType, & + VecSet, & + DMGetGlobalVector, & + DMRestoreGlobalVector, & + SNESVISetVariableBounds + mainProcess: if (worldrank == 0_pInt) then write(6,'(/,a)') ' <<<+- spectral_damage init -+>>>' write(6,'(a15,a)') ' Current time: ',IO_timeStamp() @@ -194,12 +194,18 @@ type(tSolutionState) function spectral_damage_solution(guess,timeinc,timeinc_old integer(pInt) :: i, j, k, cell PetscInt ::position PetscReal :: minDamage, maxDamage, stagNorm, solnNorm - + !-------------------------------------------------------------------------------------------------- ! PETSc Data PetscErrorCode :: ierr SNESConvergedReason :: reason - + + external :: & + VecMin, & + VecMax, & + SNESSolve, & + SNESGetConvergedReason + spectral_damage_solution%converged =.false. !-------------------------------------------------------------------------------------------------- @@ -353,10 +359,13 @@ subroutine spectral_damage_forward(guess,timeinc,timeinc_old,loadCaseTime) timeinc, & loadCaseTime !< remaining time of current load case logical, intent(in) :: guess - PetscErrorCode :: ierr integer(pInt) :: i, j, k, cell DM :: dm_local PetscScalar, dimension(:,:,:), pointer :: x_scal + PetscErrorCode :: ierr + + external :: & + SNESGetDM if (cutBack) then damage_current = damage_lastInc @@ -400,6 +409,10 @@ subroutine spectral_damage_destroy() implicit none PetscErrorCode :: ierr + external :: & + VecDestroy, & + SNESDestroy + call VecDestroy(solution,ierr); CHKERRQ(ierr) call SNESDestroy(damage_snes,ierr); CHKERRQ(ierr) diff --git a/code/spectral_mech_AL.f90 b/code/spectral_mech_AL.f90 index b6a8c9353..0077ba2c3 100644 --- a/code/spectral_mech_AL.f90 +++ b/code/spectral_mech_AL.f90 @@ -22,7 +22,7 @@ module spectral_mech_AL DAMASK_spectral_solverAL_label = 'al' !-------------------------------------------------------------------------------------------------- -! derived types +! derived types type(tSolutionParams), private :: params real(pReal), private, dimension(3,3) :: mask_stress = 0.0_pReal @@ -31,7 +31,7 @@ module spectral_mech_AL DM, private :: da SNES, private :: snes Vec, private :: solution_vec - + !-------------------------------------------------------------------------------------------------- ! common pointwise data real(pReal), private, dimension(:,:,:,:,:), allocatable :: & @@ -72,21 +72,7 @@ module spectral_mech_AL AL_forward, & AL_destroy external :: & - VecDestroy, & - DMDestroy, & - DMDACreate3D, & - DMCreateGlobalVector, & - DMDASNESSetFunctionLocal, & PETScFinalize, & - SNESDestroy, & - SNESGetNumberFunctionEvals, & - SNESGetIterationNumber, & - SNESSolve, & - SNESSetDM, & - SNESGetConvergedReason, & - SNESSetConvergenceTest, & - SNESSetFromOptions, & - SNESCreate, & MPI_Abort, & MPI_Bcast, & MPI_Allreduce @@ -136,11 +122,22 @@ subroutine AL_init integer(pInt) :: proc character(len=1024) :: rankStr - if (worldrank == 0_pInt) then + external :: & + SNESCreate, & + SNESSetOptionsPrefix, & + DMDACreate3D, & + SNESSetDM, & + DMCreateGlobalVector, & + DMDASNESSetFunctionLocal, & + SNESGetConvergedReason, & + SNESSetConvergenceTest, & + SNESSetFromOptions + + mainProcess: if (worldrank == 0_pInt) then write(6,'(/,a)') ' <<<+- DAMASK_spectral_solverAL init -+>>>' write(6,'(a15,a)') ' Current time: ',IO_timeStamp() #include "compilation_info.f90" - endif + endif mainProcess !-------------------------------------------------------------------------------------------------- ! allocate global fields @@ -150,7 +147,7 @@ subroutine AL_init allocate (F_lambdaDot (3,3,grid(1),grid(2),grid3),source = 0.0_pReal) !-------------------------------------------------------------------------------------------------- -! PETSc Init +! initialize solver specific parts of PETSc call SNESCreate(PETSC_COMM_WORLD,snes,ierr); CHKERRQ(ierr) call SNESSetOptionsPrefix(snes,'mech_',ierr);CHKERRQ(ierr) allocate(localK(worldsize), source = 0); localK(worldrank+1) = grid3 @@ -185,10 +182,10 @@ subroutine AL_init 'reading values of increment ', restartInc - 1_pInt, ' from file' flush(6) write(rankStr,'(a1,i0)')'_',worldrank - call IO_read_realFile(777,'F'//trim(rankStr), trim(getSolverJobName()),size(F)) + call IO_read_realFile(777,'F'//trim(rankStr),trim(getSolverJobName()),size(F)) read (777,rec=1) F close (777) - call IO_read_realFile(777,'F_lastInc'//trim(rankStr), trim(getSolverJobName()),size(F_lastInc)) + call IO_read_realFile(777,'F_lastInc'//trim(rankStr),trim(getSolverJobName()),size(F_lastInc)) read (777,rec=1) F_lastInc close (777) call IO_read_realFile(777,'F_lambda'//trim(rankStr),trim(getSolverJobName()),size(F_lambda)) @@ -214,15 +211,14 @@ subroutine AL_init F_lambda_lastInc = F_lastInc endif restart - call Utilities_updateIPcoords(reshape(F,shape(F_lastInc))) call Utilities_constitutiveResponse(F_lastInc, reshape(F,shape(F_lastInc)), & 0.0_pReal,P,C_volAvg,C_minMaxAvg,temp33_Real,.false.,math_I3) nullify(F) nullify(F_lambda) call DMDAVecRestoreArrayF90(da,solution_vec,xx_psc,ierr); CHKERRQ(ierr) ! write data back to PETSc - - readRestart: if (restartInc > 1_pInt) then + + restartRead: if (restartInc > 1_pInt) then if (iand(debug_level(debug_spectral),debug_spectralRestart)/= 0 .and. worldrank == 0_pInt) & write(6,'(/,a,'//IO_intOut(restartInc-1_pInt)//',a)') & 'reading more values of increment', restartInc - 1_pInt, 'from file' @@ -236,7 +232,7 @@ subroutine AL_init call IO_read_realFile(777,'C_ref',trim(getSolverJobName()),size(C_minMaxAvg)) read (777,rec=1) C_minMaxAvg close (777) - endif readRestart + endif restartRead call Utilities_updateGamma(C_minMaxAvg,.True.) C_scale = C_minMaxAvg @@ -263,7 +259,7 @@ type(tSolutionState) function & use FEsolving, only: & restartWrite, & terminallyIll - + implicit none !-------------------------------------------------------------------------------------------------- @@ -286,6 +282,10 @@ type(tSolutionState) function & PetscErrorCode :: ierr SNESConvergedReason :: reason + external :: & + SNESSolve, & + SNESGetConvergedReason + incInfo = incInfoIn !-------------------------------------------------------------------------------------------------- @@ -298,7 +298,7 @@ type(tSolutionState) function & endif !-------------------------------------------------------------------------------------------------- -! set module wide availabe data +! set module wide availabe data mask_stress = P_BC%maskFloat params%P_BC = P_BC%values params%rotation_BC = rotation_BC @@ -387,6 +387,10 @@ subroutine AL_formResidual(in,x_scal,f_scal,dummy,ierr) integer(pInt) :: & i, j, k, e + external :: & + SNESGetNumberFunctionEvals, & + SNESGetIterationNumber + F => x_scal(1:3,1:3,1,& XG_RANGE,YG_RANGE,ZG_RANGE) F_lambda => x_scal(1:3,1:3,2,& @@ -414,7 +418,7 @@ subroutine AL_formResidual(in,x_scal,f_scal,dummy,ierr) write(6,'(/,a,/,3(3(f12.7,1x)/))',advance='no') ' deformation gradient aim (lab) =', & math_transpose33(math_rotate_backward33(F_aim,params%rotation_BC)) write(6,'(/,a,/,3(3(f12.7,1x)/))',advance='no') ' deformation gradient aim =', & - math_transpose33(F_aim) + math_transpose33(F_aim) flush(6) endif endif newIteration @@ -507,7 +511,7 @@ subroutine AL_converged(snes_local,PETScIter,xnorm,snorm,fnorm,reason,dummy,ierr fnorm SNESConvergedReason :: reason PetscObject :: dummy - PetscErrorCode ::ierr + PetscErrorCode :: ierr real(pReal) :: & curlTol, & divTol, & @@ -704,6 +708,11 @@ subroutine AL_destroy() implicit none PetscErrorCode :: ierr + external :: & + VecDestroy, & + SNESDestroy, & + DMDestroy + call VecDestroy(solution_vec,ierr); CHKERRQ(ierr) call SNESDestroy(snes,ierr); CHKERRQ(ierr) call DMDestroy(da,ierr); CHKERRQ(ierr) diff --git a/code/spectral_mech_Basic.f90 b/code/spectral_mech_Basic.f90 index 358a095d1..445fbdf10 100644 --- a/code/spectral_mech_Basic.f90 +++ b/code/spectral_mech_Basic.f90 @@ -48,7 +48,7 @@ module spectral_mech_basic C_volAvg = 0.0_pReal, & !< current volume average stiffness C_volAvgLastInc = 0.0_pReal, & !< previous volume average stiffness C_minMaxAvg = 0.0_pReal, & !< current (min+max)/2 stiffness - S = 0.0_pReal !< current compliance (filled up with zeros) + S = 0.0_pReal !< current compliance (filled up with zeros) real(pReal), private :: err_stress, err_div logical, private :: ForwardData integer(pInt), private :: & @@ -61,21 +61,7 @@ module spectral_mech_basic BasicPETSc_forward, & basicPETSc_destroy external :: & - VecDestroy, & - DMDestroy, & - DMDACreate3D, & - DMCreateGlobalVector, & - DMDASNESSetFunctionLocal, & PETScFinalize, & - SNESDestroy, & - SNESGetNumberFunctionEvals, & - SNESGetIterationNumber, & - SNESSolve, & - SNESSetDM, & - SNESGetConvergedReason, & - SNESSetConvergenceTest, & - SNESSetFromOptions, & - SNESCreate, & MPI_Abort, & MPI_Bcast, & MPI_Allreduce @@ -105,7 +91,7 @@ subroutine basicPETSc_init use spectral_utilities, only: & Utilities_constitutiveResponse, & Utilities_updateGamma, & - utilities_updateIPcoords, & + Utilities_updateIPcoords, & wgt use mesh, only: & grid, & @@ -115,15 +101,28 @@ subroutine basicPETSc_init implicit none real(pReal), dimension(3,3,grid(1),grid(2),grid3) :: P - PetscScalar, dimension(:,:,:,:), pointer :: F - PetscErrorCode :: ierr - PetscObject :: dummy real(pReal), dimension(3,3) :: & temp33_Real = 0.0_pReal + + PetscErrorCode :: ierr + PetscObject :: dummy + PetscScalar, pointer, dimension(:,:,:,:) :: F + integer(pInt), dimension(:), allocatable :: localK integer(pInt) :: proc character(len=1024) :: rankStr - + + external :: & + SNESCreate, & + SNESSetOptionsPrefix, & + DMDACreate3D, & + SNESSetDM, & + DMCreateGlobalVector, & + DMDASNESSetFunctionLocal, & + SNESGetConvergedReason, & + SNESSetConvergenceTest, & + SNESSetFromOptions + mainProcess: if (worldrank == 0_pInt) then write(6,'(/,a)') ' <<<+- DAMASK_spectral_solverBasicPETSc init -+>>>' write(6,'(a15,a)') ' Current time: ',IO_timeStamp() @@ -147,9 +146,9 @@ subroutine basicPETSc_init DM_BOUNDARY_NONE, DM_BOUNDARY_NONE, DM_BOUNDARY_NONE, & ! cut off stencil at boundary DMDA_STENCIL_BOX, & ! Moore (26) neighborhood around central point grid(1),grid(2),grid(3), & ! global grid - 1, 1, worldsize, & + 1 , 1, worldsize, & 9, 0, & ! #dof (F tensor), ghost boundary width (domain overlap) - grid (1),grid (2),localK, & ! local grid + grid(1),grid(2),localK, & ! local grid da,ierr) ! handle, error CHKERRQ(ierr) call SNESSetDM(snes,da,ierr); CHKERRQ(ierr) @@ -195,10 +194,9 @@ subroutine basicPETSc_init temp33_Real, & .false., & math_I3) - call DMDAVecRestoreArrayF90(da,solution_vec,F,ierr); CHKERRQ(ierr) ! write data back to PETSc - restartRead: if (restartInc > 1_pInt) then + restartRead: if (restartInc > 1_pInt) then if (iand(debug_level(debug_spectral),debug_spectralRestart)/= 0 .and. worldrank == 0_pInt) & write(6,'(/,a,'//IO_intOut(restartInc-1_pInt)//',a)') & 'reading more values of increment', restartInc - 1_pInt, 'from file' @@ -243,19 +241,24 @@ type(tSolutionState) function & timeinc, & !< increment in time for current solution timeinc_old, & !< increment in time of last increment loadCaseTime !< remaining time of current load case + logical, intent(in) :: & + guess type(tBoundaryCondition), intent(in) :: & P_BC, & F_BC character(len=*), intent(in) :: & incInfoIn real(pReal), dimension(3,3), intent(in) :: rotation_BC - logical, intent(in) :: & - guess !-------------------------------------------------------------------------------------------------- ! PETSc Data PetscErrorCode :: ierr SNESConvergedReason :: reason + + external :: & + SNESSolve, & + SNESGetConvergedReason + incInfo = incInfoIn !-------------------------------------------------------------------------------------------------- @@ -263,9 +266,9 @@ type(tSolutionState) function & S = Utilities_maskedCompliance(rotation_BC,P_BC%maskLogical,C_volAvg) if (update_gamma) call Utilities_updateGamma(C_minmaxAvg,restartWrite) - + !-------------------------------------------------------------------------------------------------- -! set module wide availabe data +! set module wide availabe data mask_stress = P_BC%maskFloat params%P_BC = P_BC%values params%rotation_BC = rotation_BC @@ -292,7 +295,7 @@ end function BasicPETSc_solution !-------------------------------------------------------------------------------------------------- -!> @brief forms the AL residual vector +!> @brief forms the basic residual vector !-------------------------------------------------------------------------------------------------- subroutine BasicPETSC_formResidual(in,x_scal,f_scal,dummy,ierr) use numerics, only: & @@ -312,10 +315,11 @@ subroutine BasicPETSC_formResidual(in,x_scal,f_scal,dummy,ierr) debug_spectral, & debug_spectralRotation use spectral_utilities, only: & + wgt, & tensorField_real, & utilities_FFTtensorForward, & - utilities_FFTtensorBackward, & utilities_fourierGammaConvolution, & + utilities_FFTtensorBackward, & Utilities_constitutiveResponse, & Utilities_divergenceRMS use IO, only: & @@ -338,11 +342,15 @@ subroutine BasicPETSC_formResidual(in,x_scal,f_scal,dummy,ierr) PetscObject :: dummy PetscErrorCode :: ierr + external :: & + SNESGetNumberFunctionEvals, & + SNESGetIterationNumber + call SNESGetNumberFunctionEvals(snes,nfuncs,ierr); CHKERRQ(ierr) call SNESGetIterationNumber(snes,PETScIter,ierr); CHKERRQ(ierr) if(nfuncs== 0 .and. PETScIter == 0) totalIter = -1_pInt ! new increment - newIteration: if (totalIter <= PETScIter) then + newIteration: if(totalIter <= PETScIter) then !-------------------------------------------------------------------------------------------------- ! report begin of new iteration totalIter = totalIter + 1_pInt @@ -351,7 +359,7 @@ subroutine BasicPETSC_formResidual(in,x_scal,f_scal,dummy,ierr) ' @ Iteration ', itmin, '≤',totalIter, '≤', itmax if (iand(debug_level(debug_spectral),debug_spectralRotation) /= 0) & write(6,'(/,a,/,3(3(f12.7,1x)/))',advance='no') ' deformation gradient aim (lab) =', & - math_transpose33(math_rotate_backward33(F_aim,params%rotation_BC)) + math_transpose33(math_rotate_backward33(F_aim,params%rotation_BC)) write(6,'(/,a,/,3(3(f12.7,1x)/))',advance='no') ' deformation gradient aim =', & math_transpose33(F_aim) flush(6) @@ -401,7 +409,7 @@ subroutine BasicPETSc_converged(snes_local,PETScIter,xnorm,snorm,fnorm,reason,du worldrank use FEsolving, only: & terminallyIll - + implicit none SNES :: snes_local PetscInt :: PETScIter @@ -415,10 +423,10 @@ subroutine BasicPETSc_converged(snes_local,PETScIter,xnorm,snorm,fnorm,reason,du real(pReal) :: & divTol, & stressTol - + divTol = max(maxval(abs(P_av))*err_div_tolRel,err_div_tolAbs) stressTol = max(maxval(abs(P_av))*err_stress_tolrel,err_stress_tolabs) - + converged: if ((totalIter >= itmin .and. & all([ err_div/divTol, & err_stress/stressTol ] < 1.0_pReal)) & @@ -451,21 +459,21 @@ subroutine BasicPETSc_forward(guess,timeinc,timeinc_old,loadCaseTime,F_BC,P_BC,r use math, only: & math_mul33x33 ,& math_rotate_backward33 + use numerics, only: & + worldrank use mesh, only: & grid, & grid3 use spectral_utilities, only: & Utilities_calculateRate, & Utilities_forwardField, & - utilities_updateIPcoords, & + Utilities_updateIPcoords, & tBoundaryCondition, & cutBack use IO, only: & IO_write_JobRealFile use FEsolving, only: & restartWrite - use numerics, only: & - worldrank implicit none real(pReal), intent(in) :: & @@ -478,8 +486,9 @@ subroutine BasicPETSc_forward(guess,timeinc,timeinc_old,loadCaseTime,F_BC,P_BC,r real(pReal), dimension(3,3), intent(in) :: rotation_BC logical, intent(in) :: & guess + PetscErrorCode :: ierr PetscScalar, pointer :: F(:,:,:,:) - PetscErrorCode :: ierr + character(len=1024) :: rankStr call DMDAVecGetArrayF90(da,solution_vec,F,ierr) @@ -508,7 +517,7 @@ subroutine BasicPETSc_forward(guess,timeinc,timeinc_old,loadCaseTime,F_BC,P_BC,r write (777,rec=1) C_volAvgLastInc close(777) endif - endif + endif call utilities_updateIPcoords(F) @@ -538,6 +547,7 @@ subroutine BasicPETSc_forward(guess,timeinc,timeinc_old,loadCaseTime,F_BC,P_BC,r timeinc_old,guess,F_lastInc,reshape(F,[3,3,grid(1),grid(2),grid3])) F_lastInc = reshape(F, [3,3,grid(1),grid(2),grid3]) endif + F_aim = F_aim + f_aimDot * timeinc !-------------------------------------------------------------------------------------------------- @@ -558,6 +568,11 @@ subroutine BasicPETSc_destroy() implicit none PetscErrorCode :: ierr + external :: & + VecDestroy, & + SNESDestroy, & + DMDestroy + call VecDestroy(solution_vec,ierr); CHKERRQ(ierr) call SNESDestroy(snes,ierr); CHKERRQ(ierr) call DMDestroy(da,ierr); CHKERRQ(ierr) diff --git a/code/spectral_mech_Polarisation.f90 b/code/spectral_mech_Polarisation.f90 index d7f1599e5..fc9fae7d7 100644 --- a/code/spectral_mech_Polarisation.f90 +++ b/code/spectral_mech_Polarisation.f90 @@ -22,7 +22,7 @@ module spectral_mech_Polarisation DAMASK_spectral_solverPolarisation_label = 'polarisation' !-------------------------------------------------------------------------------------------------- -! derived types +! derived types type(tSolutionParams), private :: params real(pReal), private, dimension(3,3) :: mask_stress = 0.0_pReal @@ -31,7 +31,7 @@ module spectral_mech_Polarisation DM, private :: da SNES, private :: snes Vec, private :: solution_vec - + !-------------------------------------------------------------------------------------------------- ! common pointwise data real(pReal), private, dimension(:,:,:,:,:), allocatable :: & @@ -57,7 +57,7 @@ module spectral_mech_Polarisation S = 0.0_pReal, & !< current compliance (filled up with zeros) C_scale = 0.0_pReal, & S_scale = 0.0_pReal - + real(pReal), private :: & err_BC, & !< deviation from stress BC err_curl, & !< RMS of curl of F @@ -72,21 +72,7 @@ module spectral_mech_Polarisation Polarisation_forward, & Polarisation_destroy external :: & - VecDestroy, & - DMDestroy, & - DMDACreate3D, & - DMCreateGlobalVector, & - DMDASNESSetFunctionLocal, & PETScFinalize, & - SNESDestroy, & - SNESGetNumberFunctionEvals, & - SNESGetIterationNumber, & - SNESSolve, & - SNESSetDM, & - SNESGetConvergedReason, & - SNESSetConvergenceTest, & - SNESSetFromOptions, & - SNESCreate, & MPI_Abort, & MPI_Bcast, & MPI_Allreduce @@ -136,11 +122,22 @@ subroutine Polarisation_init integer(pInt) :: proc character(len=1024) :: rankStr - if (worldrank == 0_pInt) then + external :: & + SNESCreate, & + SNESSetOptionsPrefix, & + DMDACreate3D, & + SNESSetDM, & + DMCreateGlobalVector, & + DMDASNESSetFunctionLocal, & + SNESGetConvergedReason, & + SNESSetConvergenceTest, & + SNESSetFromOptions + + mainProcess: if (worldrank == 0_pInt) then write(6,'(/,a)') ' <<<+- DAMASK_spectral_solverPolarisation init -+>>>' write(6,'(a15,a)') ' Current time: ',IO_timeStamp() #include "compilation_info.f90" - endif + endif mainProcess !-------------------------------------------------------------------------------------------------- ! allocate global fields @@ -150,7 +147,7 @@ subroutine Polarisation_init allocate (F_tauDot (3,3,grid(1),grid(2),grid3),source = 0.0_pReal) !-------------------------------------------------------------------------------------------------- -! PETSc Init +! initialize solver specific parts of PETSc call SNESCreate(PETSC_COMM_WORLD,snes,ierr); CHKERRQ(ierr) call SNESSetOptionsPrefix(snes,'mech_',ierr);CHKERRQ(ierr) allocate(localK(worldsize), source = 0); localK(worldrank+1) = grid3 @@ -163,7 +160,7 @@ subroutine Polarisation_init grid(1),grid(2),grid(3), & ! global grid 1 , 1, worldsize, & 18, 0, & ! #dof (F tensor), ghost boundary width (domain overlap) - grid (1),grid (2),localK, & ! local grid + grid(1),grid(2),localK, & ! local grid da,ierr) ! handle, error CHKERRQ(ierr) call SNESSetDM(snes,da,ierr); CHKERRQ(ierr) @@ -182,7 +179,7 @@ subroutine Polarisation_init restart: if (restartInc > 1_pInt) then if (iand(debug_level(debug_spectral),debug_spectralRestart)/= 0 .and. worldrank == 0_pInt) & write(6,'(/,a,'//IO_intOut(restartInc-1_pInt)//',a)') & - 'reading values of increment', restartInc - 1_pInt, 'from file' + 'reading values of increment ', restartInc - 1_pInt, ' from file' flush(6) write(rankStr,'(a1,i0)')'_',worldrank call IO_read_realFile(777,'F'//trim(rankStr),trim(getSolverJobName()),size(F)) @@ -221,7 +218,7 @@ subroutine Polarisation_init nullify(F_tau) call DMDAVecRestoreArrayF90(da,solution_vec,xx_psc,ierr); CHKERRQ(ierr) ! write data back to PETSc - readRestart: if (restartInc > 1_pInt) then + restartRead: if (restartInc > 1_pInt) then if (iand(debug_level(debug_spectral),debug_spectralRestart)/= 0 .and. worldrank == 0_pInt) & write(6,'(/,a,'//IO_intOut(restartInc-1_pInt)//',a)') & 'reading more values of increment', restartInc - 1_pInt, 'from file' @@ -235,7 +232,7 @@ subroutine Polarisation_init call IO_read_realFile(777,'C_ref',trim(getSolverJobName()),size(C_minMaxAvg)) read (777,rec=1) C_minMaxAvg close (777) - endif readRestart + endif restartRead call Utilities_updateGamma(C_minMaxAvg,.True.) C_scale = C_minMaxAvg @@ -262,7 +259,7 @@ type(tSolutionState) function & use FEsolving, only: & restartWrite, & terminallyIll - + implicit none !-------------------------------------------------------------------------------------------------- @@ -285,6 +282,10 @@ type(tSolutionState) function & PetscErrorCode :: ierr SNESConvergedReason :: reason + external :: & + SNESSolve, & + SNESGetConvergedReason + incInfo = incInfoIn !-------------------------------------------------------------------------------------------------- @@ -385,7 +386,11 @@ subroutine Polarisation_formResidual(in,x_scal,f_scal,dummy,ierr) PetscErrorCode :: ierr integer(pInt) :: & i, j, k, e - + + external :: & + SNESGetNumberFunctionEvals, & + SNESGetIterationNumber + F => x_scal(1:3,1:3,1,& XG_RANGE,YG_RANGE,ZG_RANGE) F_tau => x_scal(1:3,1:3,2,& @@ -505,7 +510,7 @@ subroutine Polarisation_converged(snes_local,PETScIter,xnorm,snorm,fnorm,reason, fnorm SNESConvergedReason :: reason PetscObject :: dummy - PetscErrorCode ::ierr + PetscErrorCode :: ierr real(pReal) :: & curlTol, & divTol, & @@ -631,7 +636,8 @@ subroutine Polarisation_forward(guess,timeinc,timeinc_old,loadCaseTime,F_BC,P_BC write (777,rec=1) C_volAvgLastInc close(777) endif - endif + endif + call utilities_updateIPcoords(F) if (cutBack) then @@ -701,6 +707,11 @@ subroutine Polarisation_destroy() implicit none PetscErrorCode :: ierr + external :: & + VecDestroy, & + SNESDestroy, & + DMDestroy + call VecDestroy(solution_vec,ierr); CHKERRQ(ierr) call SNESDestroy(snes,ierr); CHKERRQ(ierr) call DMDestroy(da,ierr); CHKERRQ(ierr) diff --git a/code/spectral_thermal.f90 b/code/spectral_thermal.f90 index 985bdf0c6..ab980e091 100644 --- a/code/spectral_thermal.f90 +++ b/code/spectral_thermal.f90 @@ -42,7 +42,6 @@ module spectral_thermal integer(pInt), private :: totalIter = 0_pInt !< total iteration in current increment real(pReal), dimension(3,3), private :: D_ref real(pReal), private :: mobility_ref - character(len=1024), private :: incInfo public :: & spectral_thermal_init, & @@ -50,21 +49,7 @@ module spectral_thermal spectral_thermal_forward, & spectral_thermal_destroy external :: & - VecDestroy, & - DMDestroy, & - DMDACreate3D, & - DMCreateGlobalVector, & - DMDASNESSetFunctionLocal, & PETScFinalize, & - SNESDestroy, & - SNESGetNumberFunctionEvals, & - SNESGetIterationNumber, & - SNESSolve, & - SNESSetDM, & - SNESGetConvergedReason, & - SNESSetConvergenceTest, & - SNESSetFromOptions, & - SNESCreate, & MPI_Abort, & MPI_Bcast, & MPI_Allreduce @@ -99,10 +84,20 @@ subroutine spectral_thermal_init integer(pInt) :: proc integer(pInt) :: i, j, k, cell DM :: thermal_grid - PetscScalar, pointer :: x_scal(:,:,:) + PetscScalar, dimension(:,:,:), pointer :: x_scal PetscErrorCode :: ierr PetscObject :: dummy + external :: & + SNESCreate, & + SNESSetOptionsPrefix, & + DMDACreate3D, & + SNESSetDM, & + DMDAGetCorners, & + DMCreateGlobalVector, & + DMDASNESSetFunctionLocal, & + SNESSetFromOptions + mainProcess: if (worldrank == 0_pInt) then write(6,'(/,a)') ' <<<+- spectral_thermal init -+>>>' write(6,'(a15,a)') ' Current time: ',IO_timeStamp() @@ -154,6 +149,8 @@ subroutine spectral_thermal_init x_scal(xstart:xend,ystart:yend,zstart:zend) = temperature_current call DMDAVecRestoreArrayF90(thermal_grid,solution,x_scal,ierr); CHKERRQ(ierr) +!-------------------------------------------------------------------------------------------------- +! thermal reference diffusion update cell = 0_pInt D_ref = 0.0_pReal mobility_ref = 0.0_pReal @@ -171,7 +168,7 @@ subroutine spectral_thermal_init end subroutine spectral_thermal_init !-------------------------------------------------------------------------------------------------- -!> @brief solution for the Basic PETSC scheme with internal iterations +!> @brief solution for the spectral thermal scheme with internal iterations !-------------------------------------------------------------------------------------------------- type(tSolutionState) function spectral_thermal_solution(guess,timeinc,timeinc_old,loadCaseTime) use numerics, only: & @@ -196,12 +193,18 @@ type(tSolutionState) function spectral_thermal_solution(guess,timeinc,timeinc_ol integer(pInt) :: i, j, k, cell PetscInt :: position PetscReal :: minTemperature, maxTemperature, stagNorm, solnNorm - + !-------------------------------------------------------------------------------------------------- ! PETSc Data PetscErrorCode :: ierr SNESConvergedReason :: reason - + + external :: & + VecMin, & + VecMax, & + SNESSolve, & + SNESGetConvergedReason + spectral_thermal_solution%converged =.false. !-------------------------------------------------------------------------------------------------- @@ -355,8 +358,11 @@ subroutine spectral_thermal_forward(guess,timeinc,timeinc_old,loadCaseTime) logical, intent(in) :: guess integer(pInt) :: i, j, k, cell DM :: dm_local - PetscScalar, pointer :: x_scal(:,:,:) + PetscScalar, dimension(:,:,:), pointer :: x_scal PetscErrorCode :: ierr + + external :: & + SNESGetDM if (cutBack) then temperature_current = temperature_lastInc @@ -405,6 +411,10 @@ subroutine spectral_thermal_destroy() implicit none PetscErrorCode :: ierr + external :: & + VecDestroy, & + SNESDestroy + call VecDestroy(solution,ierr); CHKERRQ(ierr) call SNESDestroy(thermal_snes,ierr); CHKERRQ(ierr) From 21cfe0941230605fae556673a4d1e6478ad0897a Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 27 Jun 2016 18:15:56 +0200 Subject: [PATCH 17/37] removed a bunch of unneded functions --- code/mesh.f90 | 332 +------------------------------------------------- 1 file changed, 3 insertions(+), 329 deletions(-) diff --git a/code/mesh.f90 b/code/mesh.f90 index ada304d9e..5b999cdb4 100644 --- a/code/mesh.f90 +++ b/code/mesh.f90 @@ -640,7 +640,7 @@ subroutine mesh_init(ip,el) if (myDebug) write(6,'(a)') ' Built shared elements'; flush(6) call mesh_build_ipNeighborhood #else - call mesh_spectral_build_ipNeighborhood(FILEUNIT) + call mesh_spectral_build_ipNeighborhood #endif if (myDebug) write(6,'(a)') ' Built IP neighborhood'; flush(6) @@ -1388,11 +1388,9 @@ end subroutine mesh_spectral_build_elements !> @brief build neighborhood relations for spectral !> @details assign globals: mesh_ipNeighborhood !-------------------------------------------------------------------------------------------------- -subroutine mesh_spectral_build_ipNeighborhood(fileUnit) +subroutine mesh_spectral_build_ipNeighborhood implicit none - integer(pInt), intent(in) :: & - fileUnit integer(pInt) :: & x,y,z, & e @@ -1529,332 +1527,8 @@ function mesh_nodesAroundCentres(gDim,Favg,centres) result(nodes) nodes = nodes/8.0_pReal end function mesh_nodesAroundCentres - - -!-------------------------------------------------------------------------------------------------- -!> @brief calculate coordinates in current configuration for given defgrad -! using integration in Fourier space -!-------------------------------------------------------------------------------------------------- -function mesh_deformedCoordsFFT(gDim,F,FavgIn,scalingIn) result(coords) - use IO, only: & - IO_error - use numerics, only: & - fftw_timelimit, & - fftw_planner_flag - use debug, only: & - debug_mesh, & - debug_level, & - debug_levelBasic - use math, only: & - PI, & - math_mul33x3 - - implicit none - real(pReal), intent(in), dimension(:,:,:,:,:) :: F - real(pReal), dimension(3,size(F,3),size(F,4),size(F,5)) :: coords - real(pReal), intent(in), dimension(3) :: gDim - real(pReal), intent(in), dimension(3,3), optional :: FavgIn - real(pReal), intent(in), dimension(3), optional :: scalingIn - -! allocatable arrays for fftw c routines - type(C_PTR) :: planForth, planBack - type(C_PTR) :: coords_fftw, defgrad_fftw - real(pReal), dimension(:,:,:,:,:), pointer :: F_real - complex(pReal), dimension(:,:,:,:,:), pointer :: F_fourier - real(pReal), dimension(:,:,:,:), pointer :: coords_real - complex(pReal), dimension(:,:,:,:), pointer :: coords_fourier - ! other variables - integer(pInt) :: i, j, k, m, res1Red - integer(pInt), dimension(3) :: k_s, iRes - real(pReal), dimension(3) :: scaling, step, offset_coords, integrator - real(pReal), dimension(3,3) :: Favg - integer(pInt), dimension(2:3,2) :: Nyquist ! highest frequencies to be removed (1 if even, 2 if odd) - - if (present(scalingIn)) then - where (scalingIn < 0.0_pReal) ! invalid values. in case of f2py -1 if not present - scaling = [1.0_pReal,1.0_pReal,1.0_pReal] - elsewhere - scaling = scalingIn - end where - else - scaling = 1.0_pReal - endif - - iRes = [size(F,3),size(F,4),size(F,5)] - integrator = gDim / 2.0_pReal / PI ! see notes where it is used - res1Red = iRes(1)/2_pInt + 1_pInt ! size of complex array in first dimension (c2r, r2c) - step = gDim/real(iRes, pReal) - Nyquist(2,1:2) = [iRes(2)/2_pInt + 1_pInt, iRes(2)/2_pInt + 1_pInt + mod(iRes(2),2_pInt)] - Nyquist(3,1:2) = [iRes(3)/2_pInt + 1_pInt, iRes(3)/2_pInt + 1_pInt + mod(iRes(3),2_pInt)] - -!-------------------------------------------------------------------------------------------------- -! report - if (iand(debug_level(debug_mesh),debug_levelBasic) /= 0_pInt) then - write(6,'(a)') ' Restore geometry using FFT-based integration' - write(6,'(a,3(i12 ))') ' grid a b c: ', iRes - write(6,'(a,3(es12.5))') ' size x y z: ', gDim - endif - -!-------------------------------------------------------------------------------------------------- -! sanity check - if (pReal /= C_DOUBLE .or. pInt /= C_INT) & - call IO_error(0_pInt,ext_msg='Fortran to C in mesh_deformedCoordsFFT') - -!-------------------------------------------------------------------------------------------------- -! allocation and FFTW initialization - defgrad_fftw = fftw_alloc_complex(int(res1Red *iRes(2)*iRes(3)*9_pInt,C_SIZE_T)) ! C_SIZE_T is of type integer(8) - coords_fftw = fftw_alloc_complex(int(res1Red *iRes(2)*iRes(3)*3_pInt,C_SIZE_T)) ! C_SIZE_T is of type integer(8) - call c_f_pointer(defgrad_fftw, F_real, & - [iRes(1)+2_pInt-mod(iRes(1),2_pInt),iRes(2),iRes(3),3_pInt,3_pInt]) - call c_f_pointer(defgrad_fftw, F_fourier, & - [res1Red, iRes(2),iRes(3),3_pInt,3_pInt]) - call c_f_pointer(coords_fftw, coords_real, & - [iRes(1)+2_pInt-mod(iRes(1),2_pInt),iRes(2),iRes(3),3_pInt]) - call c_f_pointer(coords_fftw, coords_fourier, & - [res1Red, iRes(2),iRes(3),3_pInt]) - - call fftw_set_timelimit(fftw_timelimit) - planForth = fftw_plan_many_dft_r2c(3_pInt,[iRes(3),iRes(2) ,iRes(1)],9_pInt,& ! dimensions , length in each dimension in reversed order - F_real,[iRes(3),iRes(2) ,iRes(1)+2_pInt-mod(iRes(1),2_pInt)],& ! input data , physical length in each dimension in reversed order - 1_pInt, iRes(3)*iRes(2)*(iRes(1)+2_pInt-mod(iRes(1),2_pInt)),& ! striding , product of physical lenght in the 3 dimensions - F_fourier,[iRes(3),iRes(2) ,res1Red],& - 1_pInt, iRes(3)*iRes(2)* res1Red,fftw_planner_flag) - - planBack = fftw_plan_many_dft_c2r(3_pInt,[iRes(3),iRes(2) ,iRes(1)],3_pInt,& - coords_fourier,[iRes(3),iRes(2) ,res1Red],& - 1_pInt, iRes(3)*iRes(2)* res1Red,& - coords_real,[iRes(3),iRes(2) ,iRes(1)+2_pInt-mod(iRes(1),2_pInt)],& - 1_pInt, iRes(3)*iRes(2)*(iRes(1)+2_pInt-mod(iRes(1),2_pInt)),& - fftw_planner_flag) - F_real(1:iRes(1),1:iRes(2),1:iRes(3),1:3,1:3) = & - reshape(F,[iRes(1),iRes(2),iRes(3),3,3], order = [4,5,1,2,3]) ! F_real is overwritten during plan creatio, is larger (padding) and has different order - -!-------------------------------------------------------------------------------------------------- -! FFT - call fftw_execute_dft_r2c(planForth, F_real, F_fourier) - -!-------------------------------------------------------------------------------------------------- -! if no average F is given, compute it in Fourier space - if (present(FavgIn)) then - if (all(FavgIn < 0.0_pReal)) then - Favg = real(F_fourier(1,1,1,1:3,1:3),pReal)/real(product(iRes),pReal) !the f2py way to tell it is not present - else - Favg = FavgIn - endif - else - Favg = real(F_fourier(1,1,1,1:3,1:3),pReal)/real(product(iRes),pReal) - endif - -!-------------------------------------------------------------------------------------------------- -! remove highest frequency in each direction, in third direction only if not 2D - - if(iRes(1)/=1_pInt) & ! do not delete the whole slice in case of 2D calculation - F_fourier (res1Red, 1:iRes(2), 1:iRes(3), 1:3,1:3) & - = cmplx(0.0_pReal,0.0_pReal,pReal) - if(iRes(2)/=1_pInt) & ! do not delete the whole slice in case of 2D calculation - F_fourier (1:res1Red,Nyquist(2,1):Nyquist(2,2),1:iRes(3), 1:3,1:3) & - = cmplx(0.0_pReal,0.0_pReal,pReal) - if(iRes(3)/=1_pInt) & ! do not delete the whole slice in case of 2D calculation - F_fourier (1:res1Red,1:iRes(2), Nyquist(3,1):Nyquist(3,2),1:3,1:3) & - = cmplx(0.0_pReal,0.0_pReal,pReal) - -!-------------------------------------------------------------------------------------------------- -! integration in Fourier space - coords_fourier = cmplx(0.0_pReal,0.0_pReal,pReal) - do k = 1_pInt, iRes(3) - k_s(3) = k-1_pInt - if(k > iRes(3)/2_pInt+1_pInt) k_s(3) = k_s(3)-iRes(3) - do j = 1_pInt, iRes(2) - k_s(2) = j-1_pInt - if(j > iRes(2)/2_pInt+1_pInt) k_s(2) = k_s(2)-iRes(2) - do i = 1_pInt, res1Red - k_s(1) = i-1_pInt - do m = 1_pInt,3_pInt - coords_fourier(i,j,k,m) = sum(F_fourier(i,j,k,m,1:3)*& - cmplx(0.0_pReal,real(k_s,pReal)*integrator,pReal)) - enddo - if (any(k_s /= 0_pInt)) coords_fourier(i,j,k,1:3) = & - coords_fourier(i,j,k,1:3) / cmplx(-sum(k_s*k_s),0.0_pReal,pReal) - enddo; enddo; enddo - -!-------------------------------------------------------------------------------------------------- -! iFFT and freeing memory - call fftw_execute_dft_c2r(planBack,coords_fourier,coords_real) - coords = reshape(coords_real(1:iRes(1),1:iRes(2),1:iRes(3),1:3), [3,iRes(1),iRes(2),iRes(3)], & - order = [2,3,4,1])/real(product(iRes),pReal) ! weight and change order - call fftw_destroy_plan(planForth) - call fftw_destroy_plan(planBack) - call fftw_free(defgrad_fftw) - call fftw_free(coords_fftw) - -!-------------------------------------------------------------------------------------------------- -! add average to scaled fluctuation and put (0,0,0) on (0,0,0) - offset_coords = math_mul33x3(F(1:3,1:3,1,1,1),step/2.0_pReal) - scaling*coords(1:3,1,1,1) - forall(k = 1_pInt:iRes(3), j = 1_pInt:iRes(2), i = 1_pInt:iRes(1)) & - coords(1:3,i,j,k) = scaling(1:3)*coords(1:3,i,j,k) & - + offset_coords & - + math_mul33x3(Favg,step*real([i,j,k]-1_pInt,pReal)) - -end function mesh_deformedCoordsFFT - - -!-------------------------------------------------------------------------------------------------- -!> @brief calculates the mismatch between volume of reconstructed (compatible) cube and -! determinant of defgrad at the FP -!-------------------------------------------------------------------------------------------------- -function mesh_volumeMismatch(gDim,F,nodes) result(vMismatch) - use IO, only: & - IO_error - use debug, only: & - debug_mesh, & - debug_level, & - debug_levelBasic - use math, only: & - math_det33, & - math_volTetrahedron - - implicit none - real(pReal), intent(in), dimension(:,:,:,:,:) :: & - F - real(pReal), dimension(size(F,3),size(F,4),size(F,5)) :: & - vMismatch - real(pReal), intent(in), dimension(:,:,:,:) :: & - nodes - real(pReal), dimension(3) :: & - gDim - integer(pInt), dimension(3) :: & - iRes - real(pReal), dimension(3,8) :: coords - integer(pInt) :: i,j,k - real(pReal) :: volInitial - - iRes = [size(F,3),size(F,4),size(F,5)] - volInitial = product(gDim)/real(product(iRes), pReal) - -!-------------------------------------------------------------------------------------------------- -! report and check - if (iand(debug_level(debug_mesh),debug_levelBasic) /= 0_pInt) then - write(6,'(a)') ' Calculating volume mismatch' - write(6,'(a,3(i12 ))') ' grid a b c: ', iRes - write(6,'(a,3(es12.5))') ' size x y z: ', gDim - endif - - if (any([iRes/=size(nodes,2)-1_pInt,iRes/=size(nodes,3)-1_pInt,iRes/=size(nodes,4)-1_pInt]))& - call IO_error(0_pInt,ext_msg='Arrays F and nodes in mesh_volumeMismatch') - -!-------------------------------------------------------------------------------------------------- -! calculate actual volume and volume resulting from deformation gradient - do k = 1_pInt,iRes(3) - do j = 1_pInt,iRes(2) - do i = 1_pInt,iRes(1) - coords(1:3,1) = nodes(1:3,i, j, k ) - coords(1:3,2) = nodes(1:3,i+1_pInt,j, k ) - coords(1:3,3) = nodes(1:3,i+1_pInt,j+1_pInt,k ) - coords(1:3,4) = nodes(1:3,i, j+1_pInt,k ) - coords(1:3,5) = nodes(1:3,i, j, k+1_pInt) - coords(1:3,6) = nodes(1:3,i+1_pInt,j, k+1_pInt) - coords(1:3,7) = nodes(1:3,i+1_pInt,j+1_pInt,k+1_pInt) - coords(1:3,8) = nodes(1:3,i, j+1_pInt,k+1_pInt) - vMismatch(i,j,k) = & - abs(math_volTetrahedron(coords(1:3,7),coords(1:3,1),coords(1:3,8),coords(1:3,4))) & - + abs(math_volTetrahedron(coords(1:3,7),coords(1:3,1),coords(1:3,8),coords(1:3,5))) & - + abs(math_volTetrahedron(coords(1:3,7),coords(1:3,1),coords(1:3,3),coords(1:3,4))) & - + abs(math_volTetrahedron(coords(1:3,7),coords(1:3,1),coords(1:3,3),coords(1:3,2))) & - + abs(math_volTetrahedron(coords(1:3,7),coords(1:3,5),coords(1:3,2),coords(1:3,6))) & - + abs(math_volTetrahedron(coords(1:3,7),coords(1:3,5),coords(1:3,2),coords(1:3,1))) - vMismatch(i,j,k) = vMismatch(i,j,k)/math_det33(F(1:3,1:3,i,j,k)) - enddo; enddo; enddo - vMismatch = vMismatch/volInitial - -end function mesh_volumeMismatch - - -!-------------------------------------------------------------------------------------------------- -!> @brief Routine to calculate the mismatch between the vectors from the central point to -! the corners of reconstructed (combatible) volume element and the vectors calculated by deforming -! the initial volume element with the current deformation gradient -!-------------------------------------------------------------------------------------------------- -function mesh_shapeMismatch(gDim,F,nodes,centres) result(sMismatch) - use IO, only: & - IO_error - use debug, only: & - debug_mesh, & - debug_level, & - debug_levelBasic - use math, only: & - math_mul33x3 - - implicit none - real(pReal), intent(in), dimension(:,:,:,:,:) :: & - F - real(pReal), dimension(size(F,3),size(F,4),size(F,5)) :: & - sMismatch - real(pReal), intent(in), dimension(:,:,:,:) :: & - nodes, & - centres - real(pReal), dimension(3) :: & - gDim, & - fRes - integer(pInt), dimension(3) :: & - iRes - real(pReal), dimension(3,8) :: coordsInitial - integer(pInt) i,j,k - - iRes = [size(F,3),size(F,4),size(F,5)] - fRes = real(iRes,pReal) - -!-------------------------------------------------------------------------------------------------- -! report and check - if (iand(debug_level(debug_mesh),debug_levelBasic) /= 0_pInt) then - write(6,'(a)') ' Calculating shape mismatch' - write(6,'(a,3(i12 ))') ' grid a b c: ', iRes - write(6,'(a,3(es12.5))') ' size x y z: ', gDim - endif - - if(any([iRes/=size(nodes,2)-1_pInt,iRes/=size(nodes,3)-1_pInt,iRes/=size(nodes,4)-1_pInt]) .or.& - any([iRes/=size(centres,2), iRes/=size(centres,3), iRes/=size(centres,4)]))& - call IO_error(0_pInt,ext_msg='Arrays F and nodes/centres in mesh_shapeMismatch') - -!-------------------------------------------------------------------------------------------------- -! initial positions - coordsInitial(1:3,1) = [-gDim(1)/fRes(1),-gDim(2)/fRes(2),-gDim(3)/fRes(3)] - coordsInitial(1:3,2) = [+gDim(1)/fRes(1),-gDim(2)/fRes(2),-gDim(3)/fRes(3)] - coordsInitial(1:3,3) = [+gDim(1)/fRes(1),+gDim(2)/fRes(2),-gDim(3)/fRes(3)] - coordsInitial(1:3,4) = [-gDim(1)/fRes(1),+gDim(2)/fRes(2),-gDim(3)/fRes(3)] - coordsInitial(1:3,5) = [-gDim(1)/fRes(1),-gDim(2)/fRes(2),+gDim(3)/fRes(3)] - coordsInitial(1:3,6) = [+gDim(1)/fRes(1),-gDim(2)/fRes(2),+gDim(3)/fRes(3)] - coordsInitial(1:3,7) = [+gDim(1)/fRes(1),+gDim(2)/fRes(2),+gDim(3)/fRes(3)] - coordsInitial(1:3,8) = [-gDim(1)/fRes(1),+gDim(2)/fRes(2),+gDim(3)/fRes(3)] - coordsInitial = coordsInitial/2.0_pReal - -!-------------------------------------------------------------------------------------------------- -! compare deformed original and deformed positions to actual positions - do k = 1_pInt,iRes(3) - do j = 1_pInt,iRes(2) - do i = 1_pInt,iRes(1) - sMismatch(i,j,k) = & - sqrt(sum((nodes(1:3,i, j, k ) - centres(1:3,i,j,k)& - - math_mul33x3(F(1:3,1:3,i,j,k), coordsInitial(1:3,1)))**2.0_pReal))& - + sqrt(sum((nodes(1:3,i+1_pInt,j, k ) - centres(1:3,i,j,k)& - - math_mul33x3(F(1:3,1:3,i,j,k), coordsInitial(1:3,2)))**2.0_pReal))& - + sqrt(sum((nodes(1:3,i+1_pInt,j+1_pInt,k ) - centres(1:3,i,j,k)& - - math_mul33x3(F(1:3,1:3,i,j,k), coordsInitial(1:3,3)))**2.0_pReal))& - + sqrt(sum((nodes(1:3,i, j+1_pInt,k ) - centres(1:3,i,j,k)& - - math_mul33x3(F(1:3,1:3,i,j,k), coordsInitial(1:3,4)))**2.0_pReal))& - + sqrt(sum((nodes(1:3,i, j, k+1_pInt) - centres(1:3,i,j,k)& - - math_mul33x3(F(1:3,1:3,i,j,k), coordsInitial(1:3,5)))**2.0_pReal))& - + sqrt(sum((nodes(1:3,i+1_pInt,j, k+1_pInt) - centres(1:3,i,j,k)& - - math_mul33x3(F(1:3,1:3,i,j,k), coordsInitial(1:3,6)))**2.0_pReal))& - + sqrt(sum((nodes(1:3,i+1_pInt,j+1_pInt,k+1_pInt) - centres(1:3,i,j,k)& - - math_mul33x3(F(1:3,1:3,i,j,k), coordsInitial(1:3,7)))**2.0_pReal))& - + sqrt(sum((nodes(1:3,i, j+1_pInt,k+1_pInt) - centres(1:3,i,j,k)& - - math_mul33x3(F(1:3,1:3,i,j,k), coordsInitial(1:3,8)))**2.0_pReal)) - enddo; enddo; enddo - -end function mesh_shapeMismatch #endif - - + #ifdef Marc4DAMASK !-------------------------------------------------------------------------------------------------- !> @brief Figures out table styles (Marc only) and stores to 'initialcondTableStyle' and From 8307a4a9abe5a8ab65b9d7ec3b8015fd1ad7844c Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 27 Jun 2016 19:38:12 +0200 Subject: [PATCH 18/37] trying to get the last things work without the core module --- processing/post/addCompatibilityMismatch.py | 165 +++++++++++++++----- 1 file changed, 122 insertions(+), 43 deletions(-) diff --git a/processing/post/addCompatibilityMismatch.py b/processing/post/addCompatibilityMismatch.py index 4e474a482..b082ca45b 100755 --- a/processing/post/addCompatibilityMismatch.py +++ b/processing/post/addCompatibilityMismatch.py @@ -3,12 +3,85 @@ import os,sys import numpy as np +import math +import scipy.ndimage from optparse import OptionParser import damask scriptName = os.path.splitext(os.path.basename(__file__))[0] scriptID = ' '.join([scriptName,damask.version]) +#-------------------------------------------------------------------------------------------------- +def cell2node(cellData,grid): + + nodeData = 0.0 + datalen = np.array(cellData.shape[3:]).prod() + + for i in xrange(datalen): + node = scipy.ndimage.convolve(cellData.reshape(tuple(grid)+(datalen,))[...,i], + np.ones((2,2,2))/8., # 2x2x2 neighborhood of cells + mode = 'wrap', + origin = -1, # offset to have cell origin as center + ) # now averaged at cell origins + node = np.append(node,node[np.newaxis,0,:,:,...],axis=0) # wrap along z + node = np.append(node,node[:,0,np.newaxis,:,...],axis=1) # wrap along y + node = np.append(node,node[:,:,0,np.newaxis,...],axis=2) # wrap along x + + nodeData = node[...,np.newaxis] if i==0 else np.concatenate((nodeData,node[...,np.newaxis]),axis=-1) + + return nodeData + +#-------------------------------------------------------------------------------------------------- +def displacementAvgFFT(F,grid,size,nodal=False,transformed=False): + """calculate average cell center (or nodal) displacement for deformation gradient field specified in each grid cell""" + if nodal: + x, y, z = np.meshgrid(np.linspace(0,size[0],1+grid[0]), + np.linspace(0,size[1],1+grid[1]), + np.linspace(0,size[2],1+grid[2]), + indexing = 'ij') + else: + x, y, z = np.meshgrid(np.linspace(0,size[0],grid[0],endpoint=False), + np.linspace(0,size[1],grid[1],endpoint=False), + np.linspace(0,size[2],grid[2],endpoint=False), + indexing = 'ij') + + origCoords = np.concatenate((z[:,:,:,None],y[:,:,:,None],x[:,:,:,None]),axis = 3) + + F_fourier = F if transformed else np.fft.rfftn(F,axes=(0,1,2)) # transform or use provided data + Favg = np.real(F_fourier[0,0,0,:,:])/grid.prod() # take zero freq for average + avgDisplacement = np.einsum('ml,ijkl->ijkm',Favg-np.eye(3),origCoords) # dX = Favg.X + + return avgDisplacement + +#-------------------------------------------------------------------------------------------------- +def displacementFluctFFT(F,grid,size,nodal=False,transformed=False): + """calculate cell center (or nodal) displacement for deformation gradient field specified in each grid cell""" + integrator = 0.5j * size / math.pi + + kk, kj, ki = np.meshgrid(np.where(np.arange(grid[2])>grid[2]//2,np.arange(grid[2])-grid[2],np.arange(grid[2])), + np.where(np.arange(grid[1])>grid[1]//2,np.arange(grid[1])-grid[1],np.arange(grid[1])), + np.arange(grid[0]//2+1), + indexing = 'ij') + k_s = np.concatenate((ki[:,:,:,None],kj[:,:,:,None],kk[:,:,:,None]),axis = 3) + k_sSquared = np.einsum('...l,...l',k_s,k_s) + k_sSquared[0,0,0] = 1.0 # ignore global average frequency + +#-------------------------------------------------------------------------------------------------- +# integration in Fourier space + + displacement_fourier = +np.einsum('ijkml,ijkl,l->ijkm', + F if transformed else np.fft.rfftn(F,axes=(0,1,2)), + k_s, + integrator, + ) / k_sSquared[...,np.newaxis] + +#-------------------------------------------------------------------------------------------------- +# backtransformation to real space + + displacement = np.fft.irfftn(displacement_fourier,grid,axes=(0,1,2)) + + return cell2node(displacement,grid) if nodal else displacement + def volTetrahedron(coords): """ @@ -188,66 +261,71 @@ for name in filenames: errors = [] remarks = [] - if table.label_dimension(options.pos) != 3: - errors.append('coordinates "{}" are not a vector.'.format(options.pos)) - else: colCoord = table.label_index(options.pos) - if table.label_dimension(options.defgrad) != 9: - errors.append('deformation gradient "{}" is not a tensor.'.format(options.defgrad)) - else: colF = table.label_index(options.defgrad) + errors.append('deformation gradient "{}" is not a 3x3 tensor.'.format(options.defgrad)) + + coordDim = table.label_dimension(options.pos) + if not 3 >= coordDim >= 1: + errors.append('coordinates "{}" need to have one, two, or three dimensions.'.format(options.pos)) + elif coordDim < 3: + remarks.append('appending {} dimension{} to coordinates "{}"...'.format(3-coordDim, + 's' if coordDim < 2 else '', + options.pos)) if remarks != []: damask.util.croak(remarks) if errors != []: damask.util.croak(errors) - table.close(dismiss = True) + table.close(dismiss=True) continue -# ------------------------------------------ assemble header -------------------------------------- - - table.info_append(scriptID + '\t' + ' '.join(sys.argv[1:])) - if options.shape: table.labels_append('shapeMismatch({})'.format(options.defgrad)) - if options.volume: table.labels_append('volMismatch({})'.format(options.defgrad)) - # --------------- figure out size and grid --------------------------------------------------------- - table.data_readArray() + table.data_readArray([options.defgrad,options.pos]) + table.data_rewind() - coords = [np.unique(table.data[:,colCoord+i]) for i in xrange(3)] + if len(table.data.shape) < 2: table.data.shape += (1,) # expand to 2D shape + if table.data[:,9:].shape[1] < 3: + table.data = np.hstack((table.data, + np.zeros((table.data.shape[0], + 3-table.data[:,9:].shape[1]),dtype='f'))) # fill coords up to 3D with zeros + + coords = [np.unique(table.data[:,9+i]) for i in xrange(3)] mincorner = np.array(map(min,coords)) maxcorner = np.array(map(max,coords)) grid = np.array(map(len,coords),'i') size = grid/np.maximum(np.ones(3,'d'), grid-1.0) * (maxcorner-mincorner) # size from edge to edge = dim * n/(n-1) - size = np.where(grid > 1, size, min(size[grid > 1]/grid[grid > 1])) # grid==1 spacing set to smallest among other ones + size = np.where(grid > 1, size, min(size[grid > 1]/grid[grid > 1])) # spacing for grid==1 set to smallest among other spacings N = grid.prod() - -# --------------- figure out columns to process --------------------------------------------------- - key = '1_'+options.defgrad - if table.label_index(key) == -1: - damask.util.croak('column "{}" not found...'.format(key)) + + if N != len(table.data): errors.append('data count {} does not match grid {}x{}x{}.'.format(N,*grid)) + if errors != []: + damask.util.croak(errors) + table.close(dismiss = True) continue - else: - column = table.label_index(key) # remember columns of requested data - -# ------------------------------------------ assemble header --------------------------------------- - if options.shape: table.labels_append(['shapeMismatch({})'.format(options.defgrad)]) - if options.volume: table.labels_append(['volMismatch({})'.format(options.defgrad)]) - table.head_write() - -# ------------------------------------------ read deformation gradient field ----------------------- - table.data_rewind() - F = np.zeros(N*9,'d').reshape([3,3]+list(grid)) - idx = 0 - while table.data_read(): - (x,y,z) = damask.util.gridLocation(idx,grid) # figure out (x,y,z) position from line count - idx += 1 - F[0:3,0:3,x,y,z] = np.array(map(float,table.data[column:column+9]),'d').reshape(3,3) - Favg = damask.core.math.tensorAvg(F) - centres = damask.core.mesh.deformedCoordsFFT(size,F,Favg,[1.0,1.0,1.0]) - nodes = damask.core.mesh.nodesAroundCentres(size,Favg,centres) - if options.shape: shapeMismatch = shapeMismatch( size,F,nodes,centres) - if options.volume: volumeMismatch = volumeMismatch(size,F,nodes) +# -----------------------------process data and assemble header ------------------------------------- + + F_fourier = np.fft.rfftn(table.data[:,:9].reshape(grid[2],grid[1],grid[0],3,3),axes=(0,1,2)) # perform transform only once... + nodes = np.vstack(np.meshgrid(np.linspace(0.0,size[0],grid[0]+1), + np.linspace(0.0,size[1],grid[1]+1), + np.linspace(0.0,size[2],grid[2]+1))).reshape([3,17,17,17]).T\ + + displacementFluctFFT(F_fourier,grid,size,True,transformed=True)\ + + displacementAvgFFT (F_fourier,grid,size,True,transformed=True) + if options.shape: + table.labels_append(['shapeMismatch({})'.format(options.defgrad)]) + centres = np.vstack(np.meshgrid(np.linspace(size[0]/grid[0]*.5,size[0]-size[0]/grid[0]*.5,grid[0]), + np.linspace(size[1]/grid[1]*.5,size[1]-size[1]/grid[1]*.5,grid[1]), + np.linspace(size[2]/grid[2]*.5,size[2]-size[2]/grid[2]*.5,grid[2]))).reshape([3,16,16,16]).T\ + + displacementFluctFFT(F_fourier,grid,size,False,transformed=True)\ + + displacementAvgFFT (F_fourier,grid,size,False,transformed=True) + + if options.volume: + table.labels_append(['volMismatch({})'.format(options.defgrad)]) + + table.head_write() + if options.shape: shapeMismatch = shapeMismatch( size,table.data[:,:9].reshape(grid[2],grid[1],grid[0],3,3),nodes,centres) + if options.volume: volumeMismatch = volumeMismatch(size,table.data[:,:9].reshape(grid[2],grid[1],grid[0],3,3),nodes) # ------------------------------------------ process data ------------------------------------------ table.data_rewind() @@ -262,4 +340,5 @@ for name in filenames: # ------------------------------------------ output finalization ----------------------------------- - table.close() # close ASCII tables + table.close() + From bfc02af5150427c576ea129c5d6d5fc5bfdaf7b2 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 27 Jun 2016 23:15:41 +0200 Subject: [PATCH 19/37] closing stdout for mpi rannk >0 (enables to get rid of many if statements and allows for central debug handling like writing to file per process) --- code/spectral_interface.f90 | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/code/spectral_interface.f90 b/code/spectral_interface.f90 index b10399cbd..e506bff7a 100644 --- a/code/spectral_interface.f90 +++ b/code/spectral_interface.f90 @@ -89,10 +89,10 @@ subroutine DAMASK_interface_init(loadCaseParameterIn,geometryParameterIn) #endif call PetscInitialize(PETSC_NULL_CHARACTER,ierr) ! according to PETSc manual, that should be the first line in the code CHKERRQ(ierr) ! this is a macro definition, it is case sensitive - open(6, encoding='UTF-8') call MPI_Comm_rank(PETSC_COMM_WORLD,worldrank,ierr);CHKERRQ(ierr) #endif mainProcess: if (worldrank == 0) then + open(6, encoding='UTF-8') call date_and_time(values = dateAndTime) write(6,'(/,a)') ' <<<+- DAMASK_spectral -+>>>' write(6,'(/,a)') ' Version: '//DAMASKVERSION @@ -104,6 +104,8 @@ subroutine DAMASK_interface_init(loadCaseParameterIn,geometryParameterIn) dateAndTime(7) write(6,'(/,a)') ' <<<+- DAMASK_interface init -+>>>' #include "compilation_info.f90" + else mainProcess + close(6) endif mainProcess if ( present(loadcaseParameterIn) .and. present(geometryParameterIn)) then ! both mandatory parameters given in function call geometryArg = geometryParameterIn From af2404f0f8accd01c211c407a12f905f825df9fc Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 27 Jun 2016 23:27:30 +0200 Subject: [PATCH 20/37] no access out of bounds anymore (but incorrect results) --- processing/post/addCompatibilityMismatch.py | 34 ++++++++++----------- 1 file changed, 17 insertions(+), 17 deletions(-) diff --git a/processing/post/addCompatibilityMismatch.py b/processing/post/addCompatibilityMismatch.py index b082ca45b..77e215acc 100755 --- a/processing/post/addCompatibilityMismatch.py +++ b/processing/post/addCompatibilityMismatch.py @@ -145,14 +145,14 @@ def volumeMismatch(size,F,nodes): for k in xrange(grid[2]): for j in xrange(grid[1]): for i in xrange(grid[0]): - coords[0,0:3] = nodes[0:3,i, j, k ] - coords[1,0:3] = nodes[0:3,i+1,j, k ] - coords[2,0:3] = nodes[0:3,i+1,j+1,k ] - coords[3,0:3] = nodes[0:3,i, j+1,k ] - coords[4,0:3] = nodes[0:3,i, j, k+1] - coords[5,0:3] = nodes[0:3,i+1,j, k+1] - coords[6,0:3] = nodes[0:3,i+1,j+1,k+1] - coords[7,0:3] = nodes[0:3,i, j+1,k+1] + coords[0,0:3] = nodes[i, j, k ,0:3] + coords[1,0:3] = nodes[i+1,j, k ,0:3] + coords[2,0:3] = nodes[i+1,j+1,k ,0:3] + coords[3,0:3] = nodes[i, j+1,k ,0:3] + coords[4,0:3] = nodes[i, j, k+1,0:3] + coords[5,0:3] = nodes[i+1,j, k+1,0:3] + coords[6,0:3] = nodes[i+1,j+1,k+1,0:3] + coords[7,0:3] = nodes[i, j+1,k+1,0:3] vMismatch[i,j,k] = \ abs(volTetrahedron([coords[6,0:3],coords[0,0:3],coords[7,0:3],coords[3,0:3]])) \ + abs(volTetrahedron([coords[6,0:3],coords[0,0:3],coords[7,0:3],coords[4,0:3]])) \ @@ -160,7 +160,7 @@ def volumeMismatch(size,F,nodes): + abs(volTetrahedron([coords[6,0:3],coords[0,0:3],coords[2,0:3],coords[1,0:3]])) \ + abs(volTetrahedron([coords[6,0:3],coords[4,0:3],coords[1,0:3],coords[5,0:3]])) \ + abs(volTetrahedron([coords[6,0:3],coords[4,0:3],coords[1,0:3],coords[0,0:3]])) - vMismatch[i,j,k] = vMismatch[i,j,k]/np.linalg.det(F[0:3,0:3,i,j,k]) + vMismatch[i,j,k] = vMismatch[i,j,k]/np.linalg.det(F[i,j,k,0:3,0:3]) return vMismatch/volInitial @@ -195,14 +195,14 @@ def shapeMismatch(size,F,nodes,centres): for j in xrange(grid[1]): for i in xrange(grid[0]): sMismatch[i,j,k] = \ - + np.linalg.norm(nodes[0:3,i, j, k] - centres[0:3,i,j,k] - np.dot(F[:,:,i,j,k], coordsInitial[0,0:3]))\ - + np.linalg.norm(nodes[0:3,i+1,j, k] - centres[0:3,i,j,k] - np.dot(F[:,:,i,j,k], coordsInitial[1,0:3]))\ - + np.linalg.norm(nodes[0:3,i+1,j+1,k ] - centres[0:3,i,j,k] - np.dot(F[:,:,i,j,k], coordsInitial[2,0:3]))\ - + np.linalg.norm(nodes[0:3,i, j+1,k ] - centres[0:3,i,j,k] - np.dot(F[:,:,i,j,k], coordsInitial[3,0:3]))\ - + np.linalg.norm(nodes[0:3,i, j, k+1] - centres[0:3,i,j,k] - np.dot(F[:,:,i,j,k], coordsInitial[4,0:3]))\ - + np.linalg.norm(nodes[0:3,i+1,j, k+1] - centres[0:3,i,j,k] - np.dot(F[:,:,i,j,k], coordsInitial[5,0:3]))\ - + np.linalg.norm(nodes[0:3,i+1,j+1,k+1] - centres[0:3,i,j,k] - np.dot(F[:,:,i,j,k], coordsInitial[6,0:3]))\ - + np.linalg.norm(nodes[0:3,i, j+1,k+1] - centres[0:3,i,j,k] - np.dot(F[:,:,i,j,k], coordsInitial[7,0:3])) + + np.linalg.norm(nodes[i, j, k,0:3] - centres[i,j,k,0:3] - np.dot(F[i,j,k,:,:], coordsInitial[0,0:3]))\ + + np.linalg.norm(nodes[i+1,j, k,0:3] - centres[i,j,k,0:3] - np.dot(F[i,j,k,:,:], coordsInitial[1,0:3]))\ + + np.linalg.norm(nodes[i+1,j+1,k ,0:3] - centres[i,j,k,0:3] - np.dot(F[i,j,k,:,:], coordsInitial[2,0:3]))\ + + np.linalg.norm(nodes[i, j+1,k ,0:3] - centres[i,j,k,0:3] - np.dot(F[i,j,k,:,:], coordsInitial[3,0:3]))\ + + np.linalg.norm(nodes[i, j, k+1,0:3] - centres[i,j,k,0:3] - np.dot(F[i,j,k,:,:], coordsInitial[4,0:3]))\ + + np.linalg.norm(nodes[i+1,j, k+1,0:3] - centres[i,j,k,0:3] - np.dot(F[i,j,k,:,:], coordsInitial[5,0:3]))\ + + np.linalg.norm(nodes[i+1,j+1,k+1,0:3] - centres[i,j,k,0:3] - np.dot(F[i,j,k,:,:], coordsInitial[6,0:3]))\ + + np.linalg.norm(nodes[i, j+1,k+1,0:3] - centres[i,j,k,0:3] - np.dot(F[i,j,k,:,:], coordsInitial[7,0:3])) return sMismatch From b759a79f9aad988a7849aa51896d4fdedf85584a Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 27 Jun 2016 23:36:09 +0200 Subject: [PATCH 21/37] small check to see if 6 is really STDOUT (no idea what to do if not) --- code/spectral_interface.f90 | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/code/spectral_interface.f90 b/code/spectral_interface.f90 index e506bff7a..d5be8ad75 100644 --- a/code/spectral_interface.f90 +++ b/code/spectral_interface.f90 @@ -92,6 +92,10 @@ subroutine DAMASK_interface_init(loadCaseParameterIn,geometryParameterIn) call MPI_Comm_rank(PETSC_COMM_WORLD,worldrank,ierr);CHKERRQ(ierr) #endif mainProcess: if (worldrank == 0) then + if (output_unit /= 6) then + write(output_unit,'(a)') 'STDOUT != 6' + call quit(1_pInt) + endif open(6, encoding='UTF-8') call date_and_time(values = dateAndTime) write(6,'(/,a)') ' <<<+- DAMASK_spectral -+>>>' From 9ea6d3afd7a874e7a00d03eb7149b75cdb7975de Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 29 Jun 2016 10:58:15 +0200 Subject: [PATCH 22/37] simplified FFT statements --- processing/post/addCurl.py | 6 +++--- processing/post/addDivergence.py | 6 +++--- processing/post/addGradient.py | 6 +++--- 3 files changed, 9 insertions(+), 9 deletions(-) diff --git a/processing/post/addCurl.py b/processing/post/addCurl.py index 3afec570a..79bb5f848 100755 --- a/processing/post/addCurl.py +++ b/processing/post/addCurl.py @@ -18,7 +18,7 @@ def curlFFT(geomdim,field): if n == 3: dataType = 'vector' elif n == 9: dataType = 'tensor' - field_fourier = np.fft.fftpack.rfftn(field,axes=(0,1,2),s=shapeFFT) + field_fourier = np.fft.rfftn(field,axes=(0,1,2),s=shapeFFT) curl_fourier = np.empty(field_fourier.shape,'c16') # differentiation in Fourier space @@ -56,7 +56,7 @@ def curlFFT(geomdim,field): curl_fourier[i,j,k,2] = ( field_fourier[i,j,k,1]*xi[0]\ -field_fourier[i,j,k,0]*xi[1]) *TWOPIIMG - return np.fft.fftpack.irfftn(curl_fourier,axes=(0,1,2),s=shapeFFT).reshape([N,n]) + return np.fft.irfftn(curl_fourier,axes=(0,1,2),s=shapeFFT).reshape([N,n]) # -------------------------------------------------------------------- @@ -158,7 +158,7 @@ for name in filenames: # we need to reverse order here, because x is fastest,ie rightmost, but leftmost in our x,y,z notation stack.append(curlFFT(size[::-1], table.data[:,data['column'][i]:data['column'][i]+data['dim']]. - reshape([grid[2],grid[1],grid[0]]+data['shape']))) + reshape(grid[::-1].tolist()+data['shape']))) # ------------------------------------------ output result ----------------------------------------- diff --git a/processing/post/addDivergence.py b/processing/post/addDivergence.py index 56ccb1b07..4c24eea3c 100755 --- a/processing/post/addDivergence.py +++ b/processing/post/addDivergence.py @@ -15,7 +15,7 @@ def divFFT(geomdim,field): N = grid.prod() # field size n = np.array(np.shape(field)[3:]).prod() # data size - field_fourier = np.fft.fftpack.rfftn(field,axes=(0,1,2),s=shapeFFT) + field_fourier = np.fft.rfftn(field,axes=(0,1,2),s=shapeFFT) div_fourier = np.empty(field_fourier.shape[0:len(np.shape(field))-1],'c16') # size depents on whether tensor or vector # differentiation in Fourier space @@ -42,7 +42,7 @@ def divFFT(geomdim,field): elif n == 3: # vector, 3 -> 1 div_fourier[i,j,k] = sum(field_fourier[i,j,k,0:3]*xi) *TWOPIIMG - return np.fft.fftpack.irfftn(div_fourier,axes=(0,1,2),s=shapeFFT).reshape([N,n/3]) + return np.fft.irfftn(div_fourier,axes=(0,1,2),s=shapeFFT).reshape([N,n/3]) # -------------------------------------------------------------------- @@ -145,7 +145,7 @@ for name in filenames: # we need to reverse order here, because x is fastest,ie rightmost, but leftmost in our x,y,z notation stack.append(divFFT(size[::-1], table.data[:,data['column'][i]:data['column'][i]+data['dim']]. - reshape([grid[2],grid[1],grid[0]]+data['shape']))) + reshape(grid[::-1].tolist()+data['shape']))) # ------------------------------------------ output result ----------------------------------------- diff --git a/processing/post/addGradient.py b/processing/post/addGradient.py index 66018a890..5ded3fc90 100755 --- a/processing/post/addGradient.py +++ b/processing/post/addGradient.py @@ -18,7 +18,7 @@ def gradFFT(geomdim,field): if n == 3: dataType = 'vector' elif n == 1: dataType = 'scalar' - field_fourier = np.fft.fftpack.rfftn(field,axes=(0,1,2),s=shapeFFT) + field_fourier = np.fft.rfftn(field,axes=(0,1,2),s=shapeFFT) grad_fourier = np.empty(field_fourier.shape+(3,),'c16') # differentiation in Fourier space @@ -46,7 +46,7 @@ def gradFFT(geomdim,field): grad_fourier[i,j,k,1,:] = field_fourier[i,j,k,1]*xi *TWOPIIMG # tensor field from vector data grad_fourier[i,j,k,2,:] = field_fourier[i,j,k,2]*xi *TWOPIIMG - return np.fft.fftpack.irfftn(grad_fourier,axes=(0,1,2),s=shapeFFT).reshape([N,3*n]) + return np.fft.irfftn(grad_fourier,axes=(0,1,2),s=shapeFFT).reshape([N,3*n]) # -------------------------------------------------------------------- @@ -148,7 +148,7 @@ for name in filenames: # we need to reverse order here, because x is fastest,ie rightmost, but leftmost in our x,y,z notation stack.append(gradFFT(size[::-1], table.data[:,data['column'][i]:data['column'][i]+data['dim']]. - reshape([grid[2],grid[1],grid[0]]+data['shape']))) + reshape(grid[::-1].tolist()+data['shape']))) # ------------------------------------------ output result ----------------------------------------- From a64388355af11cdee30741b755776e29ff69556b Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 29 Jun 2016 11:02:49 +0200 Subject: [PATCH 23/37] simplified --- processing/post/addCalculation.py | 32 +++++++++++++++---------------- 1 file changed, 15 insertions(+), 17 deletions(-) diff --git a/processing/post/addCalculation.py b/processing/post/addCalculation.py index 8bfc7692f..8b5dd1d33 100755 --- a/processing/post/addCalculation.py +++ b/processing/post/addCalculation.py @@ -74,32 +74,30 @@ for name in filenames: } # ------------------------------------------ Evaluate condition --------------------------------------- - if options.condition: + if options.condition is not None: interpolator = [] - condition = options.condition # copy per file, since might be altered inline + condition = options.condition # copy per file, since might be altered inline breaker = False - for position,operand in enumerate(set(re.findall(r'#(([s]#)?(.+?))#',condition))): # find three groups + for position,operand in enumerate(set(re.findall(r'#(([s]#)?(.+?))#',condition))): # find three groups condition = condition.replace('#'+operand[0]+'#', { '': '{%i}'%position, 's#':'"{%i}"'%position}[operand[1]]) - if operand[2] in specials: # special label + if operand[2] in specials: # special label interpolator += ['specials["%s"]'%operand[2]] else: try: interpolator += ['%s(table.data[%i])'%({ '':'float', 's#':'str'}[operand[1]], - table.label_index(operand[2]))] # ccould be generalized to indexrange as array lookup + table.label_index(operand[2]))] # could be generalized to indexrange as array lookup except: damask.util.croak('column "{}" not found.'.format(operand[2])) breaker = True - if breaker: continue # found mistake in condition evaluation --> next file + if breaker: continue # found mistake in condition evaluation --> next file evaluator_condition = "'" + condition + "'.format(" + ','.join(interpolator) + ")" - else: condition = '' - # ------------------------------------------ build formulae ---------------------------------------- evaluator = {} @@ -165,19 +163,19 @@ for name in filenames: for label in output.labels(): oldIndices = table.label_indexrange(label) - Nold = max(1,len(oldIndices)) # Nold could be zero for new columns + Nold = max(1,len(oldIndices)) # Nold could be zero for new columns Nnew = len(output.label_indexrange(label)) output.data_append(eval(evaluator[label]) if label in options.labels and - (condition == '' or eval(eval(evaluator_condition))) - else np.tile([table.data[i] for i in oldIndices] - if label in tabLabels - else np.nan, - np.ceil(float(Nnew)/Nold))[:Nnew]) # spread formula result into given number of columns + (options.condition is None or eval(eval(evaluator_condition))) + else np.tile([table.data[i] for i in oldIndices] + if label in tabLabels + else np.nan, + np.ceil(float(Nnew)/Nold))[:Nnew]) # spread formula result into given number of columns - outputAlive = output.data_write() # output processed line + outputAlive = output.data_write() # output processed line # ------------------------------------------ output finalization ----------------------------------- - table.input_close() # close ASCII tables - output.close() # close ASCII tables + table.input_close() # close ASCII tables + output.close() # close ASCII tables From 9bf8b6221c39607ecde95bba35c37ab944e0f9cc Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 29 Jun 2016 12:11:07 +0200 Subject: [PATCH 24/37] fixed fluct displacement --- processing/post/addDisplacement.py | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/processing/post/addDisplacement.py b/processing/post/addDisplacement.py index bcc02f869..fe78fb02b 100755 --- a/processing/post/addDisplacement.py +++ b/processing/post/addDisplacement.py @@ -18,7 +18,7 @@ def cell2node(cellData,grid): datalen = np.array(cellData.shape[3:]).prod() for i in xrange(datalen): - node = scipy.ndimage.convolve(cellData.reshape(tuple(grid)+(datalen,))[...,i], + node = scipy.ndimage.convolve(cellData.reshape(tuple(grid[::-1])+(datalen,))[...,i], np.ones((2,2,2))/8., # 2x2x2 neighborhood of cells mode = 'wrap', origin = -1, # offset to have cell origin as center @@ -69,7 +69,7 @@ def displacementFluctFFT(F,grid,size,nodal=False,transformed=False): #-------------------------------------------------------------------------------------------------- # integration in Fourier space - displacement_fourier = +np.einsum('ijkml,ijkl,l->ijkm', + displacement_fourier = -np.einsum('ijkml,ijkl,l->ijkm', F if transformed else np.fft.rfftn(F,axes=(0,1,2)), k_s, integrator, @@ -78,7 +78,7 @@ def displacementFluctFFT(F,grid,size,nodal=False,transformed=False): #-------------------------------------------------------------------------------------------------- # backtransformation to real space - displacement = np.fft.irfftn(displacement_fourier,grid,axes=(0,1,2)) + displacement = np.fft.irfftn(displacement_fourier,grid[::-1],axes=(0,1,2)) return cell2node(displacement,grid) if nodal else displacement @@ -187,7 +187,7 @@ for name in filenames: F_fourier = np.fft.rfftn(table.data[:,:9].reshape(grid[2],grid[1],grid[0],3,3),axes=(0,1,2)) # perform transform only once... displacement = displacementFluctFFT(F_fourier,grid,size,options.nodal,transformed=True) - avgDisplacement = displacementAvgFFT (F_fourier,grid,size,options.nodal,transformed=True) + #avgDisplacement = displacementAvgFFT (F_fourier,grid,size,options.nodal,transformed=True) # ------------------------------------------ assemble header --------------------------------------- @@ -196,24 +196,24 @@ for name in filenames: table.labels_clear() table.info_append(scriptID + '\t' + ' '.join(sys.argv[1:])) + #['{}_avg({}).{}' .format(i+1,options.defgrad,options.pos) for i in xrange(3)] + table.labels_append((['{}_pos' .format(i+1) for i in xrange(3)] if options.nodal else []) + - ['{}_avg({}).{}' .format(i+1,options.defgrad,options.pos) for i in xrange(3)] + ['{}_fluct({}).{}'.format(i+1,options.defgrad,options.pos) for i in xrange(3)] ) table.head_write() # ------------------------------------------ output data ------------------------------------------- - zrange = np.linspace(0,size[2],1+grid[2]) if options.nodal else xrange(grid[2]) - yrange = np.linspace(0,size[1],1+grid[1]) if options.nodal else xrange(grid[1]) - xrange = np.linspace(0,size[0],1+grid[0]) if options.nodal else xrange(grid[0]) + Zrange = np.linspace(0,size[2],1+grid[2]) if options.nodal else xrange(grid[2]) + Yrange = np.linspace(0,size[1],1+grid[1]) if options.nodal else xrange(grid[1]) + Xrange = np.linspace(0,size[0],1+grid[0]) if options.nodal else xrange(grid[0]) - for i,z in enumerate(zrange): - for j,y in enumerate(yrange): - for k,x in enumerate(xrange): + for i,z in enumerate(Zrange): + for j,y in enumerate(Yrange): + for k,x in enumerate(Xrange): if options.nodal: table.data_clear() else: table.data_read() table.data_append([x,y,z] if options.nodal else []) - table.data_append(list(avgDisplacement[i,j,k,:])) + #table.data_append(list(avgDisplacement[i,j,k,:])) table.data_append(list( displacement[i,j,k,:])) table.data_write() From 2c8427eb2ac0458aaf7ce03b3134ed8a8b658759 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 29 Jun 2016 12:35:50 +0200 Subject: [PATCH 25/37] seems to work now --- processing/post/addDisplacement.py | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/processing/post/addDisplacement.py b/processing/post/addDisplacement.py index fe78fb02b..a1a476185 100755 --- a/processing/post/addDisplacement.py +++ b/processing/post/addDisplacement.py @@ -35,14 +35,14 @@ def cell2node(cellData,grid): def displacementAvgFFT(F,grid,size,nodal=False,transformed=False): """calculate average cell center (or nodal) displacement for deformation gradient field specified in each grid cell""" if nodal: - x, y, z = np.meshgrid(np.linspace(0,size[0],1+grid[0]), + x, y, z = np.meshgrid(np.linspace(0,size[2],1+grid[2]), np.linspace(0,size[1],1+grid[1]), - np.linspace(0,size[2],1+grid[2]), + np.linspace(0,size[0],1+grid[0]), indexing = 'ij') else: - x, y, z = np.meshgrid(np.linspace(0,size[0],grid[0],endpoint=False), + x, y, z = np.meshgrid(np.linspace(0,size[2],grid[2],endpoint=False), np.linspace(0,size[1],grid[1],endpoint=False), - np.linspace(0,size[2],grid[2],endpoint=False), + np.linspace(0,size[0],grid[0],endpoint=False), indexing = 'ij') origCoords = np.concatenate((z[:,:,:,None],y[:,:,:,None],x[:,:,:,None]),axis = 3) @@ -186,8 +186,8 @@ for name in filenames: F_fourier = np.fft.rfftn(table.data[:,:9].reshape(grid[2],grid[1],grid[0],3,3),axes=(0,1,2)) # perform transform only once... - displacement = displacementFluctFFT(F_fourier,grid,size,options.nodal,transformed=True) - #avgDisplacement = displacementAvgFFT (F_fourier,grid,size,options.nodal,transformed=True) + fluctDisplacement = displacementFluctFFT(F_fourier,grid,size,options.nodal,transformed=True) + avgDisplacement = displacementAvgFFT (F_fourier,grid,size,options.nodal,transformed=True) # ------------------------------------------ assemble header --------------------------------------- @@ -196,8 +196,8 @@ for name in filenames: table.labels_clear() table.info_append(scriptID + '\t' + ' '.join(sys.argv[1:])) - #['{}_avg({}).{}' .format(i+1,options.defgrad,options.pos) for i in xrange(3)] + table.labels_append((['{}_pos' .format(i+1) for i in xrange(3)] if options.nodal else []) + + ['{}_avg({}).{}' .format(i+1,options.defgrad,options.pos) for i in xrange(3)] + ['{}_fluct({}).{}'.format(i+1,options.defgrad,options.pos) for i in xrange(3)] ) table.head_write() @@ -213,8 +213,8 @@ for name in filenames: if options.nodal: table.data_clear() else: table.data_read() table.data_append([x,y,z] if options.nodal else []) - #table.data_append(list(avgDisplacement[i,j,k,:])) - table.data_append(list( displacement[i,j,k,:])) + table.data_append(list( avgDisplacement[i,j,k,:])) + table.data_append(list(fluctDisplacement[i,j,k,:])) table.data_write() # ------------------------------------------ output finalization ----------------------------------- From 39c9c18ade4c54376df092a9fd6880254c4694dd Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 29 Jun 2016 13:40:54 +0200 Subject: [PATCH 26/37] disabling stdout for MPIrank>0 now working for ifort: --- code/prec.f90 | 29 ++++++++--------------------- code/spectral_interface.f90 | 31 ++++++++++++++++++------------- 2 files changed, 26 insertions(+), 34 deletions(-) diff --git a/code/prec.f90 b/code/prec.f90 index 594201bee..bf9ac7124 100644 --- a/code/prec.f90 +++ b/code/prec.f90 @@ -130,30 +130,17 @@ subroutine prec_init iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) implicit none - integer(pInt) :: worldrank = 0_pInt -#ifdef PETSc -#include - PetscErrorCode :: ierr -#endif external :: & - quit, & - MPI_Comm_rank, & - MPI_Abort - -#ifdef PETSc - call MPI_Comm_rank(PETSC_COMM_WORLD,worldrank,ierr);CHKERRQ(ierr) -#endif + quit - mainProcess: if (worldrank == 0) then - write(6,'(/,a)') ' <<<+- prec init -+>>>' + write(6,'(/,a)') ' <<<+- prec init -+>>>' #include "compilation_info.f90" - write(6,'(a,i3)') ' Bytes for pReal: ',pReal - write(6,'(a,i3)') ' Bytes for pInt: ',pInt - write(6,'(a,i3)') ' Bytes for pLongInt: ',pLongInt - write(6,'(a,e10.3)') ' NaN: ', DAMASK_NaN - write(6,'(a,l3)') ' NaN != NaN: ',DAMASK_NaN /= DAMASK_NaN - write(6,'(a,l3,/)') ' NaN check passed ',prec_isNAN(DAMASK_NaN) - endif mainProcess + write(6,'(a,i3)') ' Bytes for pReal: ',pReal + write(6,'(a,i3)') ' Bytes for pInt: ',pInt + write(6,'(a,i3)') ' Bytes for pLongInt: ',pLongInt + write(6,'(a,e10.3)') ' NaN: ', DAMASK_NaN + write(6,'(a,l3)') ' NaN != NaN: ',DAMASK_NaN /= DAMASK_NaN + write(6,'(a,l3,/)') ' NaN check passed ',prec_isNAN(DAMASK_NaN) if ((.not. prec_isNaN(DAMASK_NaN)) .or. (DAMASK_NaN == DAMASK_NaN)) call quit(9000) realloc_lhs_test = [1_pInt,2_pInt] diff --git a/code/spectral_interface.f90 b/code/spectral_interface.f90 index d5be8ad75..c774a2202 100644 --- a/code/spectral_interface.f90 +++ b/code/spectral_interface.f90 @@ -77,6 +77,8 @@ subroutine DAMASK_interface_init(loadCaseParameterIn,geometryParameterIn) MPI_Init_Thread, & MPI_abort + open(6, encoding='UTF-8') ! for special characters in output + !-------------------------------------------------------------------------------------------------- ! PETSc Init #ifdef PETSc @@ -91,26 +93,29 @@ subroutine DAMASK_interface_init(loadCaseParameterIn,geometryParameterIn) CHKERRQ(ierr) ! this is a macro definition, it is case sensitive call MPI_Comm_rank(PETSC_COMM_WORLD,worldrank,ierr);CHKERRQ(ierr) #endif + mainProcess: if (worldrank == 0) then if (output_unit /= 6) then write(output_unit,'(a)') 'STDOUT != 6' call quit(1_pInt) endif - open(6, encoding='UTF-8') - call date_and_time(values = dateAndTime) - write(6,'(/,a)') ' <<<+- DAMASK_spectral -+>>>' - write(6,'(/,a)') ' Version: '//DAMASKVERSION - write(6,'(a,2(i2.2,a),i4.4)') ' Date: ',dateAndTime(3),'/',& - dateAndTime(2),'/',& - dateAndTime(1) - write(6,'(a,2(i2.2,a),i2.2)') ' Time: ',dateAndTime(5),':',& - dateAndTime(6),':',& - dateAndTime(7) - write(6,'(/,a)') ' <<<+- DAMASK_interface init -+>>>' -#include "compilation_info.f90" else mainProcess - close(6) + close(6) ! disable output for non-master processes (open 6 to rank specific file for debug) + open(6,file='/dev/null',status='replace') ! close(6) alone will leave some temp files in cwd endif mainProcess + + call date_and_time(values = dateAndTime) + write(6,'(/,a)') ' <<<+- DAMASK_spectral -+>>>' + write(6,'(/,a)') ' Version: '//DAMASKVERSION + write(6,'(a,2(i2.2,a),i4.4)') ' Date: ',dateAndTime(3),'/',& + dateAndTime(2),'/',& + dateAndTime(1) + write(6,'(a,2(i2.2,a),i2.2)') ' Time: ',dateAndTime(5),':',& + dateAndTime(6),':',& + dateAndTime(7) + write(6,'(/,a)') ' <<<+- DAMASK_interface init -+>>>' +#include "compilation_info.f90" + if ( present(loadcaseParameterIn) .and. present(geometryParameterIn)) then ! both mandatory parameters given in function call geometryArg = geometryParameterIn loadcaseArg = loadcaseParameterIn From e1802cb31dfa7abc3fab860f83374f3903fac783 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 29 Jun 2016 16:28:15 +0200 Subject: [PATCH 27/37] removed some more core module functionality --- code/core_quit.f90 | 12 ------------ code/spectral_interface.f90 | 19 +------------------ 2 files changed, 1 insertion(+), 30 deletions(-) delete mode 100644 code/core_quit.f90 diff --git a/code/core_quit.f90 b/code/core_quit.f90 deleted file mode 100644 index 3a730c82d..000000000 --- a/code/core_quit.f90 +++ /dev/null @@ -1,12 +0,0 @@ -!******************************************************************** -! quit subroutine to satisfy IO_error for core module -! -!******************************************************************** -subroutine quit(stop_id) - use prec, only: & - pInt - - implicit none - integer(pInt), intent(in) :: stop_id - -end subroutine diff --git a/code/spectral_interface.f90 b/code/spectral_interface.f90 index 862b8e849..ce4f6b6d7 100644 --- a/code/spectral_interface.f90 +++ b/code/spectral_interface.f90 @@ -13,10 +13,8 @@ module DAMASK_interface pInt implicit none private -#ifdef PETSc #include -#endif - logical, public, protected :: appendToOutFile = .false. !< Append to existing spectralOut file (in case of restart, not in case of regridding) + logical, public, protected :: appendToOutFile = .false. !< Append to existing spectralOut file (in case of restart) integer(pInt), public, protected :: spectralRestartInc = 1_pInt !< Increment at which calculation starts character(len=1024), public, protected :: & geometryFile = '', & !< parameter given for geometry file @@ -64,9 +62,7 @@ subroutine DAMASK_interface_init() chunkPos integer, dimension(8) :: & dateAndTime ! type default integer -#ifdef PETSc PetscErrorCode :: ierr -#endif external :: & quit,& MPI_Comm_rank,& @@ -76,7 +72,6 @@ subroutine DAMASK_interface_init() !-------------------------------------------------------------------------------------------------- ! PETSc Init -#ifdef PETSc #ifdef _OPENMP call MPI_Init_Thread(MPI_THREAD_FUNNELED,threadLevel,ierr);CHKERRQ(ierr) ! in case of OpenMP, don't rely on PETScInitialize doing MPI init if (threadLevel>>' @@ -119,7 +113,6 @@ subroutine DAMASK_interface_init() write(6,'(a)') ' --load (-l, --loadcase)' write(6,'(a)') ' --workingdir (-w, --wd, --workingdirectory, -d, --directory)' write(6,'(a)') ' --restart (-r, --rs)' - write(6,'(a)') ' --regrid (--rg)' write(6,'(a)') ' --help (-h)' write(6,'(/,a)')' -----------------------------------------------------------------------' write(6,'(a)') ' Mandatory arguments:' @@ -151,13 +144,6 @@ subroutine DAMASK_interface_init() write(6,'(a)') ' "NameOfGeom_NameOfLoadFile.spectralOut".' write(6,'(a)') ' Works only if the restart information for total increment' write(6,'(a)') ' No. XX-1 is available in the working directory.' - write(6,'(/,a)')' --regrid XX' - write(6,'(a)') ' Reads in total increment No. XX-1 and continues to' - write(6,'(a)') ' calculate total increment No. XX.' - write(6,'(a)') ' Attention: Overwrites existing results file ' - write(6,'(a)') ' "NameOfGeom_NameOfLoadFile.spectralOut".' - write(6,'(a)') ' Works only if the restart information for total increment' - write(6,'(a)') ' No. XX-1 is available in the working directory.' write(6,'(/,a)')' -----------------------------------------------------------------------' write(6,'(a)') ' Help:' write(6,'(/,a)')' --help' @@ -173,9 +159,6 @@ subroutine DAMASK_interface_init() case ('-r', '--rs', '--restart') spectralRestartInc = IIO_IntValue(commandLine,chunkPos,i+1_pInt) appendToOutFile = .true. - case ('--rg', '--regrid') - spectralRestartInc = IIO_IntValue(commandLine,chunkPos,i+1_pInt) - appendToOutFile = .false. end select enddo From 3a0a7dea9aa6e29ae2873ce345c204498be8b8c0 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 29 Jun 2016 16:35:49 +0200 Subject: [PATCH 28/37] not needed for disabled output MPI rank>0 --- code/IO.f90 | 19 +---- code/numerics.f90 | 202 ++++++++++++++++++++++------------------------ 2 files changed, 98 insertions(+), 123 deletions(-) diff --git a/code/IO.f90 b/code/IO.f90 index 2a13ce3d8..91b3e2a7f 100644 --- a/code/IO.f90 +++ b/code/IO.f90 @@ -80,25 +80,10 @@ subroutine IO_init use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) implicit none - integer(pInt) :: worldrank = 0_pInt -#ifdef PETSc -#include - PetscErrorCode :: ierr -#endif - external :: & - MPI_Comm_rank, & - MPI_Abort -#ifdef PETSc - call MPI_Comm_rank(PETSC_COMM_WORLD,worldrank,ierr);CHKERRQ(ierr) -#endif - - mainProcess: if (worldrank == 0) then - write(6,'(/,a)') ' <<<+- IO init -+>>>' - write(6,'(a15,a)') ' Current time: ',IO_timeStamp() + write(6,'(/,a)') ' <<<+- IO init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() #include "compilation_info.f90" - endif mainProcess - end subroutine IO_init diff --git a/code/numerics.f90 b/code/numerics.f90 index 365b078ec..9b3449e95 100644 --- a/code/numerics.f90 +++ b/code/numerics.f90 @@ -236,11 +236,9 @@ subroutine numerics_init call MPI_Comm_rank(PETSC_COMM_WORLD,worldrank,ierr);CHKERRQ(ierr) call MPI_Comm_size(PETSC_COMM_WORLD,worldsize,ierr);CHKERRQ(ierr) #endif - mainProcess: if (worldrank == 0) then - write(6,'(/,a)') ' <<<+- numerics init -+>>>' - write(6,'(a15,a)') ' Current time: ',IO_timeStamp() + write(6,'(/,a)') ' <<<+- numerics init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() #include "compilation_info.f90" - endif mainProcess !$ call GET_ENVIRONMENT_VARIABLE(NAME='DAMASK_NUM_THREADS',VALUE=DAMASK_NumThreadsString,STATUS=gotDAMASK_NUM_THREADS) ! get environment variable DAMASK_NUM_THREADS... !$ if(gotDAMASK_NUM_THREADS /= 0) then ! could not get number of threads, set it to 1 @@ -489,14 +487,8 @@ subroutine numerics_init close(FILEUNIT) else fileExists -#ifdef FEM - if (worldrank == 0) then -#endif write(6,'(a,/)') ' using standard values' flush(6) -#ifdef FEM - endif -#endif endif fileExists #ifdef Spectral @@ -519,128 +511,126 @@ subroutine numerics_init !-------------------------------------------------------------------------------------------------- ! writing parameters to output - mainProcess3: if (worldrank == 0) then - write(6,'(a24,1x,es8.1)') ' relevantStrain: ',relevantStrain - write(6,'(a24,1x,es8.1)') ' defgradTolerance: ',defgradTolerance - write(6,'(a24,1x,i8)') ' iJacoStiffness: ',iJacoStiffness - write(6,'(a24,1x,i8)') ' iJacoLpresiduum: ',iJacoLpresiduum - write(6,'(a24,1x,es8.1)') ' pert_Fg: ',pert_Fg - write(6,'(a24,1x,i8)') ' pert_method: ',pert_method - write(6,'(a24,1x,i8)') ' nCryst: ',nCryst - write(6,'(a24,1x,es8.1)') ' subStepMinCryst: ',subStepMinCryst - write(6,'(a24,1x,es8.1)') ' subStepSizeCryst: ',subStepSizeCryst - write(6,'(a24,1x,es8.1)') ' stepIncreaseCryst: ',stepIncreaseCryst - write(6,'(a24,1x,i8)') ' nState: ',nState - write(6,'(a24,1x,i8)') ' nStress: ',nStress - write(6,'(a24,1x,es8.1)') ' rTol_crystalliteState: ',rTol_crystalliteState - write(6,'(a24,1x,es8.1)') ' rTol_crystalliteStress: ',rTol_crystalliteStress - write(6,'(a24,1x,es8.1)') ' aTol_crystalliteStress: ',aTol_crystalliteStress - write(6,'(a24,2(1x,i8))') ' integrator: ',numerics_integrator - write(6,'(a24,1x,L8)') ' timeSyncing: ',numerics_timeSyncing - write(6,'(a24,1x,L8)') ' analytic Jacobian: ',analyticJaco - write(6,'(a24,1x,L8)') ' use ping pong scheme: ',usepingpong - write(6,'(a24,1x,es8.1,/)')' unitlength: ',numerics_unitlength + write(6,'(a24,1x,es8.1)') ' relevantStrain: ',relevantStrain + write(6,'(a24,1x,es8.1)') ' defgradTolerance: ',defgradTolerance + write(6,'(a24,1x,i8)') ' iJacoStiffness: ',iJacoStiffness + write(6,'(a24,1x,i8)') ' iJacoLpresiduum: ',iJacoLpresiduum + write(6,'(a24,1x,es8.1)') ' pert_Fg: ',pert_Fg + write(6,'(a24,1x,i8)') ' pert_method: ',pert_method + write(6,'(a24,1x,i8)') ' nCryst: ',nCryst + write(6,'(a24,1x,es8.1)') ' subStepMinCryst: ',subStepMinCryst + write(6,'(a24,1x,es8.1)') ' subStepSizeCryst: ',subStepSizeCryst + write(6,'(a24,1x,es8.1)') ' stepIncreaseCryst: ',stepIncreaseCryst + write(6,'(a24,1x,i8)') ' nState: ',nState + write(6,'(a24,1x,i8)') ' nStress: ',nStress + write(6,'(a24,1x,es8.1)') ' rTol_crystalliteState: ',rTol_crystalliteState + write(6,'(a24,1x,es8.1)') ' rTol_crystalliteStress: ',rTol_crystalliteStress + write(6,'(a24,1x,es8.1)') ' aTol_crystalliteStress: ',aTol_crystalliteStress + write(6,'(a24,2(1x,i8))') ' integrator: ',numerics_integrator + write(6,'(a24,1x,L8)') ' timeSyncing: ',numerics_timeSyncing + write(6,'(a24,1x,L8)') ' analytic Jacobian: ',analyticJaco + write(6,'(a24,1x,L8)') ' use ping pong scheme: ',usepingpong + write(6,'(a24,1x,es8.1,/)')' unitlength: ',numerics_unitlength - write(6,'(a24,1x,i8)') ' nHomog: ',nHomog - write(6,'(a24,1x,es8.1)') ' subStepMinHomog: ',subStepMinHomog - write(6,'(a24,1x,es8.1)') ' subStepSizeHomog: ',subStepSizeHomog - write(6,'(a24,1x,es8.1)') ' stepIncreaseHomog: ',stepIncreaseHomog - write(6,'(a24,1x,i8,/)') ' nMPstate: ',nMPstate + write(6,'(a24,1x,i8)') ' nHomog: ',nHomog + write(6,'(a24,1x,es8.1)') ' subStepMinHomog: ',subStepMinHomog + write(6,'(a24,1x,es8.1)') ' subStepSizeHomog: ',subStepSizeHomog + write(6,'(a24,1x,es8.1)') ' stepIncreaseHomog: ',stepIncreaseHomog + write(6,'(a24,1x,i8,/)') ' nMPstate: ',nMPstate !-------------------------------------------------------------------------------------------------- ! RGC parameters - write(6,'(a24,1x,es8.1)') ' aTol_RGC: ',absTol_RGC - write(6,'(a24,1x,es8.1)') ' rTol_RGC: ',relTol_RGC - write(6,'(a24,1x,es8.1)') ' aMax_RGC: ',absMax_RGC - write(6,'(a24,1x,es8.1)') ' rMax_RGC: ',relMax_RGC - write(6,'(a24,1x,es8.1)') ' perturbPenalty_RGC: ',pPert_RGC - write(6,'(a24,1x,es8.1)') ' relevantMismatch_RGC: ',xSmoo_RGC - write(6,'(a24,1x,es8.1)') ' viscosityrate_RGC: ',viscPower_RGC - write(6,'(a24,1x,es8.1)') ' viscositymodulus_RGC: ',viscModus_RGC - write(6,'(a24,1x,es8.1)') ' maxrelaxation_RGC: ',maxdRelax_RGC - write(6,'(a24,1x,es8.1)') ' maxVolDiscrepancy_RGC: ',maxVolDiscr_RGC - write(6,'(a24,1x,es8.1)') ' volDiscrepancyMod_RGC: ',volDiscrMod_RGC - write(6,'(a24,1x,es8.1,/)') ' discrepancyPower_RGC: ',volDiscrPow_RGC + write(6,'(a24,1x,es8.1)') ' aTol_RGC: ',absTol_RGC + write(6,'(a24,1x,es8.1)') ' rTol_RGC: ',relTol_RGC + write(6,'(a24,1x,es8.1)') ' aMax_RGC: ',absMax_RGC + write(6,'(a24,1x,es8.1)') ' rMax_RGC: ',relMax_RGC + write(6,'(a24,1x,es8.1)') ' perturbPenalty_RGC: ',pPert_RGC + write(6,'(a24,1x,es8.1)') ' relevantMismatch_RGC: ',xSmoo_RGC + write(6,'(a24,1x,es8.1)') ' viscosityrate_RGC: ',viscPower_RGC + write(6,'(a24,1x,es8.1)') ' viscositymodulus_RGC: ',viscModus_RGC + write(6,'(a24,1x,es8.1)') ' maxrelaxation_RGC: ',maxdRelax_RGC + write(6,'(a24,1x,es8.1)') ' maxVolDiscrepancy_RGC: ',maxVolDiscr_RGC + write(6,'(a24,1x,es8.1)') ' volDiscrepancyMod_RGC: ',volDiscrMod_RGC + write(6,'(a24,1x,es8.1,/)') ' discrepancyPower_RGC: ',volDiscrPow_RGC !-------------------------------------------------------------------------------------------------- ! Random seeding parameter - write(6,'(a24,1x,i16,/)') ' fixed_seed: ',fixedSeed - if (fixedSeed <= 0_pInt) & - write(6,'(a,/)') ' No fixed Seed: Random is random!' + write(6,'(a24,1x,i16,/)') ' fixed_seed: ',fixedSeed + if (fixedSeed <= 0_pInt) & + write(6,'(a,/)') ' No fixed Seed: Random is random!' !-------------------------------------------------------------------------------------------------- ! gradient parameter - write(6,'(a24,1x,es8.1)') ' charLength: ',charLength - write(6,'(a24,1x,es8.1)') ' residualStiffness: ',residualStiffness + write(6,'(a24,1x,es8.1)') ' charLength: ',charLength + write(6,'(a24,1x,es8.1)') ' residualStiffness: ',residualStiffness !-------------------------------------------------------------------------------------------------- ! openMP parameter - !$ write(6,'(a24,1x,i8,/)') ' number of threads: ',DAMASK_NumThreadsInt + !$ write(6,'(a24,1x,i8,/)') ' number of threads: ',DAMASK_NumThreadsInt !-------------------------------------------------------------------------------------------------- ! field parameters - write(6,'(a24,1x,i8)') ' itmax: ',itmax - write(6,'(a24,1x,i8)') ' itmin: ',itmin - write(6,'(a24,1x,i8)') ' maxCutBack: ',maxCutBack - write(6,'(a24,1x,i8)') ' maxStaggeredIter: ',stagItMax - write(6,'(a24,1x,i8)') ' vacancyPolyOrder: ',vacancyPolyOrder - write(6,'(a24,1x,i8)') ' hydrogenPolyOrder: ',hydrogenPolyOrder - write(6,'(a24,1x,es8.1)') ' err_struct_tolAbs: ',err_struct_tolAbs - write(6,'(a24,1x,es8.1)') ' err_struct_tolRel: ',err_struct_tolRel - write(6,'(a24,1x,es8.1)') ' err_thermal_tolabs: ',err_thermal_tolabs - write(6,'(a24,1x,es8.1)') ' err_thermal_tolrel: ',err_thermal_tolrel - write(6,'(a24,1x,es8.1)') ' err_damage_tolabs: ',err_damage_tolabs - write(6,'(a24,1x,es8.1)') ' err_damage_tolrel: ',err_damage_tolrel - write(6,'(a24,1x,es8.1)') ' err_vacancyflux_tolabs: ',err_vacancyflux_tolabs - write(6,'(a24,1x,es8.1)') ' err_vacancyflux_tolrel: ',err_vacancyflux_tolrel - write(6,'(a24,1x,es8.1)') ' err_porosity_tolabs: ',err_porosity_tolabs - write(6,'(a24,1x,es8.1)') ' err_porosity_tolrel: ',err_porosity_tolrel - write(6,'(a24,1x,es8.1)') ' err_hydrogenflux_tolabs:',err_hydrogenflux_tolabs - write(6,'(a24,1x,es8.1)') ' err_hydrogenflux_tolrel:',err_hydrogenflux_tolrel - write(6,'(a24,1x,es8.1)') ' vacancyBoundPenalty: ',vacancyBoundPenalty - write(6,'(a24,1x,es8.1)') ' hydrogenBoundPenalty: ',hydrogenBoundPenalty + write(6,'(a24,1x,i8)') ' itmax: ',itmax + write(6,'(a24,1x,i8)') ' itmin: ',itmin + write(6,'(a24,1x,i8)') ' maxCutBack: ',maxCutBack + write(6,'(a24,1x,i8)') ' maxStaggeredIter: ',stagItMax + write(6,'(a24,1x,i8)') ' vacancyPolyOrder: ',vacancyPolyOrder + write(6,'(a24,1x,i8)') ' hydrogenPolyOrder: ',hydrogenPolyOrder + write(6,'(a24,1x,es8.1)') ' err_struct_tolAbs: ',err_struct_tolAbs + write(6,'(a24,1x,es8.1)') ' err_struct_tolRel: ',err_struct_tolRel + write(6,'(a24,1x,es8.1)') ' err_thermal_tolabs: ',err_thermal_tolabs + write(6,'(a24,1x,es8.1)') ' err_thermal_tolrel: ',err_thermal_tolrel + write(6,'(a24,1x,es8.1)') ' err_damage_tolabs: ',err_damage_tolabs + write(6,'(a24,1x,es8.1)') ' err_damage_tolrel: ',err_damage_tolrel + write(6,'(a24,1x,es8.1)') ' err_vacancyflux_tolabs: ',err_vacancyflux_tolabs + write(6,'(a24,1x,es8.1)') ' err_vacancyflux_tolrel: ',err_vacancyflux_tolrel + write(6,'(a24,1x,es8.1)') ' err_porosity_tolabs: ',err_porosity_tolabs + write(6,'(a24,1x,es8.1)') ' err_porosity_tolrel: ',err_porosity_tolrel + write(6,'(a24,1x,es8.1)') ' err_hydrogenflux_tolabs:',err_hydrogenflux_tolabs + write(6,'(a24,1x,es8.1)') ' err_hydrogenflux_tolrel:',err_hydrogenflux_tolrel + write(6,'(a24,1x,es8.1)') ' vacancyBoundPenalty: ',vacancyBoundPenalty + write(6,'(a24,1x,es8.1)') ' hydrogenBoundPenalty: ',hydrogenBoundPenalty !-------------------------------------------------------------------------------------------------- ! spectral parameters #ifdef Spectral - write(6,'(a24,1x,i8)') ' continueCalculation: ',continueCalculation - write(6,'(a24,1x,L8)') ' memory_efficient: ',memory_efficient - write(6,'(a24,1x,i8)') ' divergence_correction: ',divergence_correction - write(6,'(a24,1x,a)') ' spectral_derivative: ',trim(spectral_derivative) - if(fftw_timelimit<0.0_pReal) then - write(6,'(a24,1x,L8)') ' fftw_timelimit: ',.false. - else - write(6,'(a24,1x,es8.1)') ' fftw_timelimit: ',fftw_timelimit - endif - write(6,'(a24,1x,a)') ' fftw_plan_mode: ',trim(fftw_plan_mode) - write(6,'(a24,1x,i8)') ' fftw_planner_flag: ',fftw_planner_flag - write(6,'(a24,1x,L8,/)') ' update_gamma: ',update_gamma - write(6,'(a24,1x,es8.1)') ' err_stress_tolAbs: ',err_stress_tolAbs - write(6,'(a24,1x,es8.1)') ' err_stress_tolRel: ',err_stress_tolRel - write(6,'(a24,1x,es8.1)') ' err_div_tolAbs: ',err_div_tolAbs - write(6,'(a24,1x,es8.1)') ' err_div_tolRel: ',err_div_tolRel - write(6,'(a24,1x,es8.1)') ' err_curl_tolAbs: ',err_curl_tolAbs - write(6,'(a24,1x,es8.1)') ' err_curl_tolRel: ',err_curl_tolRel - write(6,'(a24,1x,es8.1)') ' polarAlpha: ',polarAlpha - write(6,'(a24,1x,es8.1)') ' polarBeta: ',polarBeta - write(6,'(a24,1x,a)') ' spectral solver: ',trim(spectral_solver) - write(6,'(a24,1x,a)') ' PETSc_options: ',trim(petsc_defaultOptions)//' '//trim(petsc_options) + write(6,'(a24,1x,i8)') ' continueCalculation: ',continueCalculation + write(6,'(a24,1x,L8)') ' memory_efficient: ',memory_efficient + write(6,'(a24,1x,i8)') ' divergence_correction: ',divergence_correction + write(6,'(a24,1x,a)') ' spectral_derivative: ',trim(spectral_derivative) + if(fftw_timelimit<0.0_pReal) then + write(6,'(a24,1x,L8)') ' fftw_timelimit: ',.false. + else + write(6,'(a24,1x,es8.1)') ' fftw_timelimit: ',fftw_timelimit + endif + write(6,'(a24,1x,a)') ' fftw_plan_mode: ',trim(fftw_plan_mode) + write(6,'(a24,1x,i8)') ' fftw_planner_flag: ',fftw_planner_flag + write(6,'(a24,1x,L8,/)') ' update_gamma: ',update_gamma + write(6,'(a24,1x,es8.1)') ' err_stress_tolAbs: ',err_stress_tolAbs + write(6,'(a24,1x,es8.1)') ' err_stress_tolRel: ',err_stress_tolRel + write(6,'(a24,1x,es8.1)') ' err_div_tolAbs: ',err_div_tolAbs + write(6,'(a24,1x,es8.1)') ' err_div_tolRel: ',err_div_tolRel + write(6,'(a24,1x,es8.1)') ' err_curl_tolAbs: ',err_curl_tolAbs + write(6,'(a24,1x,es8.1)') ' err_curl_tolRel: ',err_curl_tolRel + write(6,'(a24,1x,es8.1)') ' polarAlpha: ',polarAlpha + write(6,'(a24,1x,es8.1)') ' polarBeta: ',polarBeta + write(6,'(a24,1x,a)') ' spectral solver: ',trim(spectral_solver) + write(6,'(a24,1x,a)') ' PETSc_options: ',trim(petsc_defaultOptions)//' '//trim(petsc_options) #endif !-------------------------------------------------------------------------------------------------- ! spectral parameters #ifdef FEM - write(6,'(a24,1x,i8)') ' integrationOrder: ',integrationOrder - write(6,'(a24,1x,i8)') ' structOrder: ',structOrder - write(6,'(a24,1x,i8)') ' thermalOrder: ',thermalOrder - write(6,'(a24,1x,i8)') ' damageOrder: ',damageOrder - write(6,'(a24,1x,i8)') ' vacancyfluxOrder: ',vacancyfluxOrder - write(6,'(a24,1x,i8)') ' porosityOrder: ',porosityOrder - write(6,'(a24,1x,i8)') ' hydrogenfluxOrder: ',hydrogenfluxOrder - write(6,'(a24,1x,a)') ' PETSc_options: ',trim(petsc_defaultOptions)//' '//trim(petsc_options) - write(6,'(a24,1x,L8)') ' B-Bar stabilisation: ',BBarStabilisation + write(6,'(a24,1x,i8)') ' integrationOrder: ',integrationOrder + write(6,'(a24,1x,i8)') ' structOrder: ',structOrder + write(6,'(a24,1x,i8)') ' thermalOrder: ',thermalOrder + write(6,'(a24,1x,i8)') ' damageOrder: ',damageOrder + write(6,'(a24,1x,i8)') ' vacancyfluxOrder: ',vacancyfluxOrder + write(6,'(a24,1x,i8)') ' porosityOrder: ',porosityOrder + write(6,'(a24,1x,i8)') ' hydrogenfluxOrder: ',hydrogenfluxOrder + write(6,'(a24,1x,a)') ' PETSc_options: ',trim(petsc_defaultOptions)//' '//trim(petsc_options) + write(6,'(a24,1x,L8)') ' B-Bar stabilisation: ',BBarStabilisation #endif - endif mainProcess3 !-------------------------------------------------------------------------------------------------- From ddff0035b6380a49b0519a39828b85187a6b72ed Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 29 Jun 2016 16:59:22 +0200 Subject: [PATCH 29/37] removed old regridding related stuff --- code/DAMASK_spectral.f90 | 29 +++++++++++++---------------- code/FEsolving.f90 | 10 ++-------- code/IO.f90 | 2 -- code/mesh.f90 | 6 ++---- 4 files changed, 17 insertions(+), 30 deletions(-) diff --git a/code/DAMASK_spectral.f90 b/code/DAMASK_spectral.f90 index 53c9c4423..706aa22d9 100644 --- a/code/DAMASK_spectral.f90 +++ b/code/DAMASK_spectral.f90 @@ -617,12 +617,12 @@ program DAMASK_spectral timeinc = timeinc/2.0_pReal elseif (solres(1)%termIll) then ! material point model cannot find a solution, exit in any casy call IO_warning(850_pInt) - call quit(-1_pInt*(lastRestartWritten+1_pInt)) ! quit and provide information about last restart inc written (e.g. for regridding) + call quit(-1_pInt*(lastRestartWritten+1_pInt)) ! quit and provide information about last restart inc written elseif (continueCalculation == 1_pInt) then guess = .true. ! accept non converged BVP solution else ! default behavior, exit if spectral solver does not converge call IO_warning(850_pInt) - call quit(-1_pInt*(lastRestartWritten+1_pInt)) ! quit and provide information about last restart inc written (e.g. for regridding) + call quit(-1_pInt*(lastRestartWritten+1_pInt)) ! quit and provide information about last restart inc written endif else guess = .true. ! start guessing after first converged (sub)inc @@ -722,7 +722,7 @@ end program DAMASK_spectral !> @brief quit subroutine to mimic behavior of FEM solvers !> @details exits the Spectral solver and reports time and duration. Exit code 0 signals !> everything went fine. Exit code 1 signals an error, message according to IO_error. Exit code -!> 2 signals request for regridding, increment of last saved restart information is written to +!> 2 signals no converged solution and increment of last saved restart information is written to !> stderr. Exit code 3 signals no severe problems, but some increments did not converge !-------------------------------------------------------------------------------------------------- subroutine quit(stop_id) @@ -735,21 +735,18 @@ subroutine quit(stop_id) integer(pInt), intent(in) :: stop_id integer, dimension(8) :: dateAndTime ! type default integer - if (worldrank == 0_pInt) then - call date_and_time(values = dateAndTime) - write(6,'(/,a)') 'DAMASK terminated on:' - write(6,'(a,2(i2.2,a),i4.4)') 'Date: ',dateAndTime(3),'/',& - dateAndTime(2),'/',& - dateAndTime(1) - write(6,'(a,2(i2.2,a),i2.2)') 'Time: ',dateAndTime(5),':',& - dateAndTime(6),':',& - dateAndTime(7) - endif + call date_and_time(values = dateAndTime) + write(6,'(/,a)') 'DAMASK terminated on:' + write(6,'(a,2(i2.2,a),i4.4)') 'Date: ',dateAndTime(3),'/',& + dateAndTime(2),'/',& + dateAndTime(1) + write(6,'(a,2(i2.2,a),i2.2)') 'Time: ',dateAndTime(5),':',& + dateAndTime(6),':',& + dateAndTime(7) if (stop_id == 0_pInt) stop 0 ! normal termination - if (stop_id < 0_pInt) then ! trigger regridding - if (worldrank == 0_pInt) & - write(0,'(a,i6)') 'restart information available at ', stop_id*(-1_pInt) + if (stop_id < 0_pInt) then ! terminally ill, restart might help + write(0,'(a,i6)') 'restart information available at ', stop_id*(-1_pInt) stop 2 endif if (stop_id == 3_pInt) stop 3 ! not all incs converged diff --git a/code/FEsolving.f90 b/code/FEsolving.f90 index 3b0aeb194..bc7588ff0 100644 --- a/code/FEsolving.f90 +++ b/code/FEsolving.f90 @@ -72,11 +72,9 @@ subroutine FE_init integer(pInt), allocatable, dimension(:) :: chunkPos #endif - mainProcess: if (worldrank == 0) then - write(6,'(/,a)') ' <<<+- FEsolving init -+>>>' - write(6,'(a15,a)') ' Current time: ',IO_timeStamp() + write(6,'(/,a)') ' <<<+- FEsolving init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() #include "compilation_info.f90" - endif mainProcess modelName = getSolverJobName() #ifdef Spectral @@ -153,10 +151,6 @@ subroutine FE_init 200 close(FILEUNIT) endif -!-------------------------------------------------------------------------------------------------- -! the following array are allocated by mesh.f90 and need to be deallocated in case of regridding - if (allocated(calcMode)) deallocate(calcMode) - if (allocated(FEsolving_execIP)) deallocate(FEsolving_execIP) #endif if (iand(debug_level(debug_FEsolving),debug_levelBasic) /= 0_pInt) then write(6,'(a21,l1)') ' restart writing: ', restartWrite diff --git a/code/IO.f90 b/code/IO.f90 index 2a13ce3d8..55a75b78d 100644 --- a/code/IO.f90 +++ b/code/IO.f90 @@ -1640,8 +1640,6 @@ subroutine IO_error(error_ID,el,ip,g,ext_msg) msg = 'update of gamma operator not possible when pre-calculated' case (880_pInt) msg = 'mismatch of microstructure count and a*b*c in geom file' - case (890_pInt) - msg = 'invalid input for regridding' case (891_pInt) msg = 'unknown solver type selected' case (892_pInt) diff --git a/code/mesh.f90 b/code/mesh.f90 index 5b999cdb4..0562ab218 100644 --- a/code/mesh.f90 +++ b/code/mesh.f90 @@ -514,11 +514,9 @@ subroutine mesh_init(ip,el) integer(pInt) :: j logical :: myDebug - mainProcess: if (worldrank == 0) then - write(6,'(/,a)') ' <<<+- mesh init -+>>>' - write(6,'(a15,a)') ' Current time: ',IO_timeStamp() + write(6,'(/,a)') ' <<<+- mesh init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() #include "compilation_info.f90" - endif mainProcess if (allocated(mesh_mapFEtoCPelem)) deallocate(mesh_mapFEtoCPelem) if (allocated(mesh_mapFEtoCPnode)) deallocate(mesh_mapFEtoCPnode) From c949f407e559d073edeab8819c97b69165bffd86 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 29 Jun 2016 17:13:02 +0200 Subject: [PATCH 30/37] unused variable --- code/DAMASK_spectral.f90 | 2 -- 1 file changed, 2 deletions(-) diff --git a/code/DAMASK_spectral.f90 b/code/DAMASK_spectral.f90 index 706aa22d9..0be78083b 100644 --- a/code/DAMASK_spectral.f90 +++ b/code/DAMASK_spectral.f90 @@ -728,8 +728,6 @@ end program DAMASK_spectral subroutine quit(stop_id) use prec, only: & pInt - use numerics, only: & - worldrank implicit none integer(pInt), intent(in) :: stop_id From 745c0120886abbfdd8c957e983ac0ceb2720483c Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 29 Jun 2016 20:09:42 +0200 Subject: [PATCH 31/37] fully adopted code from addDisplacement --- processing/post/addCompatibilityMismatch.py | 121 +++++++++----------- 1 file changed, 57 insertions(+), 64 deletions(-) diff --git a/processing/post/addCompatibilityMismatch.py b/processing/post/addCompatibilityMismatch.py index 77e215acc..d311c286b 100755 --- a/processing/post/addCompatibilityMismatch.py +++ b/processing/post/addCompatibilityMismatch.py @@ -1,9 +1,9 @@ #!/usr/bin/env python2 # -*- coding: UTF-8 no BOM -*- -import os,sys -import numpy as np +import os import math +import numpy as np import scipy.ndimage from optparse import OptionParser import damask @@ -18,7 +18,7 @@ def cell2node(cellData,grid): datalen = np.array(cellData.shape[3:]).prod() for i in xrange(datalen): - node = scipy.ndimage.convolve(cellData.reshape(tuple(grid)+(datalen,))[...,i], + node = scipy.ndimage.convolve(cellData.reshape(tuple(grid[::-1])+(datalen,))[...,i], np.ones((2,2,2))/8., # 2x2x2 neighborhood of cells mode = 'wrap', origin = -1, # offset to have cell origin as center @@ -32,26 +32,26 @@ def cell2node(cellData,grid): return nodeData #-------------------------------------------------------------------------------------------------- -def displacementAvgFFT(F,grid,size,nodal=False,transformed=False): - """calculate average cell center (or nodal) displacement for deformation gradient field specified in each grid cell""" +def deformationAvgFFT(F,grid,size,nodal=False,transformed=False): + """calculate average cell center (or nodal) deformation for deformation gradient field specified in each grid cell""" if nodal: - x, y, z = np.meshgrid(np.linspace(0,size[0],1+grid[0]), + x, y, z = np.meshgrid(np.linspace(0,size[2],1+grid[2]), np.linspace(0,size[1],1+grid[1]), - np.linspace(0,size[2],1+grid[2]), + np.linspace(0,size[0],1+grid[0]), indexing = 'ij') else: - x, y, z = np.meshgrid(np.linspace(0,size[0],grid[0],endpoint=False), - np.linspace(0,size[1],grid[1],endpoint=False), - np.linspace(0,size[2],grid[2],endpoint=False), + x, y, z = np.meshgrid(np.linspace(size[2]/grid[2]/2.,size[2]-size[2]/grid[2]/2.,grid[2]), + np.linspace(size[1]/grid[1]/2.,size[1]-size[1]/grid[1]/2.,grid[1]), + np.linspace(size[0]/grid[0]/2.,size[0]-size[0]/grid[0]/2.,grid[0]), indexing = 'ij') origCoords = np.concatenate((z[:,:,:,None],y[:,:,:,None],x[:,:,:,None]),axis = 3) F_fourier = F if transformed else np.fft.rfftn(F,axes=(0,1,2)) # transform or use provided data Favg = np.real(F_fourier[0,0,0,:,:])/grid.prod() # take zero freq for average - avgDisplacement = np.einsum('ml,ijkl->ijkm',Favg-np.eye(3),origCoords) # dX = Favg.X + avgDeformation = np.einsum('ml,ijkl->ijkm',Favg,origCoords) # dX = Favg.X - return avgDisplacement + return avgDeformation #-------------------------------------------------------------------------------------------------- def displacementFluctFFT(F,grid,size,nodal=False,transformed=False): @@ -69,16 +69,16 @@ def displacementFluctFFT(F,grid,size,nodal=False,transformed=False): #-------------------------------------------------------------------------------------------------- # integration in Fourier space - displacement_fourier = +np.einsum('ijkml,ijkl,l->ijkm', + displacement_fourier = -np.einsum('ijkml,ijkl,l->ijkm', F if transformed else np.fft.rfftn(F,axes=(0,1,2)), k_s, integrator, - ) / k_sSquared[...,np.newaxis] + ) / k_sSquared[...,np.newaxis] #-------------------------------------------------------------------------------------------------- # backtransformation to real space - displacement = np.fft.irfftn(displacement_fourier,grid,axes=(0,1,2)) + displacement = np.fft.irfftn(displacement_fourier,grid[::-1],axes=(0,1,2)) return cell2node(displacement,grid) if nodal else displacement @@ -137,7 +137,7 @@ def volumeMismatch(size,F,nodes): (compatible) cube and determinant of defgrad at the FP """ coords = np.empty([8,3]) - vMismatch = np.empty(grid) + vMismatch = np.empty(grid[::-1]) volInitial = size.prod()/grid.prod() #-------------------------------------------------------------------------------------------------- @@ -145,23 +145,22 @@ def volumeMismatch(size,F,nodes): for k in xrange(grid[2]): for j in xrange(grid[1]): for i in xrange(grid[0]): - coords[0,0:3] = nodes[i, j, k ,0:3] - coords[1,0:3] = nodes[i+1,j, k ,0:3] - coords[2,0:3] = nodes[i+1,j+1,k ,0:3] - coords[3,0:3] = nodes[i, j+1,k ,0:3] - coords[4,0:3] = nodes[i, j, k+1,0:3] - coords[5,0:3] = nodes[i+1,j, k+1,0:3] - coords[6,0:3] = nodes[i+1,j+1,k+1,0:3] - coords[7,0:3] = nodes[i, j+1,k+1,0:3] - vMismatch[i,j,k] = \ - abs(volTetrahedron([coords[6,0:3],coords[0,0:3],coords[7,0:3],coords[3,0:3]])) \ + coords[0,0:3] = nodes[k, j, i ,0:3] + coords[1,0:3] = nodes[k ,j, i+1,0:3] + coords[2,0:3] = nodes[k ,j+1,i+1,0:3] + coords[3,0:3] = nodes[k, j+1,i ,0:3] + coords[4,0:3] = nodes[k+1,j, i ,0:3] + coords[5,0:3] = nodes[k+1,j, i+1,0:3] + coords[6,0:3] = nodes[k+1,j+1,i+1,0:3] + coords[7,0:3] = nodes[k+1,j+1,i ,0:3] + vMismatch[k,j,i] = \ + ( abs(volTetrahedron([coords[6,0:3],coords[0,0:3],coords[7,0:3],coords[3,0:3]])) \ + abs(volTetrahedron([coords[6,0:3],coords[0,0:3],coords[7,0:3],coords[4,0:3]])) \ + abs(volTetrahedron([coords[6,0:3],coords[0,0:3],coords[2,0:3],coords[3,0:3]])) \ + abs(volTetrahedron([coords[6,0:3],coords[0,0:3],coords[2,0:3],coords[1,0:3]])) \ + abs(volTetrahedron([coords[6,0:3],coords[4,0:3],coords[1,0:3],coords[5,0:3]])) \ - + abs(volTetrahedron([coords[6,0:3],coords[4,0:3],coords[1,0:3],coords[0,0:3]])) - vMismatch[i,j,k] = vMismatch[i,j,k]/np.linalg.det(F[i,j,k,0:3,0:3]) - + + abs(volTetrahedron([coords[6,0:3],coords[4,0:3],coords[1,0:3],coords[0,0:3]]))) \ + /np.linalg.det(F[k,j,i,0:3,0:3]) return vMismatch/volInitial @@ -175,7 +174,7 @@ def shapeMismatch(size,F,nodes,centres): the initial volume element with the current deformation gradient """ coordsInitial = np.empty([8,3]) - sMismatch = np.empty(grid) + sMismatch = np.empty(grid[::-1]) #-------------------------------------------------------------------------------------------------- # initial positions @@ -194,15 +193,15 @@ def shapeMismatch(size,F,nodes,centres): for k in xrange(grid[2]): for j in xrange(grid[1]): for i in xrange(grid[0]): - sMismatch[i,j,k] = \ - + np.linalg.norm(nodes[i, j, k,0:3] - centres[i,j,k,0:3] - np.dot(F[i,j,k,:,:], coordsInitial[0,0:3]))\ - + np.linalg.norm(nodes[i+1,j, k,0:3] - centres[i,j,k,0:3] - np.dot(F[i,j,k,:,:], coordsInitial[1,0:3]))\ - + np.linalg.norm(nodes[i+1,j+1,k ,0:3] - centres[i,j,k,0:3] - np.dot(F[i,j,k,:,:], coordsInitial[2,0:3]))\ - + np.linalg.norm(nodes[i, j+1,k ,0:3] - centres[i,j,k,0:3] - np.dot(F[i,j,k,:,:], coordsInitial[3,0:3]))\ - + np.linalg.norm(nodes[i, j, k+1,0:3] - centres[i,j,k,0:3] - np.dot(F[i,j,k,:,:], coordsInitial[4,0:3]))\ - + np.linalg.norm(nodes[i+1,j, k+1,0:3] - centres[i,j,k,0:3] - np.dot(F[i,j,k,:,:], coordsInitial[5,0:3]))\ - + np.linalg.norm(nodes[i+1,j+1,k+1,0:3] - centres[i,j,k,0:3] - np.dot(F[i,j,k,:,:], coordsInitial[6,0:3]))\ - + np.linalg.norm(nodes[i, j+1,k+1,0:3] - centres[i,j,k,0:3] - np.dot(F[i,j,k,:,:], coordsInitial[7,0:3])) + sMismatch[k,j,i] = \ + + np.linalg.norm(nodes[k, j, i ,0:3] - centres[k,j,i,0:3] - np.dot(F[k,j,i,:,:], coordsInitial[0,0:3]))\ + + np.linalg.norm(nodes[k, j, i+1,0:3] - centres[k,j,i,0:3] - np.dot(F[k,j,i,:,:], coordsInitial[1,0:3]))\ + + np.linalg.norm(nodes[k, j+1,i+1,0:3] - centres[k,j,i,0:3] - np.dot(F[k,j,i,:,:], coordsInitial[2,0:3]))\ + + np.linalg.norm(nodes[k, j+1,i ,0:3] - centres[k,j,i,0:3] - np.dot(F[k,j,i,:,:], coordsInitial[3,0:3]))\ + + np.linalg.norm(nodes[k+1,j, i ,0:3] - centres[k,j,i,0:3] - np.dot(F[k,j,i,:,:], coordsInitial[4,0:3]))\ + + np.linalg.norm(nodes[k+1,j, i+1,0:3] - centres[k,j,i,0:3] - np.dot(F[k,j,i,:,:], coordsInitial[5,0:3]))\ + + np.linalg.norm(nodes[k+1,j+1,i+1,0:3] - centres[k,j,i,0:3] - np.dot(F[k,j,i,:,:], coordsInitial[6,0:3]))\ + + np.linalg.norm(nodes[k+1,j+1,i ,0:3] - centres[k,j,i,0:3] - np.dot(F[k,j,i,:,:], coordsInitial[7,0:3])) return sMismatch @@ -307,38 +306,32 @@ for name in filenames: # -----------------------------process data and assemble header ------------------------------------- F_fourier = np.fft.rfftn(table.data[:,:9].reshape(grid[2],grid[1],grid[0],3,3),axes=(0,1,2)) # perform transform only once... - nodes = np.vstack(np.meshgrid(np.linspace(0.0,size[0],grid[0]+1), - np.linspace(0.0,size[1],grid[1]+1), - np.linspace(0.0,size[2],grid[2]+1))).reshape([3,17,17,17]).T\ - + displacementFluctFFT(F_fourier,grid,size,True,transformed=True)\ - + displacementAvgFFT (F_fourier,grid,size,True,transformed=True) + nodes = displacementFluctFFT(F_fourier,grid,size,True,transformed=True)\ + + deformationAvgFFT (F_fourier,grid,size,True,transformed=True) + if options.shape: table.labels_append(['shapeMismatch({})'.format(options.defgrad)]) - centres = np.vstack(np.meshgrid(np.linspace(size[0]/grid[0]*.5,size[0]-size[0]/grid[0]*.5,grid[0]), - np.linspace(size[1]/grid[1]*.5,size[1]-size[1]/grid[1]*.5,grid[1]), - np.linspace(size[2]/grid[2]*.5,size[2]-size[2]/grid[2]*.5,grid[2]))).reshape([3,16,16,16]).T\ - + displacementFluctFFT(F_fourier,grid,size,False,transformed=True)\ - + displacementAvgFFT (F_fourier,grid,size,False,transformed=True) + centres = displacementFluctFFT(F_fourier,grid,size,False,transformed=True)\ + + deformationAvgFFT (F_fourier,grid,size,False,transformed=True) if options.volume: table.labels_append(['volMismatch({})'.format(options.defgrad)]) table.head_write() - if options.shape: shapeMismatch = shapeMismatch( size,table.data[:,:9].reshape(grid[2],grid[1],grid[0],3,3),nodes,centres) - if options.volume: volumeMismatch = volumeMismatch(size,table.data[:,:9].reshape(grid[2],grid[1],grid[0],3,3),nodes) + if options.shape: + shapeMismatch = shapeMismatch( size,table.data[:,:9].reshape(grid[2],grid[1],grid[0],3,3),nodes,centres) + if options.volume: + volumeMismatch = volumeMismatch(size,table.data[:,:9].reshape(grid[2],grid[1],grid[0],3,3),nodes) -# ------------------------------------------ process data ------------------------------------------ - table.data_rewind() - idx = 0 - outputAlive = True - while outputAlive and table.data_read(): # read next data line of ASCII table - (x,y,z) = damask.util.gridLocation(idx,grid) # figure out (x,y,z) position from line count - idx += 1 - if options.shape: table.data_append( shapeMismatch[x,y,z]) - if options.volume: table.data_append(volumeMismatch[x,y,z]) - outputAlive = table.data_write() +# ------------------------------------------ output data ------------------------------------------- + for i in xrange(grid[2]): + for j in xrange(grid[1]): + for k in xrange(grid[0]): + table.data_read() + if options.shape: table.data_append(shapeMismatch[i,j,k]) + if options.volume: table.data_append(volumeMismatch[i,j,k]) + table.data_write() -# ------------------------------------------ output finalization ----------------------------------- - - table.close() +# ------------------------------------------ output finalization ----------------------------------- + table.close() # close ASCII tables From 97d6ed57e1d627a4dfff3393a7c8accdd27cad87 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 29 Jun 2016 20:13:00 +0200 Subject: [PATCH 32/37] also not needed any more --- installation/compile_CoreModule.py | 141 ----------------------------- 1 file changed, 141 deletions(-) delete mode 100755 installation/compile_CoreModule.py diff --git a/installation/compile_CoreModule.py b/installation/compile_CoreModule.py deleted file mode 100755 index 94df21f91..000000000 --- a/installation/compile_CoreModule.py +++ /dev/null @@ -1,141 +0,0 @@ -#!/usr/bin/env python2 -# -*- coding: UTF-8 no BOM -*- - -import os,sys,glob,subprocess,shlex -from damask import Environment -from damask import version as DAMASKVERSION - -# compiles fortran code for Python -scriptID = '$Id$' - -damaskEnv = Environment() -baseDir = damaskEnv.relPath('installation/') -codeDir = damaskEnv.relPath('code/') - -keywords=['IMKL_ROOT','ACML_ROOT','LAPACK_ROOT','FFTW_ROOT','F90'] -options={} - -#--- getting options from damask.conf or, if not present, from envinronment ----------------------- -for option in keywords: - try: - value = damaskEnv.options[option] - except: - value = os.getenv(option) - if value is None: value = '' # env not set - options[option]=value - -#--- overwrite default options with keyword=value pair from argument list to mimic make behavior -- -for i, arg in enumerate(sys.argv): - for option in keywords: - if arg.startswith(option): - options[option] = sys.argv[i][len(option)+1:] - -#--- check for valid compiler and set options ----------------------------------------------------- -compilers = ['ifort','gfortran'] -if options['F90'] not in compilers: - sys.exit('compiler "F90" (in installation/options or as Shell variable) has to be one out of: %s'%(', '.join(compilers))) - -compiler = { - 'gfortran': '--fcompiler=gnu95 --f90flags="-fPIC -fno-range-check -xf95-cpp-input -std=f2008 -fall-intrinsics'+\ - ' -fdefault-real-8 -fdefault-double-8"', - 'ifort': '--fcompiler=intelem --f90flags="-fPIC -fpp -stand f08 -diag-disable 5268 -assume byterecl'+\ - ' -real-size 64 -integer-size 32 -shared-intel"', - }[options['F90']] - -#--- option not depending on compiler ------------------------------------------------------------- -compileOptions = ' -DSpectral -DFLOAT=8 -DINT=4 -I%s/lib -DDAMASKVERSION=\\\\\"\\\"%s\\\\\"\\\"'%(damaskEnv.rootDir(),DAMASKVERSION) - -#--- this saves the path of libraries to core.so, hence it is known during runtime ---------------- -if options['F90'] == 'gfortran': - # solved error: Undefined symbols for architecture x86_64: "_PyArg_ParseTupleAndKeywords" - # as found on https://lists.macosforge.org/pipermail/macports-dev/2013-May/022735.html - LDFLAGS = '-shared -Wl,-undefined,dynamic_lookup' -else: - # some f2py versions/configurations compile with openMP, so linking against openMP is needed - # to prevent errors during loading of core module - LDFLAGS = ' -openmp -Wl' - -#--- run path of for fftw during runtime ---------------------------------------------------------- -LDFLAGS += ',-rpath,%s/lib,-rpath,%s/lib64'%(options['FFTW_ROOT'],options['FFTW_ROOT']) - -# see http://cens.ioc.ee/pipermail/f2py-users/2003-December/000621.html -if options['IMKL_ROOT']: - if options['F90'] == 'gfortran': - arch = 'gf' - elif options['F90'] == 'ifort': - arch = 'intel' - lib_lapack = '-L%s/lib/intel64 -lmkl_%s_lp64 -lmkl_core -lmkl_sequential -lm'\ - %(options['IMKL_ROOT'],arch) - LDFLAGS +=',-rpath,%s/lib/intel64'%(options['IMKL_ROOT']) -elif options['ACML_ROOT'] != '': - lib_lapack = '-L%s/%s64/lib -lacml'%(options['ACML_ROOT'],options['F90']) - LDFLAGS +=',-rpath,%s/%s64/lib'%(options['ACML_ROOT'],options['F90']) -elif options['LAPACK_ROOT'] != '': - lib_lapack = '-L%s/lib -L%s/lib64 -llapack'%(options['LAPACK_ROOT'],options['LAPACK_ROOT']) - LDFLAGS +=',-rpath,%s/lib,-rpath,%s/lib64'%(options['LAPACK_ROOT'],options['LAPACK_ROOT']) - -#-------------------------------------------------------------------------------------------------- -# f2py does not (yet) support setting of special flags for the linker, hence they must be set via -# environment variable ---------------------------------------------------------------------------- -my_env = os.environ -my_env["LDFLAGS"] = LDFLAGS - -#--- delete old file ------------------------------------------------------------------------------ -try: - os.remove(os.path.join(damaskEnv.relPath('lib/damask'),'core.so')) -except OSError, e: - print ("Error when deleting: %s - %s." % (e.filename,e.strerror)) - - -# The following command is used to compile the fortran files and make the functions defined -# in damask.core.pyf available for python in the module core.so -# It uses the fortran wrapper f2py that is included in the numpy package to construct the -# module core.so out of the fortran code in the f90 files -# For the generation of the pyf file use the following lines: -########################################################################### -#'f2py -h damask.core.pyf' +\ -#' --overwrite-signature --no-lower prec.f90 DAMASK_spectral_interface.f90 math.f90 mesh.f90,...' - ########################################################################### -os.chdir(codeDir) -cmd = 'f2py damask.core.pyf' +\ - ' -c --no-lower %s'%(compiler) +\ - compileOptions+\ - ' C_routines.c'+\ - ' system_routines.f90'+\ - ' prec.f90'+\ - ' spectral_interface.f90'+\ - ' IO.f90'+\ - ' libs.f90'+\ - ' numerics.f90'+\ - ' debug.f90'+\ - ' math.f90'+\ - ' FEsolving.f90'+\ - ' mesh.f90'+\ - ' core_quit.f90'+\ - ' -L%s/lib -lfftw3'%(options['FFTW_ROOT'])+\ - ' %s'%lib_lapack - -print('Executing: '+cmd) -try: - subprocess.call(shlex.split(cmd),env=my_env) -except subprocess.CalledProcessError: - print('build failed') -except OSError: - print ('f2py not found') - -try: - os.rename(os.path.join(codeDir,'core.so'),\ - os.path.join(damaskEnv.relPath('lib/damask'),'core.so')) -except: - pass - -modules = glob.glob('*.mod') -for module in modules: - print 'removing', module - os.remove(module) - -#--- check if compilation of core module was successful ------------------------------------------- -try: - with open(damaskEnv.relPath('lib/damask/core.so')) as f: pass -except IOError as e: - print '*********\n* core.so not found, compilation of core modules was not successful\n*********' From bfcad397286ccc9a743049fe6ef125e211fb2f10 Mon Sep 17 00:00:00 2001 From: Test User Date: Thu, 30 Jun 2016 04:32:36 +0200 Subject: [PATCH 33/37] updated version information after successful test of v2.0.0-302-g2c8427e --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index 38c2a636c..285f9d261 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.0-297-ga27aba1 +v2.0.0-302-g2c8427e From 755501da694a750452507e3655ab94b91f6d5e8f Mon Sep 17 00:00:00 2001 From: Test User Date: Thu, 30 Jun 2016 16:31:41 +0200 Subject: [PATCH 34/37] updated version information after successful test of v2.0.0-310-ge99784d --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index 285f9d261..bc924dc1e 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.0-302-g2c8427e +v2.0.0-310-ge99784d From 7445aa0b32ebd4dc8e118fec8d75622af2d96a7a Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 1 Jul 2016 15:00:56 +0200 Subject: [PATCH 35/37] conflict due to line ending changes --- DAMASK_env.bat | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) create mode 100644 DAMASK_env.bat diff --git a/DAMASK_env.bat b/DAMASK_env.bat new file mode 100644 index 000000000..751237800 --- /dev/null +++ b/DAMASK_env.bat @@ -0,0 +1,19 @@ +:: sets up an environment for DAMASK on Windows +:: usage: call DAMASK_env.bat +@echo off +set LOCATION=%~dp0 +set DAMASK_ROOT=%LOCATION%\DAMASK +set DAMASK_NUM_THREADS=2 +chcp 1252 +Title Düsseldorf Advanced Materials Simulation Kit - DAMASK, MPIE Düsseldorf +echo. +echo Düsseldorf Advanced Materials Simulation Kit - DAMASK +echo Max-Planck-Institut für Eisenforschung, Düsseldorf +echo http://damask.mpie.de +echo. +echo Preparing environment ... +echo DAMASK_ROOT=%DAMASK_ROOT% +echo DAMASK_NUM_THREADS=%DAMASK_NUM_THREADS% +set DAMASK_BIN=%DAMASK_ROOT%\bin +set PATH=%PATH%;%DAMASK_BIN% +set PYTHONPATH=%PYTHONPATH%;%DAMASK_ROOT%\lib From fa13aa30b03eed860a46e981cae2f02d1bad5e4c Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 29 Jun 2016 20:49:01 +0200 Subject: [PATCH 36/37] python 3 at least imports the damask module now --- lib/damask/colormaps.py | 1 + lib/damask/solver/abaqus.py | 2 +- lib/damask/util.py | 2 +- 3 files changed, 3 insertions(+), 2 deletions(-) diff --git a/lib/damask/colormaps.py b/lib/damask/colormaps.py index 45c88e8d5..b0063d76e 100644 --- a/lib/damask/colormaps.py +++ b/lib/damask/colormaps.py @@ -15,6 +15,7 @@ class Color(): __slots__ = [ 'model', 'color', + '__dict__', ] diff --git a/lib/damask/solver/abaqus.py b/lib/damask/solver/abaqus.py index 0a872bc7a..ffb01ac51 100644 --- a/lib/damask/solver/abaqus.py +++ b/lib/damask/solver/abaqus.py @@ -13,7 +13,7 @@ class Abaqus(Solver): import subprocess process = subprocess.Popen(['abaqus', 'information=release'],stdout = subprocess.PIPE,stderr = subprocess.PIPE) self.version = process.stdout.readlines()[1].split()[1] - print self.version + print(self.version) else: self.version = version diff --git a/lib/damask/util.py b/lib/damask/util.py index 620920531..14410f2ea 100644 --- a/lib/damask/util.py +++ b/lib/damask/util.py @@ -415,7 +415,7 @@ def leastsqBound(func, x0, args=(), bounds=None, Dfun=None, full_output=0, try: cov_x = inv(np.dot(np.transpose(R), R)) except LinAlgError as inverror: - print inverror + print(inverror) pass return (x, cov_x) + retval[1:-1] + (mesg, info) else: From a317636e8b1824b1b92e9a5c71103c86e396ad06 Mon Sep 17 00:00:00 2001 From: Test User Date: Sun, 3 Jul 2016 02:24:55 +0200 Subject: [PATCH 37/37] updated version information after successful test of v2.0.0-341-gaf4307e --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index bc924dc1e..c6344d639 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.0-310-ge99784d +v2.0.0-341-gaf4307e