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 diff --git a/Makefile b/Makefile index 8be738090..6c63d01f6 100755 --- a/Makefile +++ b/Makefile @@ -21,11 +21,11 @@ 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; \ fi - @./installation/compile_CoreModule.py ${MAKEFLAGS} .PHONY: tidy tidy: diff --git a/VERSION b/VERSION index 38c2a636c..c6344d639 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.0-297-ga27aba1 +v2.0.0-341-gaf4307e diff --git a/code/DAMASK_spectral.f90 b/code/DAMASK_spectral.f90 index 53c9c4423..0be78083b 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,34 +722,29 @@ 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) use prec, only: & pInt - use numerics, only: & - worldrank implicit none 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..db0c056fe 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 @@ -1640,8 +1625,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/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/commercialFEM_fileList.f90 b/code/commercialFEM_fileList.f90 index 677ca049b..7b95490b0 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/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/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/math.f90 b/code/math.f90 index 12803ba3d..442494834 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, & diff --git a/code/mesh.f90 b/code/mesh.f90 index ecf2dd6f3..0562ab218 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: & @@ -531,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) @@ -562,25 +543,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 +566,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 +589,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) @@ -666,15 +638,12 @@ 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) 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)) & @@ -963,7 +932,7 @@ subroutine mesh_build_ipCoordinates do n = 1_pInt,FE_NcellnodesPerCell(c) ! loop over cell nodes in this cell myCoords = myCoords + mesh_cellnode(1:3,mesh_cell(n,i,e)) enddo - mesh_ipCoordinates(1:3,i,e) = myCoords / real(FE_NcellnodesPerCell(c),pReal) + mesh_ipCoordinates(1:3,i,e) = myCoords / FE_NcellnodesPerCell(c) enddo enddo !$OMP END PARALLEL DO @@ -990,7 +959,7 @@ pure function mesh_cellCenterCoordinates(ip,el) do n = 1_pInt,FE_NcellnodesPerCell(c) ! loop over cell nodes in this cell mesh_cellCenterCoordinates = mesh_cellCenterCoordinates + mesh_cellnode(1:3,mesh_cell(n,ip,el)) enddo - mesh_cellCenterCoordinates = mesh_cellCenterCoordinates / real(FE_NcellnodesPerCell(c),pReal) + mesh_cellCenterCoordinates = mesh_cellCenterCoordinates / FE_NcellnodesPerCell(c) end function mesh_cellCenterCoordinates @@ -1417,11 +1386,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 @@ -1558,332 +1525,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 @@ -3070,6 +2713,7 @@ use IO, only: & implicit none integer(pInt), intent(in) :: fileUnit + #ifndef Spectral integer(pInt), allocatable, dimension(:) :: chunkPos integer(pInt) chunk, Nchunks @@ -3081,9 +2725,10 @@ use IO, only: & mesh_periodicSurface = .true. #else mesh_periodicSurface = .false. -#if defined(Marc4DAMASK) +#ifdef Marc4DAMASK keyword = '$damask' -#elif defined(Abaqus) +#endif +#ifdef Abaqus keyword = '**damask' #endif @@ -3691,7 +3336,6 @@ integer(pInt) function FE_mapElemtype(what) 'c3d20t') FE_mapElemtype = 13_pInt ! Three-dimensional Arbitrarily Distorted quadratic hexahedral case default - FE_mapElemtype = -1_pInt ! error return call IO_error(error_ID=190_pInt,ext_msg=IO_lc(what)) end select @@ -3700,7 +3344,6 @@ end function FE_mapElemtype !-------------------------------------------------------------------------------------------------- !> @brief find face-matching element of same type -!> @details currently not used, check if needed for HDF5 output, otherwise delete !-------------------------------------------------------------------------------------------------- subroutine mesh_faceMatch(elem, face ,matchingElem, matchingFace) @@ -4511,212 +4154,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 - implicit none - integer(I4P), dimension(1:mesh_Ncells) :: celltype - integer(I4P), dimension(mesh_Ncells*(1_pInt+FE_maxNcellnodesPerCell)) :: cellconnection - 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 - enddo - enddo - - 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/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 !-------------------------------------------------------------------------------------------------- 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_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_interface.f90 b/code/spectral_interface.f90 index b10399cbd..31b198806 100644 --- a/code/spectral_interface.f90 +++ b/code/spectral_interface.f90 @@ -13,9 +13,7 @@ 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) integer(pInt), public, protected :: spectralRestartInc = 1_pInt !< Increment at which calculation starts character(len=1024), public, protected :: & @@ -44,13 +42,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 @@ -67,9 +62,7 @@ subroutine DAMASK_interface_init(loadCaseParameterIn,geometryParameterIn) chunkPos integer, dimension(8) :: & dateAndTime ! type default integer -#ifdef PETSc PetscErrorCode :: ierr -#endif external :: & quit,& MPI_Comm_rank,& @@ -77,9 +70,10 @@ 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 #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>>' - 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 (output_unit /= 6) then + write(output_unit,'(a)') 'STDOUT != 6' + call quit(1_pInt) + endif + else mainProcess + 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 - 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 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" + + 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)') ' --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)')' -----------------------------------------------------------------------' + 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. + 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)' 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) 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/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*********' 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/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 1b6ec409d..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] @@ -10,47 +10,14 @@ 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 # noqa + print "Import Cython version of Orientation module" +except: + 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 .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) 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/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 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..ef2de48eb 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: @@ -464,4 +464,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) + return (popt, pcov, infodict, errmsg, ier) if return_full else (popt, pcov) \ No newline at end of file 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/3Dvisualize.py b/processing/post/3Dvisualize.py deleted file mode 100755 index e29a761df..000000000 --- a/processing/post/3Dvisualize.py +++ /dev/null @@ -1,433 +0,0 @@ -#!/usr/bin/env python2 -# -*- 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 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_pos',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])) - 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 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 diff --git a/processing/post/addCompatibilityMismatch.py b/processing/post/addCompatibilityMismatch.py index e4fc4a145..d311c286b 100755 --- a/processing/post/addCompatibilityMismatch.py +++ b/processing/post/addCompatibilityMismatch.py @@ -1,14 +1,210 @@ #!/usr/bin/env python2 # -*- coding: UTF-8 no BOM -*- -import os,sys +import os +import math import numpy as np +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[::-1])+(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 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[2],1+grid[2]), + np.linspace(0,size[1],1+grid[1]), + np.linspace(0,size[0],1+grid[0]), + indexing = 'ij') + else: + 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 + avgDeformation = np.einsum('ml,ijkl->ijkm',Favg,origCoords) # dX = Favg.X + + return avgDeformation + +#-------------------------------------------------------------------------------------------------- +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[::-1],axes=(0,1,2)) + + return cell2node(displacement,grid) if nodal else displacement + + +def volTetrahedron(coords): + """ + 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. + + 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 + 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) + + + # 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(np.linalg.det(M) / 288) + + +def volumeMismatch(size,F,nodes): + """ + 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[::-1]) + 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,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]]))) \ + /np.linalg.det(F[k,j,i,0:3,0:3]) + return vMismatch/volInitial + + + +def shapeMismatch(size,F,nodes,centres): + """ + 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[::-1]) + +#-------------------------------------------------------------------------------------------------- +# 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 + for k in xrange(grid[2]): + for j in xrange(grid[1]): + for i in xrange(grid[0]): + 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 + + # -------------------------------------------------------------------- # MAIN # -------------------------------------------------------------------- @@ -64,79 +260,78 @@ 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 = damask.core.mesh.shapeMismatch( size,F,nodes,centres) - if options.volume: volumeMismatch = damask.core.mesh.volumeMismatch(size,F,nodes) +# -----------------------------process data and assemble header ------------------------------------- -# ------------------------------------------ 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() + 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 = displacementFluctFFT(F_fourier,grid,size,True,transformed=True)\ + + deformationAvgFFT (F_fourier,grid,size,True,transformed=True) -# ------------------------------------------ output finalization ----------------------------------- + if options.shape: + table.labels_append(['shapeMismatch({})'.format(options.defgrad)]) + 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) + +# ------------------------------------------ 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() # close ASCII tables 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/addDisplacement.py b/processing/post/addDisplacement.py index bcc02f869..a1a476185 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 @@ -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) @@ -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 @@ -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 --------------------------------------- @@ -203,18 +203,18 @@ for name in filenames: # ------------------------------------------ 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( 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 ----------------------------------- 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 -----------------------------------------