diff --git a/lib/IR_Precision.f90 b/lib/IR_Precision.f90 new file mode 100644 index 000000000..e995ac898 --- /dev/null +++ b/lib/IR_Precision.f90 @@ -0,0 +1,867 @@ +!> @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 +!> @} + +!> @ingroup Interface +!> @{ +!> @defgroup IR_PrecisionInterface IR_Precision +!> @} + +!> @ingroup GlobalVarPar +!> @{ +!> @defgroup IR_PrecisionGlobalVarPar IR_Precision +!> @} + +!> @ingroup PublicProcedure +!> @{ +!> @defgroup IR_PrecisionPublicProcedure IR_Precision +!> @} + +!> @ingroup PrivateProcedure +!> @{ +!> @defgroup IR_PrecisionPrivateProcedure IR_Precision +!> @} + +!> @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 +#ifdef r16p +public:: R16P, FR16P, DR16P, MinR16P, MaxR16P, BIR16P, BYR16P, smallR16P, ZeroR16 +#endif +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:: check_endian +public:: bit_size +public:: str, strz, cton +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. +#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: +#ifdef r16p +character(10), parameter:: FR16P = '(E42.33E4)' !< Output format for kind=R16P variable. +#endif +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: +#ifdef r16p +integer, parameter:: DR16P = 42 !< Number of digits of output format FR16P. +#endif +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. + +! Useful parameters for handling numbers ranges. +! Real min and max values: +#ifdef r16p +real(R16P), parameter:: MinR16P = -huge(1._R16P), MaxR16P = huge(1._R16P) !< Min and max values of kind=R16P variable. +#endif +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 +#ifdef r16p +integer(I1P):: BIR16P, BYR16P !< Number of bits/bytes of kind=R16P variable. +#endif +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: +#ifdef r16p +real(R16P), parameter:: smallR16P = tiny(1._R16P) !< Smallest representable value of kind=R16P variable. +#endif +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)-1_I8P, MaxI8P = huge(1_I8P) !< Min and max values of kind=I8P variable. +integer(I4P), parameter:: MinI4P = -huge(1_I4P)-1_I4P, MaxI4P = huge(1_I4P) !< Min and max values of kind=I4P variable. +integer(I2P), parameter:: MinI2P = -huge(1_I2P)-1_I2P, MaxI2P = huge(1_I2P) !< Min and max values of kind=I2P variable. +integer(I1P), parameter:: MinI1P = -huge(1_I1P)-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(MaxI4P), 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 r16p +real(R16P), parameter:: ZeroR16 = nearest(1._R16P, 1._R16P) - & + nearest(1._R16P,-1._R16P) !< Smallest representable difference of kind=R16P variable. +#endif +#ifdef pgf95 +real(R8P), parameter:: ZeroR8 = 0._R8P +real(R4P), parameter:: ZeroR4 = 0._R4P +#else +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 variables; +!> number, intent(\b IN):: \em n input number; +!> 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 +endinterface +!> @brief Function 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 + str_R16P,strf_R16P,& +#endif + str_R8P,strf_R8P, & + str_R4P,strf_R4P, & + str_I8P,strf_I8P, & + str_I4P,strf_I4P, & + str_I2P,strf_I2P, & + str_I1P,strf_I1P +endinterface +!> @brief Function 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 Function 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 +!----------------------------------------------------------------------------------------------------------------------------------- +contains + !> @ingroup IR_PrecisionPublicProcedure + !> @{ + !>Function 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 + + !>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. + !>@return endian + subroutine check_endian() + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (is_little_endian()) then + endian = endianL + else + endian = endianB + endif + return + !--------------------------------------------------------------------------------------------------------------------------------- + endsubroutine check_endian + !> @} + + !> @ingroup IR_PrecisionPrivateProcedure + !> @{ +#ifdef r16p + !> @brief Function for computing the number of bits of a real variable. + elemental function bit_size_R16P(i) result(bits) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + real(R16P), intent(IN):: i !< Real variable of which number of bits must be computed. + integer(I1P):: bits !< Number of bits of i. + integer(I1P):: mold(1) !< "Molding" dummy variable for bits counting. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + bits = size(transfer(i,mold))*8_I1P + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction bit_size_R16P +#endif + + !> @brief Function for computing the number of bits of a real variable. + elemental function bit_size_R8P(i) result(bits) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + real(R8P), intent(IN):: i !< Real variable of which number of bits must be computed. + integer(I1P):: bits !< Number of bits of i. + integer(I1P):: mold(1) !< "Molding" dummy variable for bits counting. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + bits = size(transfer(i,mold))*8_I1P + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction bit_size_R8P + + !> @brief Function for computing the number of bits of a real variable. + elemental function bit_size_R4P(i) result(bits) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + real(R4P), intent(IN):: i !< Real variable of which number of bits must be computed. + integer(I1P):: bits !< Number of bits of i. + integer(I1P):: mold(1) !< "Molding" dummy variable for bits counting. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + bits = size(transfer(i,mold))*8_I1P + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction bit_size_R4P + +#ifdef r16p + !> @brief Function 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 +#endif + + !> @brief Function 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 Function 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 Function 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 Function 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 Function 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 Function 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 + +#ifdef r16p + !> @brief Function 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 +#endif + + !> @brief Function 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 Function 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 Function 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 Function 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 Function 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 Function 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 Function 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 Function 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 Function 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 Function 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 + +#ifdef r16p + !> @brief Function 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 +#endif + + !> @brief Function 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 Function 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 Function 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 Function 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 Function 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 Function 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 + !> @} + + !> 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 +#ifdef r16p + BIR16P = bit_size(i=MaxR16P) ; BYR16P = BIR16P/8_I1P +#endif + BIR8P = bit_size(i=MaxR8P) ; BYR8P = BIR8P/8_I1P + BIR4P = bit_size(i=MaxR4P) ; BYR4P = BIR4P/8_I1P + BIR_P = bit_size(i=MaxR_P) ; BYR_P = BIR_P/8_I1P + 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() + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + call IR_init + ! printing informations + if (endian==endianL) then + write(stdout,'(A)') ' This architecture has LITTLE Endian bit ordering' + else + write(stdout,'(A)') ' This architecture has BIG Endian bit ordering' + endif + write(stdout,'(A)') ' Reals kind precision definition' +#ifdef r16p + write(stdout,'(A,I2,A,I2)') ' R16P Kind "',R16P,'" | FR16P format "'//FR16P//'" | DR16P chars ',DR16P +#endif + write(stdout,'(A,I2,A,I2)') ' R8P Kind "',R8P, '" | FR8P format "'//FR8P// '" | DR8P chars ',DR8P + write(stdout,'(A,I2,A,I2)') ' R4P Kind "',R4P, '" | FR4P format "'//FR4P//'" | DR4P chars ',DR4P + write(stdout,'(A)') ' Integers kind precision definition' + write(stdout,'(A,I2,A,I2)') ' I8P Kind "',I8P,'" | FI8P format "'//FI8P// '" | DI8P chars ',DI8P + write(stdout,'(A,I2,A,I2)') ' I4P Kind "',I4P,'" | FI4P format "'//FI4P// '" | DI4P chars ',DI4P + write(stdout,'(A,I2,A,I2)') ' I2P Kind "',I2P,'" | FI2P format "'//FI2P//'" | DI2P chars ',DI2P + write(stdout,'(A,I2,A,I2)') ' I1P Kind "',I1P,'" | FI1P format "'//FI1P//'" | DI1P chars ',DI1P + write(stdout,'(A)') ' Reals minimum and maximum values' +#ifdef r16p + write(stdout,'(A)') ' MinR16P "'//trim(str(n=MinR16P))//'" | MaxR16P "'//trim(str(n=MaxR16P))//'"' +#endif + write(stdout,'(A)') ' MinR8P "'//trim(str(n=MinR8P))//'" | MaxR8P "'//trim(str(n=MaxR8P))//'"' + write(stdout,'(A)') ' MinR4P "'//trim(str(n=MinR4P))//'" | MaxR4P "'//trim(str(n=MaxR4P))//'"' + write(stdout,'(A)') ' Reals bits/bytes sizes' +#ifdef r16p + write(stdout,'(A,I2,A,I2,A)') ' R16P bits "',BIR16P,'", bytes "',BYR16P,'"' +#endif + write(stdout,'(A,I2,A,I2,A)') ' R8P bits "',BIR8P,'", bytes "',BYR8P,'"' + write(stdout,'(A,I2,A,I2,A)') ' R4P bits "',BIR4P,'", bytes "',BYR4P,'"' + write(stdout,'(A,I2,A,I2,A)') ' R_P bits "',BIR_P,'", bytes "',BYR_P,'"' + write(stdout,'(A)') ' Integers minimum and maximum values' + write(stdout,'(A)') ' MinI8P "'//trim(str(n=MinI8P))//'" | MaxI8P "'//trim(str(n=MaxI8P))//'"' + write(stdout,'(A)') ' MinI4P "'//trim(str(n=MinI4P))//'" | MaxI4P "'//trim(str(n=MaxI4P))//'"' + write(stdout,'(A)') ' MinI2P "'//trim(str(n=MinI2P))//'" | MaxI2P "'//trim(str(n=MaxI2P))//'"' + write(stdout,'(A)') ' MinI1P "'//trim(str(n=MinI1P))//'" | MaxI1P "'//trim(str(n=MaxI1P))//'"' + write(stdout,'(A)') ' Integers bits/bytes sizes' + write(stdout,'(A,I2,A,I2,A)') ' I8P bits "',BII8P,'", bytes "',BYI8P,'"' + write(stdout,'(A,I2,A,I2,A)') ' I4P bits "',BII4P,'", bytes "',BYI4P,'"' + write(stdout,'(A,I2,A,I2,A)') ' I2P bits "',BII2P,'", bytes "',BYI2P,'"' + write(stdout,'(A,I2,A,I2,A)') ' I1P bits "',BII1P,'", bytes "',BYI1P,'"' + write(stdout,'(A,I2,A,I2,A)') ' I_P bits "',BII_P,'", bytes "',BYI_P,'"' + write(stdout,'(A)') ' Machine precisions' +#ifdef r16p + write(stdout,'(A,'//FR16P//')') ' ZeroR16 "',ZeroR16 +#endif + write(stdout,'(A,'//FR8P// ')') ' ZeroR8 "',ZeroR8 + write(stdout,'(A,'//FR4P// ')') ' ZeroR4 "',ZeroR4 + !--------------------------------------------------------------------------------------------------------------------------------- + endsubroutine IR_Print +endmodule IR_Precision diff --git a/lib/Lib_VTK_IO.f90 b/lib/Lib_VTK_IO.f90 new file mode 100644 index 000000000..054327ffc --- /dev/null +++ b/lib/Lib_VTK_IO.f90 @@ -0,0 +1,3165 @@ +!> @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) +!> 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 (native Fortran scalar, vector +!> and matrix). +!> +!> 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, but it is not thread-safe (e.g. race conditions occur into OpenMP +!> parallel framework). +!> +!> 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 Lib_VTK_IO 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 every different inputs type. +!> Dynamic dispatching is based on the internal kind-precision 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-03-28 +!> @par News +!> - 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. +!> @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 Array-Reshape: \n Fortran allows automatic reshape of arrays, e.g. 2D array can be automatically (in the +!> function calling) transformed to a 1D array with the same number of element of 2D array. The use of +!> dynamic dispatching for @libvtk functions by means of generic interfaces had disable this feature: +!> dynamic dispatching use the array-shape information to detect, at compile-time, +!> the correct function to be called inside the generic interface functions. Thus automatic reshaping +!> of arrays at calling function phase is not allowed. \n +!> Instead an explicit reshape can be used by means of the Fortran built-in function \em reshape. +!> As an example considering a call to the generic function \em VTK_VAR_XML an explicit array reshape +!> could be: \n \n +!> E_IO = VTK_VAR_XML(NC_NN=nn,varname='u',var=\b reshape(u(ni1:ni2,nj1:nj2,nk1:nk2),(/nn/))) \n \n +!> where built in function \em reshape has explicitly being used in the calling to VTK_VAR_XML. +!> @bug XML-Efficiency: \n This is not properly a bug. There is an inefficiency when saving XML binary file. To write XML +!> binary @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 data. This approach is not +!> efficient. +!> @bug Thread-Safe: \n The @libvtk is not thread-safe: if used into a parallel multi-thread framework, e.g. OpenMP threads, +!> the IO operations are not safe and race conditions with unpredictable results happen. +!> @ingroup Lib_VTK_IOLibrary +module Lib_VTK_IO +!----------------------------------------------------------------------------------------------------------------------------------- +USE IR_Precision ! Integers and reals precision definition. +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 mesh with different topologies in VTK-legacy standard. +!> VTK_GEO is an interface to 8 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, & ! real(R8P) UNSTRUCTURED_GRID + VTK_GEO_UNST_R4, & ! real(R4P) UNSTRUCTURED_GRID + VTK_GEO_STRP_R8, & ! real(R8P) STRUCTURED_POINTS + VTK_GEO_STRP_R4, & ! real(R4P) STRUCTURED_POINTS + VTK_GEO_STRG_R8, & ! real(R8P) STRUCTURED_GRID + VTK_GEO_STRG_R4, & ! real(R4P) STRUCTURED_GRID + 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 +!> @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 7 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 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_R4, & ! real(R4P) StructuredGrid + VTK_GEO_XML_STRG_R8, & ! real(R8P) StructuredGrid + VTK_GEO_XML_RECT_R8, & ! real(R8P) RectilinearGrid + VTK_GEO_XML_RECT_R4, & ! real(R4P) RectilinearGrid + VTK_GEO_XML_UNST_R8, & ! real(R8P) UnstructuredGrid + VTK_GEO_XML_UNST_R4, & ! real(R4P) UnstructuredGrid + 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 18 different functions, there are 6 functions for scalar variables, 6 functions for vectorial +!> variables and 6 functions for list variables: for all of 3 types of data the precision can be R8P, R4P, I8P, I4P, I2P and I1P. +!> 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(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_R8, & ! real(R8P) scalar + VTK_VAR_XML_SCAL_R4, & ! real(R4P) scalar + VTK_VAR_XML_SCAL_I8, & ! integer(I8P) scalar + VTK_VAR_XML_SCAL_I4, & ! integer(I4P) scalar + VTK_VAR_XML_SCAL_I2, & ! integer(I2P) scalar + VTK_VAR_XML_SCAL_I1, & ! integer(I1P) scalar + VTK_VAR_XML_VECT_R8, & ! real(R8P) vectorial + VTK_VAR_XML_VECT_R4, & ! real(R4P) vectorial + VTK_VAR_XML_VECT_I8, & ! integer(I4P) vectorial + VTK_VAR_XML_VECT_I4, & ! integer(I4P) vectorial + VTK_VAR_XML_VECT_I2, & ! integer(I4P) vectorial + VTK_VAR_XML_VECT_I1, & ! integer(I4P) vectorial + VTK_VAR_XML_LIST_R8, & ! real(R8P) list + VTK_VAR_XML_LIST_R4, & ! real(R4P) list + VTK_VAR_XML_LIST_I8, & ! integer(I4P) list + VTK_VAR_XML_LIST_I4, & ! integer(I4P) list + VTK_VAR_XML_LIST_I2, & ! integer(I2P) list + VTK_VAR_XML_LIST_I1 ! integer(I1P) list +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 !< Binary-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. +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 two auxiliary functions that are not connected with the VTK standard. These functions are private and so 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, 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 + 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 vtk(f)%ioffset pointer. + subroutine ioffset_update(N_Byte) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none +#ifdef HUGE + integer(I8P), intent(IN):: N_Byte !< Number of bytes saved. +#else + integer(I4P), intent(IN):: N_Byte !< Number of bytes saved. +#endif + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- +#ifdef HUGE + vtk(f)%ioffset = vtk(f)%ioffset + BYI8P + N_Byte +#else + vtk(f)%ioffset = vtk(f)%ioffset + BYI4P + N_Byte +#endif + return + !--------------------------------------------------------------------------------------------------------------------------------- + endsubroutine ioffset_update + + !> @brief Subroutine for updating (adding and removing elements into) vtk array. + subroutine vtk_update(act) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + character(*), intent(IN):: act !< Action on vtk array: 'ADD' one more element, 'REMOVE' current element file. + 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) + f = Nvtk + else + Nvtk = 1_I4P + allocate(vtk(1:Nvtk)) + f = Nvtk + endif + case('REMOVE') + if (Nvtk>1_I4P) then + allocate(vtk_tmp(1:Nvtk-1)) + if (f==Nvtk) then + vtk_tmp = vtk(1:Nvtk-1) + else + vtk_tmp(1:f-1) = vtk(1 :f-1) + vtk_tmp(f: ) = vtk(f+1: ) + endif + deallocate(vtk) + Nvtk = Nvtk - 1 + allocate(vtk(1:Nvtk)) + vtk = vtk_tmp + deallocate(vtk_tmp) + f = 1_I4P + else + Nvtk = 0_I4P + if (allocated(vtk)) deallocate(vtk) + f = Nvtk + endif + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endsubroutine vtk_update + !> @} + + !> @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 XML file at least for the ascii + !> format (in the binary format @libvtk uses raw-data format that does not produce a well formated 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 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(cf,nx1,nx2,ny1,ny2,nz1,nz2,output_format,filename,mesh_topology) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + 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. + character(*), intent(IN):: output_format !< Output format: ASCII or BINARY. + character(*), intent(IN):: filename !< File name. + character(*), intent(IN):: mesh_topology !< Mesh topology. + 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. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (.not.ir_initialized) call IR_Init + call vtk_update(act='add') + if (present(cf)) cf = f + vtk(f)%topology = trim(mesh_topology) + select case(trim(Upper_Case(output_format))) + case('ASCII') + vtk(f)%f = ascii + open(unit=Get_Unit(vtk(f)%u),file=trim(filename),form='FORMATTED',& + access='SEQUENTIAL',action='WRITE',status='REPLACE',iostat=E_IO) + ! writing header of file + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)'' + if (endian==endianL) then + s_buffer = '' + else + s_buffer = '' + endif + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(f)%indent = 2 + select case(trim(vtk(f)%topology)) + case('RectilinearGrid','StructuredGrid') + s_buffer = repeat(' ',vtk(f)%indent)//'<'//trim(vtk(f)%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(f)%indent)//'<'//trim(vtk(f)%topology)//'>' + endselect + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(f)%indent = vtk(f)%indent + 2 + case('BINARY') + vtk(f)%f = binary + open(unit=Get_Unit(vtk(f)%u),file=trim(filename),form='UNFORMATTED',access='STREAM',action='WRITE',status='REPLACE',iostat=E_IO) + ! writing header of file + write(unit=vtk(f)%u,iostat=E_IO)''//end_rec + if (endian==endianL) then + s_buffer = '' + else + s_buffer = '' + endif + write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(f)%indent = 2 + select case(trim(vtk(f)%topology)) + case('RectilinearGrid','StructuredGrid') + s_buffer = repeat(' ',vtk(f)%indent)//'<'//trim(vtk(f)%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(f)%indent)//'<'//trim(vtk(f)%topology)//'>' + endselect + write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(f)%indent = vtk(f)%indent + 2 + ! opening the SCRATCH file used for appending raw binary data + open(unit=Get_Unit(vtk(f)%ua), form='UNFORMATTED', access='STREAM', action='READWRITE', status='SCRATCH', iostat=E_IO) + vtk(f)%ioffset = 0 ! initializing offset pointer + 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(cf,fld_action) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + character(*), intent(IN):: fld_action !< Field data tag action: OPEN or CLOSE tag. + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (present(cf)) f = cf + select case(trim(Upper_Case(fld_action))) + case('OPEN') + select case(vtk(f)%f) + case(ascii) + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' ; vtk(f)%indent = vtk(f)%indent + 2 + case(binary) + write(unit=vtk(f)%u,iostat=E_IO)repeat(' ',vtk(f)%indent)//''//end_rec ; vtk(f)%indent = vtk(f)%indent + 2 + endselect + case('CLOSE') + select case(vtk(f)%f) + case(ascii) + vtk(f)%indent = vtk(f)%indent - 2 ; write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + case(binary) + vtk(f)%indent = vtk(f)%indent - 2 ; write(unit=vtk(f)%u,iostat=E_IO)repeat(' ',vtk(f)%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(cf,fld,fname) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + real(R8P), intent(IN):: fld !< Field data value. + character(*), intent(IN):: fname !< Field data name. + 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. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (present(cf)) f = cf + select case(vtk(f)%f) + case(ascii) + s_buffer = repeat(' ',vtk(f)%indent)//''//& + trim(str(n=fld))//'' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + case(binary) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec + vtk(f)%N_Byte = BYR8P ; call ioffset_update(vtk(f)%N_Byte) + write(unit=vtk(f)%ua,iostat=E_IO)vtk(f)%N_Byte,'R8',1_I4P + write(unit=vtk(f)%ua,iostat=E_IO)fld + 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(cf,fld,fname) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + real(R4P), intent(IN):: fld !< Field data value. + character(*), intent(IN):: fname !< Field data name. + 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. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (present(cf)) f = cf + select case(vtk(f)%f) + case(ascii) + s_buffer = repeat(' ',vtk(f)%indent)//''//& + trim(str(n=fld))//'' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + case(binary) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec + vtk(f)%N_Byte = BYR4P ; call ioffset_update(vtk(f)%N_Byte) + write(unit=vtk(f)%ua,iostat=E_IO)vtk(f)%N_Byte,'R4',1_I4P + write(unit=vtk(f)%ua,iostat=E_IO)fld + 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(cf,fld,fname) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I8P), intent(IN):: fld !< Field data value. + character(*), intent(IN):: fname !< Field data name. + 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. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (present(cf)) f = cf + select case(vtk(f)%f) + case(ascii) + s_buffer = repeat(' ',vtk(f)%indent)//''// & + trim(str(n=fld))//'' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + case(binary) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec + vtk(f)%N_Byte = BYI8P ; call ioffset_update(vtk(f)%N_Byte) + write(unit=vtk(f)%ua,iostat=E_IO)vtk(f)%N_Byte,'I8',1_I4P + write(unit=vtk(f)%ua,iostat=E_IO)fld + 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(cf,fld,fname) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P), intent(IN):: fld !< Field data value. + character(*), intent(IN):: fname !< Field data name. + 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. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (present(cf)) f = cf + select case(vtk(f)%f) + case(ascii) + s_buffer = repeat(' ',vtk(f)%indent)//''// & + trim(str(n=fld))//'' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + case(binary) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec + vtk(f)%N_Byte = BYI4P ; call ioffset_update(vtk(f)%N_Byte) + write(unit=vtk(f)%ua,iostat=E_IO)vtk(f)%N_Byte,'I4',1_I4P + write(unit=vtk(f)%ua,iostat=E_IO)fld + 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(cf,fld,fname) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I2P), intent(IN):: fld !< Field data value. + character(*), intent(IN):: fname !< Field data name. + 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. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (present(cf)) f = cf + select case(vtk(f)%f) + case(ascii) + s_buffer = repeat(' ',vtk(f)%indent)//''// & + trim(str(n=fld))//'' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + case(binary) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec + vtk(f)%N_Byte = BYI2P ; call ioffset_update(vtk(f)%N_Byte) + write(unit=vtk(f)%ua,iostat=E_IO)vtk(f)%N_Byte,'I2',1_I4P + write(unit=vtk(f)%ua,iostat=E_IO)fld + 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(cf,fld,fname) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I1P), intent(IN):: fld !< Field data value. + character(*), intent(IN):: fname !< Field data name. + 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. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (present(cf)) f = cf + select case(vtk(f)%f) + case(ascii) + s_buffer = repeat(' ',vtk(f)%indent)//''// & + trim(str(n=fld))//'' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + case(binary) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec + vtk(f)%N_Byte = BYI1P ; call ioffset_update(vtk(f)%N_Byte) + write(unit=vtk(f)%ua,iostat=E_IO)vtk(f)%N_Byte,'I1',1_I4P + write(unit=vtk(f)%ua,iostat=E_IO)fld + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_FLD_XML_I1 + + !> Function for saving mesh with \b StructuredGrid topology (R8P). + !> @return E_IO: integer(I4P) error flag + function VTK_GEO_XML_STRG_R8(cf,nx1,nx2,ny1,ny2,nz1,nz2,NN,X,Y,Z) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + 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:NN) !< X coordinates. + real(R8P), intent(IN):: Y(1:NN) !< Y coordinates. + real(R8P), intent(IN):: Z(1:NN) !< Z coordinates. + 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):: n1 !< Counter. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (present(cf)) f = cf + select case(vtk(f)%f) + case(ascii) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(f)%indent = vtk(f)%indent + 2 + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' ; vtk(f)%indent = vtk(f)%indent + 2 + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + write(unit=vtk(f)%u,fmt='(3('//FR8P//',1X))',iostat=E_IO)(X(n1),Y(n1),Z(n1),n1=1,NN) + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' ; vtk(f)%indent = vtk(f)%indent - 2 + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + case(binary) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(f)%indent = vtk(f)%indent + 2 + write(unit=vtk(f)%u,iostat=E_IO)repeat(' ',vtk(f)%indent)//''//end_rec ; vtk(f)%indent = vtk(f)%indent + 2 + s_buffer = repeat(' ',vtk(f)%indent)// & + '' + write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec + vtk(f)%N_Byte = 3*NN*BYR8P ; call ioffset_update(vtk(f)%N_Byte) + write(unit=vtk(f)%ua,iostat=E_IO)vtk(f)%N_Byte,'R8',3*NN + write(unit=vtk(f)%ua,iostat=E_IO)(X(n1),Y(n1),Z(n1),n1=1,NN) + vtk(f)%indent = vtk(f)%indent - 2 ; write(unit=vtk(f)%u,iostat=E_IO)repeat(' ',vtk(f)%indent)//''//end_rec + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_GEO_XML_STRG_R8 + + !> Function for saving mesh with \b StructuredGrid topology (R4P). + !> @return E_IO: integer(I4P) error flag + function VTK_GEO_XML_STRG_R4(cf,nx1,nx2,ny1,ny2,nz1,nz2,NN,X,Y,Z) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + 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:NN) !< X coordinates. + real(R4P), intent(IN):: Y(1:NN) !< Y coordinates. + real(R4P), intent(IN):: Z(1:NN) !< Z coordinates. + 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):: n1 !< Counter. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (present(cf)) f = cf + select case(vtk(f)%f) + case(ascii) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(f)%indent = vtk(f)%indent + 2 + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' ; vtk(f)%indent = vtk(f)%indent + 2 + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + write(unit=vtk(f)%u,fmt='(3('//FR4P//',1X))',iostat=E_IO)(X(n1),Y(n1),Z(n1),n1=1,NN) + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' ; vtk(f)%indent = vtk(f)%indent - 2 + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + case(binary) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(f)%indent = vtk(f)%indent + 2 + write(unit=vtk(f)%u,iostat=E_IO)repeat(' ',vtk(f)%indent)//''//end_rec ; vtk(f)%indent = vtk(f)%indent + 2 + s_buffer = repeat(' ',vtk(f)%indent)// & + '' + write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec + vtk(f)%N_Byte = 3*NN*BYR4P ; call ioffset_update(vtk(f)%N_Byte) + write(unit=vtk(f)%ua,iostat=E_IO)vtk(f)%N_Byte,'R4',3*NN + write(unit=vtk(f)%ua,iostat=E_IO)(X(n1),Y(n1),Z(n1),n1=1,NN) + vtk(f)%indent = vtk(f)%indent - 2 ; write(unit=vtk(f)%u,iostat=E_IO)repeat(' ',vtk(f)%indent)//''//end_rec + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_GEO_XML_STRG_R4 + + !> Function for saving mesh with \b RectilinearGrid topology (R8P). + !> @return E_IO: integer(I4P) error flag + function VTK_GEO_XML_RECT_R8(cf,nx1,nx2,ny1,ny2,nz1,nz2,X,Y,Z) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + 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):: 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):: n1 !< Counter. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (present(cf)) f = cf + select case(vtk(f)%f) + case(ascii) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(f)%indent = vtk(f)%indent + 2 + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' ; vtk(f)%indent = vtk(f)%indent + 2 + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,fmt=FR8P, iostat=E_IO)(X(n1),n1=nx1,nx2) + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,fmt=FR8P, iostat=E_IO)(Y(n1),n1=ny1,ny2) + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,fmt=FR8P, iostat=E_IO)(Z(n1),n1=nz1,nz2) + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' ; vtk(f)%indent = vtk(f)%indent - 2 + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + case(binary) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(f)%indent = vtk(f)%indent + 2 + write(unit=vtk(f)%u,iostat=E_IO)repeat(' ',vtk(f)%indent)//''//end_rec ; vtk(f)%indent = vtk(f)%indent + 2 + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec + vtk(f)%N_Byte = (nx2-nx1+1)*BYR8P ; call ioffset_update(vtk(f)%N_Byte) + write(unit=vtk(f)%ua,iostat=E_IO)vtk(f)%N_Byte,'R8',(nx2-nx1+1) + write(unit=vtk(f)%ua,iostat=E_IO)(X(n1),n1=nx1,nx2) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec + vtk(f)%N_Byte = (ny2-ny1+1)*BYR8P ; call ioffset_update(vtk(f)%N_Byte) + write(unit=vtk(f)%ua,iostat=E_IO)vtk(f)%N_Byte,'R8',(ny2-ny1+1) + write(unit=vtk(f)%ua,iostat=E_IO)(Y(n1),n1=ny1,ny2) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec + vtk(f)%N_Byte = (nz2-nz1+1)*BYR8P ; call ioffset_update(vtk(f)%N_Byte) + write(unit=vtk(f)%ua,iostat=E_IO)vtk(f)%N_Byte,'R8',(nz2-nz1+1) + write(unit=vtk(f)%ua,iostat=E_IO)(Z(n1),n1=nz1,nz2) + vtk(f)%indent = vtk(f)%indent - 2 ; write(unit=vtk(f)%u,iostat=E_IO)repeat(' ',vtk(f)%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(cf,nx1,nx2,ny1,ny2,nz1,nz2,X,Y,Z) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + 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):: 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):: n1 !< Counter. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (present(cf)) f = cf + select case(vtk(f)%f) + case(ascii) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(f)%indent = vtk(f)%indent + 2 + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' ; vtk(f)%indent = vtk(f)%indent + 2 + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,fmt=FR4P, iostat=E_IO)(X(n1),n1=nx1,nx2) + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,fmt=FR4P, iostat=E_IO)(Y(n1),n1=ny1,ny2) + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,fmt=FR4P, iostat=E_IO)(Z(n1),n1=nz1,nz2) + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' ; vtk(f)%indent = vtk(f)%indent - 2 + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + case(binary) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(f)%indent = vtk(f)%indent + 2 + write(unit=vtk(f)%u,iostat=E_IO)repeat(' ',vtk(f)%indent)//''//end_rec ; vtk(f)%indent = vtk(f)%indent + 2 + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec + vtk(f)%N_Byte = (nx2-nx1+1)*BYR4P ; call ioffset_update(vtk(f)%N_Byte) + write(unit=vtk(f)%ua,iostat=E_IO)vtk(f)%N_Byte,'R4',(nx2-nx1+1) + write(unit=vtk(f)%ua,iostat=E_IO)(X(n1),n1=nx1,nx2) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec + vtk(f)%N_Byte = (ny2-ny1+1)*BYR4P ; call ioffset_update(vtk(f)%N_Byte) + write(unit=vtk(f)%ua,iostat=E_IO)vtk(f)%N_Byte,'R4',(ny2-ny1+1) + write(unit=vtk(f)%ua,iostat=E_IO)(Y(n1),n1=ny1,ny2) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec + vtk(f)%N_Byte = (nz2-nz1+1)*BYR4P ; call ioffset_update(vtk(f)%N_Byte) + write(unit=vtk(f)%ua,iostat=E_IO)vtk(f)%N_Byte,'R4',(nz2-nz1+1) + write(unit=vtk(f)%ua,iostat=E_IO)(Z(n1),n1=nz1,nz2) + vtk(f)%indent = vtk(f)%indent - 2 ; write(unit=vtk(f)%u,iostat=E_IO)repeat(' ',vtk(f)%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(cf,NN,NC,X,Y,Z) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + 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):: 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):: n1 !< Counter. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (present(cf)) f = cf + select case(vtk(f)%f) + case(ascii) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(f)%indent = vtk(f)%indent + 2 + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' ; vtk(f)%indent = vtk(f)%indent + 2 + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + write(unit=vtk(f)%u,fmt='(3('//FR8P//',1X))',iostat=E_IO)(X(n1),Y(n1),Z(n1),n1=1,NN) + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' ; vtk(f)%indent = vtk(f)%indent - 2 + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + case(binary) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(f)%indent = vtk(f)%indent + 2 + write(unit=vtk(f)%u,iostat=E_IO)repeat(' ',vtk(f)%indent)//''//end_rec ; vtk(f)%indent = vtk(f)%indent + 2 + s_buffer = repeat(' ',vtk(f)%indent)// & + '' + write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec + vtk(f)%N_Byte = 3*NN*BYR8P ; call ioffset_update(vtk(f)%N_Byte) + write(unit=vtk(f)%ua,iostat=E_IO)vtk(f)%N_Byte,'R8',3*NN + write(unit=vtk(f)%ua,iostat=E_IO)(X(n1),Y(n1),Z(n1),n1=1,NN) + vtk(f)%indent = vtk(f)%indent - 2 ; write(unit=vtk(f)%u,iostat=E_IO)repeat(' ',vtk(f)%indent)//''//end_rec + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_GEO_XML_UNST_R8 + + !> Function for saving mesh with \b UnstructuredGrid topology (R4P). + !> @return E_IO: integer(I4P) error flag + function VTK_GEO_XML_UNST_R4(cf,NN,NC,X,Y,Z) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + 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):: 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):: n1 !< Counter. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (present(cf)) f = cf + select case(vtk(f)%f) + case(ascii) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(f)%indent = vtk(f)%indent + 2 + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' ; vtk(f)%indent = vtk(f)%indent + 2 + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + write(unit=vtk(f)%u,fmt='(3('//FR4P//',1X))',iostat=E_IO)(X(n1),Y(n1),Z(n1),n1=1,NN) + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' ; vtk(f)%indent = vtk(f)%indent - 2 + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + case(binary) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(f)%indent = vtk(f)%indent + 2 + write(unit=vtk(f)%u,iostat=E_IO)repeat(' ',vtk(f)%indent)//''//end_rec ; vtk(f)%indent = vtk(f)%indent + 2 + s_buffer = repeat(' ',vtk(f)%indent)// & + '' + write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec + vtk(f)%N_Byte = 3*NN*BYR4P ; call ioffset_update(vtk(f)%N_Byte) + write(unit=vtk(f)%ua,iostat=E_IO)vtk(f)%N_Byte,'R4',3*NN + write(unit=vtk(f)%ua,iostat=E_IO)(X(n1),Y(n1),Z(n1),n1=1,NN) + vtk(f)%indent = vtk(f)%indent - 2 ; write(unit=vtk(f)%u,iostat=E_IO)repeat(' ',vtk(f)%indent)//''//end_rec + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_GEO_XML_UNST_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. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (present(cf)) f = cf + vtk(f)%indent = vtk(f)%indent - 2 + select case(vtk(f)%f) + case(ascii) + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + case(binary) + write(unit=vtk(f)%u,iostat=E_IO)repeat(' ',vtk(f)%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(cf,NC,connect,offset,cell_type) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P), intent(IN):: NC !< Number of cells. + integer(I4P), intent(IN):: connect(:) !< Mesh connectivity. + integer(I4P), intent(IN):: offset(1:NC) !< Cell offset. + integer(I1P), intent(IN):: cell_type(1:NC) !< VTK cell type. + 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):: n1 !< Counter. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (present(cf)) f = cf + select case(vtk(f)%f) + case(ascii) + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' ; vtk(f)%indent = vtk(f)%indent + 2 + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//& + '' + write(unit=vtk(f)%u,fmt=FI4P, iostat=E_IO)(connect(n1),n1=1,size(connect)) + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,fmt=FI4P, iostat=E_IO)(offset(n1),n1=1,NC) + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,fmt=FI1P, iostat=E_IO)(cell_type(n1),n1=1,NC) + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' ; vtk(f)%indent = vtk(f)%indent - 2 + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + case(binary) + write(unit=vtk(f)%u,iostat=E_IO)repeat(' ',vtk(f)%indent)//''//end_rec ; vtk(f)%indent = vtk(f)%indent + 2 + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec + vtk(f)%N_Byte = size(connect)*BYI4P ; call ioffset_update(vtk(f)%N_Byte) + write(unit=vtk(f)%ua,iostat=E_IO)vtk(f)%N_Byte,'I4',size(connect) + write(unit=vtk(f)%ua,iostat=E_IO)(connect(n1),n1=1,size(connect)) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec + vtk(f)%N_Byte = NC*BYI4P ; call ioffset_update(vtk(f)%N_Byte) + write(unit=vtk(f)%ua,iostat=E_IO)vtk(f)%N_Byte,'I4',NC + write(unit=vtk(f)%ua,iostat=E_IO)(offset(n1),n1=1,NC) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec + vtk(f)%N_Byte = NC*BYI1P ; call ioffset_update(vtk(f)%N_Byte) + write(unit=vtk(f)%ua,iostat=E_IO)vtk(f)%N_Byte,'I1',NC + write(unit=vtk(f)%ua,iostat=E_IO)(cell_type(n1),n1=1,NC) + vtk(f)%indent = vtk(f)%indent - 2 ; write(unit=vtk(f)%u,iostat=E_IO)repeat(' ',vtk(f)%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(cf,var_location,var_block_action) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + 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):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (present(cf)) f = cf + select case(vtk(f)%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(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' ; vtk(f)%indent = vtk(f)%indent + 2 + case('CLOSE') + vtk(f)%indent = vtk(f)%indent - 2 ; write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + endselect + case('NODE') + select case(trim(Upper_Case(var_block_action))) + case('OPEN') + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' ; vtk(f)%indent = vtk(f)%indent + 2 + case('CLOSE') + vtk(f)%indent = vtk(f)%indent - 2 ; write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + endselect + endselect + case(binary) + select case(trim(Upper_Case(var_location))) + case('CELL') + select case(trim(Upper_Case(var_block_action))) + case('OPEN') + write(unit=vtk(f)%u,iostat=E_IO)repeat(' ',vtk(f)%indent)//''//end_rec ; vtk(f)%indent = vtk(f)%indent + 2 + case('CLOSE') + vtk(f)%indent = vtk(f)%indent - 2 ; write(unit=vtk(f)%u,iostat=E_IO)repeat(' ',vtk(f)%indent)//''//end_rec + endselect + case('NODE') + select case(trim(Upper_Case(var_block_action))) + case('OPEN') + write(unit=vtk(f)%u,iostat=E_IO)repeat(' ',vtk(f)%indent)//''//end_rec ; vtk(f)%indent = vtk(f)%indent + 2 + case('CLOSE') + vtk(f)%indent = vtk(f)%indent - 2 ; write(unit=vtk(f)%u,iostat=E_IO)repeat(' ',vtk(f)%indent)//''//end_rec + endselect + endselect + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_DAT_XML + + !> @ingroup Lib_VTK_IOPrivateProcedure + !> @{ + + !> Function for saving field of scalar variable (R8P). + !> @return E_IO: integer(I4P) error flag + function VTK_VAR_XML_SCAL_R8(cf,NC_NN,varname,var) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. + character(*), intent(IN):: varname !< Variable name. + real(R8P), intent(IN):: var(1:NC_NN) !< Variable to be saved. + 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):: n1 !< Counter. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (present(cf)) f = cf + select case(vtk(f)%f) + case(ascii) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + write(unit=vtk(f)%u,fmt=FR8P,iostat=E_IO)(var(n1),n1=1,NC_NN) + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + case(binary) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec + vtk(f)%N_Byte = NC_NN*BYR8P ; call ioffset_update(vtk(f)%N_Byte) + write(unit=vtk(f)%ua,iostat=E_IO)vtk(f)%N_Byte,'R8',NC_NN + write(unit=vtk(f)%ua,iostat=E_IO)(var(n1),n1=1,NC_NN) + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_VAR_XML_SCAL_R8 + + !> Function for saving field of scalar variable (R4P). + !> @return E_IO: integer(I4P) error flag + function VTK_VAR_XML_SCAL_R4(cf,NC_NN,varname,var) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. + character(*), intent(IN):: varname !< Variable name. + real(R4P), intent(IN):: var(1:NC_NN) !< Variable to be saved. + 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):: n1 !< Counter. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (present(cf)) f = cf + select case(vtk(f)%f) + case(ascii) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + write(unit=vtk(f)%u,fmt=FR4P,iostat=E_IO)(var(n1),n1=1,NC_NN) + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + case(binary) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec + vtk(f)%N_Byte = NC_NN*BYR4P ; call ioffset_update(vtk(f)%N_Byte) + write(unit=vtk(f)%ua,iostat=E_IO)vtk(f)%N_Byte,'R4',NC_NN + write(unit=vtk(f)%ua,iostat=E_IO)(var(n1),n1=1,NC_NN) + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_VAR_XML_SCAL_R4 + + !> Function for saving field of scalar variable (I8P). + !> @return E_IO: integer(I4P) error flag + function VTK_VAR_XML_SCAL_I8(cf,NC_NN,varname,var) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. + character(*), intent(IN):: varname !< Variable name. + integer(I8P), intent(IN):: var(1:NC_NN) !< Variable to be saved. + 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):: n1 !< Counter. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (present(cf)) f = cf + select case(vtk(f)%f) + case(ascii) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + write(unit=vtk(f)%u,fmt=FI8P,iostat=E_IO)(var(n1),n1=1,NC_NN) + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)'' + case(binary) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec + vtk(f)%N_Byte = NC_NN*BYI8P ; call ioffset_update(vtk(f)%N_Byte) + write(unit=vtk(f)%ua,iostat=E_IO)vtk(f)%N_Byte,'I8',NC_NN + write(unit=vtk(f)%ua,iostat=E_IO)(var(n1),n1=1,NC_NN) + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_VAR_XML_SCAL_I8 + + !> Function for saving field of scalar variable (I4P). + !> @return E_IO: integer(I4P) error flag + function VTK_VAR_XML_SCAL_I4(cf,NC_NN,varname,var) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. + character(*), intent(IN):: varname !< Variable name. + integer(I4P), intent(IN):: var(1:NC_NN) !< Variable to be saved. + 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):: n1 !< Counter. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (present(cf)) f = cf + select case(vtk(f)%f) + case(ascii) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + write(unit=vtk(f)%u,fmt=FI4P,iostat=E_IO)(var(n1),n1=1,NC_NN) + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + case(binary) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec + vtk(f)%N_Byte = NC_NN*BYI4P ; call ioffset_update(vtk(f)%N_Byte) + write(unit=vtk(f)%ua,iostat=E_IO)vtk(f)%N_Byte,'I4',NC_NN + write(unit=vtk(f)%ua,iostat=E_IO)(var(n1),n1=1,NC_NN) + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_VAR_XML_SCAL_I4 + + !> Function for saving field of scalar variable (I2P). + !> @return E_IO: integer(I4P) error flag + function VTK_VAR_XML_SCAL_I2(cf,NC_NN,varname,var) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. + character(*), intent(IN):: varname !< Variable name. + integer(I2P), intent(IN):: var(1:NC_NN) !< Variable to be saved. + 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):: n1 !< Counter. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (present(cf)) f = cf + select case(vtk(f)%f) + case(ascii) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + write(unit=vtk(f)%u,fmt=FI2P, iostat=E_IO)(var(n1),n1=1,NC_NN) + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + case(binary) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec + vtk(f)%N_Byte = NC_NN*BYI2P ; call ioffset_update(vtk(f)%N_Byte) + write(unit=vtk(f)%ua,iostat=E_IO)vtk(f)%N_Byte,'I2',NC_NN + write(unit=vtk(f)%ua,iostat=E_IO)(var(n1),n1=1,NC_NN) + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_VAR_XML_SCAL_I2 + + !> Function for saving field of scalar variable (I1P). + !> @return E_IO: integer(I4P) error flag + function VTK_VAR_XML_SCAL_I1(cf,NC_NN,varname,var) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. + character(*), intent(IN):: varname !< Variable name. + integer(I1P), intent(IN):: var(1:NC_NN) !< Variable to be saved. + 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):: n1 !< Counter. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (present(cf)) f = cf + select case(vtk(f)%f) + case(ascii) + s_buffer=repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + write(unit=vtk(f)%u,fmt=FI1P, iostat=E_IO)(var(n1),n1=1,NC_NN) + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + case(binary) + s_buffer=repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec + vtk(f)%N_Byte = NC_NN*BYI1P ; call ioffset_update(vtk(f)%N_Byte) + write(unit=vtk(f)%ua,iostat=E_IO)vtk(f)%N_Byte,'I1',NC_NN + write(unit=vtk(f)%ua,iostat=E_IO)(var(n1),n1=1,NC_NN) + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_VAR_XML_SCAL_I1 + + !> Function for saving field of vectorial variable (R8P). + !> @return E_IO: integer(I4P) error flag + function VTK_VAR_XML_VECT_R8(cf,NC_NN,varname,varX,varY,varZ) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. + character(*), intent(IN):: varname !< Variable name. + real(R8P), intent(IN):: varX(1:NC_NN) !< X component. + real(R8P), intent(IN):: varY(1:NC_NN) !< Y component. + real(R8P), intent(IN):: varZ(1:NC_NN) !< Z component. + 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):: n1 !< Counter. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (present(cf)) f = cf + select case(vtk(f)%f) + case(ascii) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + write(unit=vtk(f)%u,fmt='(3('//FR8P//',1X))',iostat=E_IO)(varX(n1),varY(n1),varZ(n1),n1=1,NC_NN) + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + case(binary) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec + vtk(f)%N_Byte = 3*NC_NN*BYR8P ; call ioffset_update(vtk(f)%N_Byte) + write(unit=vtk(f)%ua,iostat=E_IO)vtk(f)%N_Byte,'R8',3*NC_NN + write(unit=vtk(f)%ua,iostat=E_IO)(varX(n1),varY(n1),varZ(n1),n1=1,NC_NN) + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_VAR_XML_VECT_R8 + + !> Function for saving field of vectorial variable (R4P). + !> @return E_IO: integer(I4P) error flag + function VTK_VAR_XML_VECT_R4(cf,NC_NN,varname,varX,varY,varZ) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. + character(*), intent(IN):: varname !< Variable name. + real(R4P), intent(IN):: varX(1:NC_NN) !< X component. + real(R4P), intent(IN):: varY(1:NC_NN) !< Y component. + real(R4P), intent(IN):: varZ(1:NC_NN) !< Z component. + 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):: n1 !< Counter. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (present(cf)) f = cf + select case(vtk(f)%f) + case(ascii) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + write(unit=vtk(f)%u,fmt='(3('//FR4P//',1X))',iostat=E_IO)(varX(n1),varY(n1),varZ(n1),n1=1,NC_NN) + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + case(binary) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec + vtk(f)%N_Byte = 3*NC_NN*BYR4P ; call ioffset_update(vtk(f)%N_Byte) + write(unit=vtk(f)%ua,iostat=E_IO)vtk(f)%N_Byte,'R4',3*NC_NN + write(unit=vtk(f)%ua,iostat=E_IO)(varX(n1),varY(n1),varZ(n1),n1=1,NC_NN) + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_VAR_XML_VECT_R4 + + !> Function for saving field of vectorial variable (I8P). + !> @return E_IO: integer(I4P) error flag + function VTK_VAR_XML_VECT_I8(cf,NC_NN,varname,varX,varY,varZ) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. + character(*), intent(IN):: varname !< Variable name. + integer(I8P), intent(IN):: varX(1:NC_NN) !< X component. + integer(I8P), intent(IN):: varY(1:NC_NN) !< Y component. + integer(I8P), intent(IN):: varZ(1:NC_NN) !< Z component. + 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):: n1 !< Counter. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (present(cf)) f = cf + select case(vtk(f)%f) + case(ascii) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + write(unit=vtk(f)%u,fmt='(3('//FI8P//',1X))',iostat=E_IO)(varX(n1),varY(n1),varZ(n1),n1=1,NC_NN) + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + case(binary) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec + vtk(f)%N_Byte = 3*NC_NN*BYI8P ; call ioffset_update(vtk(f)%N_Byte) + write(unit=vtk(f)%ua,iostat=E_IO)vtk(f)%N_Byte,'I8',3*NC_NN + write(unit=vtk(f)%ua,iostat=E_IO)(varX(n1),varY(n1),varZ(n1),n1=1,NC_NN) + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_VAR_XML_VECT_I8 + + !> Function for saving field of vectorial variable (I4P). + !> @return E_IO: integer(I4P) error flag + function VTK_VAR_XML_VECT_I4(cf,NC_NN,varname,varX,varY,varZ) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. + character(*), intent(IN):: varname !< Variable name. + integer(I4P), intent(IN):: varX(1:NC_NN) !< X component. + integer(I4P), intent(IN):: varY(1:NC_NN) !< Y component. + integer(I4P), intent(IN):: varZ(1:NC_NN) !< Z component. + 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):: n1 !< Counter. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (present(cf)) f = cf + select case(vtk(f)%f) + case(ascii) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + write(unit=vtk(f)%u,fmt='(3('//FI4P//',1X))',iostat=E_IO)(varX(n1),varY(n1),varZ(n1),n1=1,NC_NN) + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + case(binary) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec + vtk(f)%N_Byte = 3*NC_NN*BYI4P ; call ioffset_update(vtk(f)%N_Byte) + write(unit=vtk(f)%ua,iostat=E_IO)vtk(f)%N_Byte,'I4',3*NC_NN + write(unit=vtk(f)%ua,iostat=E_IO)(varX(n1),varY(n1),varZ(n1),n1=1,NC_NN) + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_VAR_XML_VECT_I4 + + !> Function for saving field of vectorial variable (I2P). + !> @return E_IO: integer(I4P) error flag + function VTK_VAR_XML_VECT_I2(cf,NC_NN,varname,varX,varY,varZ) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. + character(*), intent(IN):: varname !< Variable name. + integer(I2P), intent(IN):: varX(1:NC_NN) !< X component. + integer(I2P), intent(IN):: varY(1:NC_NN) !< Y component. + integer(I2P), intent(IN):: varZ(1:NC_NN) !< Z component. + 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):: n1 !< Counter. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (present(cf)) f = cf + select case(vtk(f)%f) + case(ascii) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + write(unit=vtk(f)%u,fmt='(3('//FI2P//',1X))',iostat=E_IO)(varX(n1),varY(n1),varZ(n1),n1=1,NC_NN) + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + case(binary) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec + vtk(f)%N_Byte = 3*NC_NN*BYI2P ; call ioffset_update(vtk(f)%N_Byte) + write(unit=vtk(f)%ua,iostat=E_IO)vtk(f)%N_Byte,'I2',3*NC_NN + write(unit=vtk(f)%ua,iostat=E_IO)(varX(n1),varY(n1),varZ(n1),n1=1,NC_NN) + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_VAR_XML_VECT_I2 + + !> Function for saving field of vectorial variable (I1P). + !> @return E_IO: integer(I4P) error flag + function VTK_VAR_XML_VECT_I1(cf,NC_NN,varname,varX,varY,varZ) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. + character(*), intent(IN):: varname !< Variable name. + integer(I1P), intent(IN):: varX(1:NC_NN) !< X component. + integer(I1P), intent(IN):: varY(1:NC_NN) !< Y component. + integer(I1P), intent(IN):: varZ(1:NC_NN) !< Z component. + 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):: n1 !< Counter. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (present(cf)) f = cf + select case(vtk(f)%f) + case(ascii) + s_buffer=repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + write(unit=vtk(f)%u,fmt='(3('//FI1P//',1X))',iostat=E_IO)(varX(n1),varY(n1),varZ(n1),n1=1,NC_NN) + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + case(binary) + s_buffer=repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec + vtk(f)%N_Byte = 3*NC_NN*BYI1P + call ioffset_update(vtk(f)%N_Byte) + write(unit=vtk(f)%ua,iostat=E_IO)vtk(f)%N_Byte,'I1',3*NC_NN + write(unit=vtk(f)%ua,iostat=E_IO)(varX(n1),varY(n1),varZ(n1),n1=1,NC_NN) + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_VAR_XML_VECT_I1 + + !> Function for saving field of list variable (R8P). + !> @return E_IO: integer(I4P) error flag + function VTK_VAR_XML_LIST_R8(cf,NC_NN,N_COL,varname,var) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + 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. + 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):: n1,n2 !< Counters. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (present(cf)) f = cf + select case(vtk(f)%f) + case(ascii) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + do n1=1,NC_NN + write(unit=vtk(f)%u,fmt=FR8P,iostat=E_IO)(var(n1,n2),n2=1,N_COL) + enddo + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + case(binary) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec + vtk(f)%N_Byte = N_COL*NC_NN*BYR8P ; call ioffset_update(vtk(f)%N_Byte) + write(unit=vtk(f)%ua,iostat=E_IO)vtk(f)%N_Byte,'R8',N_COL*NC_NN + do n1=1,NC_NN + write(unit=vtk(f)%ua,iostat=E_IO)var(n1,:) + enddo + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_VAR_XML_LIST_R8 + + !> Function for saving field of list variable (R4P). + !> @return E_IO: integer(I4P) error flag + function VTK_VAR_XML_LIST_R4(cf,NC_NN,N_COL,varname,var) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + 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. + 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):: n1,n2 !< Counters. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (present(cf)) f = cf + select case(vtk(f)%f) + case(ascii) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + do n1=1,NC_NN + write(unit=vtk(f)%u,fmt=FR4P,iostat=E_IO)(var(n1,n2),n2=1,N_COL) + enddo + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + case(binary) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec + vtk(f)%N_Byte = N_COL*NC_NN*BYR4P ; call ioffset_update(vtk(f)%N_Byte) + write(unit=vtk(f)%ua,iostat=E_IO)vtk(f)%N_Byte,'R4',N_COL*NC_NN + do n1=1,NC_NN + write(unit=vtk(f)%ua,iostat=E_IO)var(n1,:) + enddo + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_VAR_XML_LIST_R4 + + !> Function for saving field of list variable (I8P). + !> @return E_IO: integer(I4P) error flag + function VTK_VAR_XML_LIST_I8(cf,NC_NN,N_COL,varname,var) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + 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. + 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):: n1,n2 !< Counters. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (present(cf)) f = cf + select case(vtk(f)%f) + case(ascii) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + do n1=1,NC_NN + write(unit=vtk(f)%u,fmt=FI8P,iostat=E_IO)(var(n1,n2),n2=1,N_COL) + enddo + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + case(binary) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec + vtk(f)%N_Byte = N_COL*NC_NN*BYI8P ; call ioffset_update(vtk(f)%N_Byte) + write(unit=vtk(f)%ua,iostat=E_IO)vtk(f)%N_Byte,'I8',N_COL*NC_NN + do n1=1,NC_NN + write(unit=vtk(f)%ua,iostat=E_IO)var(n1,:) + enddo + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_VAR_XML_LIST_I8 + + !> Function for saving field of list variable (I4P). + !> @return E_IO: integer(I4P) error flag + function VTK_VAR_XML_LIST_I4(cf,NC_NN,N_COL,varname,var) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + 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. + 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):: n1,n2 !< Counters. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (present(cf)) f = cf + select case(vtk(f)%f) + case(ascii) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + do n1=1,NC_NN + write(unit=vtk(f)%u,fmt=FI4P,iostat=E_IO)(var(n1,n2),n2=1,N_COL) + enddo + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + case(binary) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec + vtk(f)%N_Byte = N_COL*NC_NN*BYI4P ; call ioffset_update(vtk(f)%N_Byte) + write(unit=vtk(f)%ua,iostat=E_IO)vtk(f)%N_Byte,'I4',N_COL*NC_NN + do n1=1,NC_NN + write(unit=vtk(f)%ua,iostat=E_IO)var(n1,:) + enddo + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_VAR_XML_LIST_I4 + + !> Function for saving field of list variable (I2P). + !> @return E_IO: integer(I4P) error flag + function VTK_VAR_XML_LIST_I2(cf,NC_NN,N_COL,varname,var) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + 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. + 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):: n1,n2 !< Counters. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (present(cf)) f = cf + select case(vtk(f)%f) + case(ascii) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + do n1=1,NC_NN + write(unit=vtk(f)%u,fmt=FI2P,iostat=E_IO)(var(n1,n2),n2=1,N_COL) + enddo + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + case(binary) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec + vtk(f)%N_Byte = N_COL*NC_NN*BYI2P ; call ioffset_update(vtk(f)%N_Byte) + write(unit=vtk(f)%ua,iostat=E_IO)vtk(f)%N_Byte,'I2',N_COL*NC_NN + do n1=1,NC_NN + write(unit=vtk(f)%ua,iostat=E_IO)var(n1,:) + enddo + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_VAR_XML_LIST_I2 + + !> Function for saving field of list variable (I1P). + !> @return E_IO: integer(I4P) error flag + function VTK_VAR_XML_LIST_I1(cf,NC_NN,N_COL,varname,var) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + 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. + 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):: n1,n2 !< Counters. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (present(cf)) f = cf + select case(vtk(f)%f) + case(ascii) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + do n1=1,NC_NN + write(unit=vtk(f)%u,fmt=FI1P,iostat=E_IO)(var(n1,n2),n2=1,N_COL) + enddo + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + case(binary) + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec + vtk(f)%N_Byte = N_COL*NC_NN*BYI1P ; call ioffset_update(vtk(f)%N_Byte) + write(unit=vtk(f)%ua,iostat=E_IO)vtk(f)%N_Byte,'I1',N_COL*NC_NN + do n1=1,NC_NN + write(unit=vtk(f)%ua,iostat=E_IO)var(n1,:) + enddo + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_VAR_XML_LIST_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. +#ifdef HUGE + integer(I8P):: N_v !< Vector dimension. + integer(I8P):: n1 !< Counter. +#else + integer(I4P):: N_v !< Vector dimension. + integer(I4P):: n1 !< Counter. +#endif + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (present(cf)) f = cf + select case(vtk(f)%f) + case(ascii) + vtk(f)%indent = vtk(f)%indent - 2 + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)'' + case(binary) + vtk(f)%indent = vtk(f)%indent - 2 + write(unit =vtk(f)%u, iostat=E_IO)repeat(' ',vtk(f)%indent)//''//end_rec + write(unit =vtk(f)%u, iostat=E_IO)repeat(' ',vtk(f)%indent)//''//end_rec + write(unit =vtk(f)%u, iostat=E_IO)'_' + endfile(unit=vtk(f)%ua,iostat=E_IO) + rewind(unit =vtk(f)%ua,iostat=E_IO) + do + read(unit=vtk(f)%ua,iostat=E_IO,end=100)vtk(f)%N_Byte,var_type,N_v + select case(var_type) + case('R8') + allocate(v_R8(1:N_v)) + read(unit =vtk(f)%ua,iostat=E_IO)(v_R8(n1),n1=1,N_v) + write(unit=vtk(f)%u, iostat=E_IO)int(vtk(f)%N_Byte,I4P),(v_R8(n1),n1=1,N_v) + deallocate(v_R8) + case('R4') + allocate(v_R4(1:N_v)) + read(unit =vtk(f)%ua,iostat=E_IO)(v_R4(n1),n1=1,N_v) + write(unit=vtk(f)%u, iostat=E_IO)int(vtk(f)%N_Byte,I4P),(v_R4(n1),n1=1,N_v) + deallocate(v_R4) + case('I8') + allocate(v_I8(1:N_v)) + read(unit =vtk(f)%ua,iostat=E_IO)(v_I8(n1),n1=1,N_v) + write(unit=vtk(f)%u, iostat=E_IO)int(vtk(f)%N_Byte,I4P),(v_I8(n1),n1=1,N_v) + deallocate(v_I8) + case('I4') + allocate(v_I4(1:N_v)) + read(unit =vtk(f)%ua,iostat=E_IO)(v_I4(n1),n1=1,N_v) + write(unit=vtk(f)%u, iostat=E_IO)int(vtk(f)%N_Byte,I4P),(v_I4(n1),n1=1,N_v) + deallocate(v_I4) + case('I2') + allocate(v_I2(1:N_v)) + read(unit =vtk(f)%ua,iostat=E_IO)(v_I2(n1),n1=1,N_v) + write(unit=vtk(f)%u, iostat=E_IO)int(vtk(f)%N_Byte,I4P),(v_I2(n1),n1=1,N_v) + deallocate(v_I2) + case('I1') + allocate(v_I1(1:N_v)) + read(unit =vtk(f)%ua,iostat=E_IO)(v_I1(n1),n1=1,N_v) + write(unit=vtk(f)%u, iostat=E_IO)int(vtk(f)%N_Byte,I4P),(v_I1(n1),n1=1,N_v) + 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(f)%N_Byte))//' N_v = '//trim(str(n=N_v)) + return + endselect + enddo + 100 continue + write(unit=vtk(f)%u,iostat=E_IO)end_rec + write(unit=vtk(f)%u,iostat=E_IO)repeat(' ',vtk(f)%indent)//''//end_rec + write(unit=vtk(f)%u,iostat=E_IO)''//end_rec + close(unit=vtk(f)%ua,iostat=E_IO) + endselect + close(unit=vtk(f)%u,iostat=E_IO) + call vtk_update(act='remove') + if (present(cf)) cf = f + 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. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + 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. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + 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. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + 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. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + 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(cf,nx1,nx2,ny1,ny2,nz1,nz2,filename,mesh_topology,tp) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + 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. + 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):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + character(len=maxlen):: s_buffer !< Buffer string. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (.not.ir_initialized) call IR_Init + call vtk_update(act='add') + if (present(cf)) cf = f + vtk(f)%topology = trim(mesh_topology) + open(unit=Get_Unit(vtk(f)%u),file=trim(filename),form='FORMATTED',access='SEQUENTIAL',action='WRITE',status='REPLACE',iostat=E_IO) + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)'' + if (endian==endianL) then + s_buffer = '' + else + s_buffer = '' + endif + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(f)%indent = 2 + select case(trim(vtk(f)%topology)) + case('PRectilinearGrid') + s_buffer = repeat(' ',vtk(f)%indent)//'<'//trim(vtk(f)%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(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(f)%indent = vtk(f)%indent + 2 + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' ; vtk(f)%indent = vtk(f)%indent + 2 + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + vtk(f)%indent = vtk(f)%indent - 2 ; write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + case('PStructuredGrid') + s_buffer = repeat(' ',vtk(f)%indent)//'<'//trim(vtk(f)%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(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(f)%indent = vtk(f)%indent + 2 + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' ; vtk(f)%indent = vtk(f)%indent + 2 + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + vtk(f)%indent = vtk(f)%indent - 2 ; write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + case('PUnstructuredGrid') + s_buffer = repeat(' ',vtk(f)%indent)//'<'//trim(vtk(f)%topology)//' GhostLevel="0">' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(f)%indent = vtk(f)%indent + 2 + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' ; vtk(f)%indent = vtk(f)%indent + 2 + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + vtk(f)%indent = vtk(f)%indent - 2 ; write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%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(cf,nx1,nx2,ny1,ny2,nz1,nz2,source) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + 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. + character(*), intent(IN):: source !< Source file name containing the piece data. + 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. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (present(cf)) f = cf + select case (vtk(f)%topology) + case('PRectilinearGrid','PStructuredGrid') + s_buffer = repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + case('PUnstructuredGrid') + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%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(cf,var_location,var_block_action) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + 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):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (present(cf)) f = cf + select case(trim(Upper_Case(var_location))) + case('CELL') + select case(trim(Upper_Case(var_block_action))) + case('OPEN') + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' ; vtk(f)%indent = vtk(f)%indent + 2 + case('CLOSE') + vtk(f)%indent = vtk(f)%indent - 2 ; write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + endselect + case('NODE') + select case(trim(Upper_Case(var_block_action))) + case('OPEN') + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' ; vtk(f)%indent = vtk(f)%indent + 2 + case('CLOSE') + vtk(f)%indent = vtk(f)%indent - 2 ; write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%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(cf,Nc,varname,tp) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P), intent(IN), optional:: Nc !< Number of components of variable. + character(*), intent(IN):: varname !< Variable name. + character(*), intent(IN):: tp !< Type of data representation (Float32, Float64, ecc). + 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. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (present(cf)) f = cf + if (present(Nc)) then + s_buffer = repeat(' ',vtk(f)%indent)//'' + else + s_buffer = repeat(' ',vtk(f)%indent)//'' + endif + write(unit=vtk(f)%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. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (present(cf)) f = cf + vtk(f)%indent = vtk(f)%indent - 2 + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)'' + close(unit=vtk(f)%u,iostat=E_IO) + call vtk_update(act='remove') + if (present(cf)) cf = f + 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(cf,output_format,filename,title,mesh_topology) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(OUT), optional:: cf !< Current file index (for concurrent files IO). + character(*), intent(IN):: output_format !< Output format: ASCII or BINARY. + character(*), intent(IN):: filename !< Name of file. + character(*), intent(IN):: title !< Title. + character(*), intent(IN):: mesh_topology !< Mesh topology. + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (.not.ir_initialized) call IR_Init + call vtk_update(act='add') + if (present(cf)) cf = f + vtk(f)%topology = trim(mesh_topology) + select case(trim(Upper_Case(output_format))) + case('ASCII') + vtk(f)%f = ascii + open(unit=Get_Unit(vtk(f)%u),file=trim(filename),form='FORMATTED',& + access='SEQUENTIAL',action='WRITE',status='REPLACE',iostat=E_IO) + ! writing header of file + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)'# vtk DataFile Version 3.0' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(title) + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(Upper_Case(output_format)) + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)'DATASET '//trim(vtk(f)%topology) + case('BINARY') + vtk(f)%f = binary + open(unit=Get_Unit(vtk(f)%u),file=trim(filename),form='UNFORMATTED',access='STREAM',action='WRITE',status='REPLACE',iostat=E_IO) + ! writing header of file + write(unit=vtk(f)%u,iostat=E_IO)'# vtk DataFile Version 3.0'//end_rec + write(unit=vtk(f)%u,iostat=E_IO)trim(title)//end_rec + write(unit=vtk(f)%u,iostat=E_IO)trim(Upper_Case(output_format))//end_rec + write(unit=vtk(f)%u,iostat=E_IO)'DATASET '//trim(vtk(f)%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) 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):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + character(len=maxlen):: s_buffer !< Buffer string. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + select case(vtk(f)%f) + case(ascii) + write(unit=vtk(f)%u,fmt='(A,3'//FI4P//')', iostat=E_IO)'DIMENSIONS ',Nx,Ny,Nz + write(unit=vtk(f)%u,fmt='(A,3'//FR8P//')', iostat=E_IO)'ORIGIN ',X0,Y0,Z0 + write(unit=vtk(f)%u,fmt='(A,3'//FR8P//')', iostat=E_IO)'SPACING ',Dx,Dy,Dz + case(binary) + write(s_buffer, fmt='(A,3'//FI4P//')', iostat=E_IO)'DIMENSIONS ',Nx,Ny,Nz + write(unit=vtk(f)%u, iostat=E_IO)trim(s_buffer)//end_rec + write(s_buffer, fmt='(A,3'//FR8P//')', iostat=E_IO)'ORIGIN ',X0,Y0,Z0 + write(unit=vtk(f)%u, iostat=E_IO)trim(s_buffer)//end_rec + write(s_buffer, fmt='(A,3'//FR8P//')', iostat=E_IO)'SPACING ',Dx,Dy,Dz + write(unit=vtk(f)%u, iostat=E_IO)trim(s_buffer)//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) 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):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + character(len=maxlen):: s_buffer !< Buffer string. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + select case(vtk(f)%f) + case(ascii) + write(unit=vtk(f)%u,fmt='(A,3'//FI4P//')', iostat=E_IO)'DIMENSIONS ',Nx,Ny,Nz + write(unit=vtk(f)%u,fmt='(A,3'//FR4P//')', iostat=E_IO)'ORIGIN ',X0,Y0,Z0 + write(unit=vtk(f)%u,fmt='(A,3'//FR4P//')', iostat=E_IO)'SPACING ',Dx,Dy,Dz + case(binary) + write(s_buffer, fmt='(A,3'//FI4P//')', iostat=E_IO)'DIMENSIONS ',Nx,Ny,Nz + write(unit=vtk(f)%u, iostat=E_IO)trim(s_buffer)//end_rec + write(s_buffer, fmt='(A,3'//FR4P//')', iostat=E_IO)'ORIGIN ',X0,Y0,Z0 + write(unit=vtk(f)%u, iostat=E_IO)trim(s_buffer)//end_rec + write(s_buffer, fmt='(A,3'//FR4P//')', iostat=E_IO)'SPACING ',Dx,Dy,Dz + write(unit=vtk(f)%u, iostat=E_IO)trim(s_buffer)//end_rec + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_GEO_STRP_R4 + + !> Function for saving mesh with \b STRUCTURED_GRID topology (R8P). + !> @return E_IO: integer(I4P) error flag + function VTK_GEO_STRG_R8(Nx,Ny,Nz,NN,X,Y,Z) 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:NN) !< X coordinates. + real(R8P), intent(IN):: Y(1:NN) !< Y coordinates. + real(R8P), intent(IN):: Z(1:NN) !< Z coordinates. + 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):: n1 !< Counter. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + select case(vtk(f)%f) + case(ascii) + write(unit=vtk(f)%u,fmt='(A,3'//FI4P//')', iostat=E_IO)'DIMENSIONS ',Nx,Ny,Nz + write(unit=vtk(f)%u,fmt='(A,'//FI4P//',A)',iostat=E_IO)'POINTS ',NN,' double' + write(unit=vtk(f)%u,fmt='(3'//FR8P//')', iostat=E_IO)(X(n1),Y(n1),Z(n1),n1=1,NN) + case(binary) + write(s_buffer, fmt='(A,3'//FI4P//')', iostat=E_IO)'DIMENSIONS ',Nx,Ny,Nz + write(unit=vtk(f)%u, iostat=E_IO)trim(s_buffer)//end_rec + write(s_buffer, fmt='(A,'//FI4P//',A)',iostat=E_IO)'POINTS ',NN,' double' + write(unit=vtk(f)%u, iostat=E_IO)trim(s_buffer)//end_rec + write(unit=vtk(f)%u, iostat=E_IO)(X(n1),Y(n1),Z(n1),n1=1,NN) + write(unit=vtk(f)%u, iostat=E_IO)end_rec + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_GEO_STRG_R8 + + !> Function for saving mesh with \b STRUCTURED_GRID topology (R4P). + !> @return E_IO: integer(I4P) error flag + function VTK_GEO_STRG_R4(Nx,Ny,Nz,NN,X,Y,Z) 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:NN) !< X coordinates. + real(R4P), intent(IN):: Y(1:NN) !< Y coordinates. + real(R4P), intent(IN):: Z(1:NN) !< Z coordinates. + 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):: n1 !< Counter. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + select case(vtk(f)%f) + case(ascii) + write(unit=vtk(f)%u,fmt='(A,3'//FI4P//')', iostat=E_IO)'DIMENSIONS ',Nx,Ny,Nz + write(unit=vtk(f)%u,fmt='(A,'//FI4P//',A)',iostat=E_IO)'POINTS ',NN,' float' + write(unit=vtk(f)%u,fmt='(3'//FR4P//')', iostat=E_IO)(X(n1),Y(n1),Z(n1),n1=1,NN) + case(binary) + write(s_buffer, fmt='(A,3'//FI4P//')', iostat=E_IO)'DIMENSIONS ',Nx,Ny,Nz + write(unit=vtk(f)%u, iostat=E_IO)trim(s_buffer)//end_rec + write(s_buffer, fmt='(A,'//FI4P//',A)',iostat=E_IO)'POINTS ',NN,' float' + write(unit=vtk(f)%u, iostat=E_IO)trim(s_buffer)//end_rec + write(unit=vtk(f)%u, iostat=E_IO)(X(n1),Y(n1),Z(n1),n1=1,NN) + write(unit=vtk(f)%u, iostat=E_IO)end_rec + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_GEO_STRG_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) 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):: 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):: n1 !< Counter. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + select case(vtk(f)%f) + case(ascii) + write(unit=vtk(f)%u,fmt='(A,3'//FI4P//')', iostat=E_IO)'DIMENSIONS ',Nx,Ny,Nz + write(unit=vtk(f)%u,fmt='(A,'//FI4P//',A)',iostat=E_IO)'X_COORDINATES ',Nx,' double' + write(unit=vtk(f)%u,fmt=FR8P, iostat=E_IO)(X(n1),n1=1,Nx) + write(unit=vtk(f)%u,fmt='(A,'//FI4P//',A)',iostat=E_IO)'Y_COORDINATES ',Ny,' double' + write(unit=vtk(f)%u,fmt=FR8P, iostat=E_IO)(Y(n1),n1=1,Ny) + write(unit=vtk(f)%u,fmt='(A,'//FI4P//',A)',iostat=E_IO)'Z_COORDINATES ',Nz,' double' + write(unit=vtk(f)%u,fmt=FR8P, iostat=E_IO)(Z(n1),n1=1,Nz) + case(binary) + write(s_buffer, fmt='(A,3'//FI4P//')', iostat=E_IO)'DIMENSIONS ',Nx,Ny,Nz + write(unit=vtk(f)%u, iostat=E_IO)trim(s_buffer)//end_rec + write(s_buffer, fmt='(A,'//FI4P//',A)',iostat=E_IO)'X_COORDINATES ',Nx,' double' + write(unit=vtk(f)%u, iostat=E_IO)trim(s_buffer)//end_rec + write(unit=vtk(f)%u, iostat=E_IO)(X(n1),n1=1,Nx) + write(unit=vtk(f)%u, iostat=E_IO)end_rec + write(s_buffer, fmt='(A,'//FI4P//',A)',iostat=E_IO)'Y_COORDINATES ',Ny,' double' + write(unit=vtk(f)%u, iostat=E_IO)trim(s_buffer)//end_rec + write(unit=vtk(f)%u, iostat=E_IO)(Y(n1),n1=1,Ny) + write(unit=vtk(f)%u, iostat=E_IO)end_rec + write(s_buffer, fmt='(A,'//FI4P//',A)',iostat=E_IO)'Z_COORDINATES ',Nz,' double' + write(unit=vtk(f)%u, iostat=E_IO)trim(s_buffer)//end_rec + write(unit=vtk(f)%u, iostat=E_IO)(Z(n1),n1=1,Nz) + write(unit=vtk(f)%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) 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):: 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):: n1 !< Counter. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + select case(vtk(f)%f) + case(ascii) + write(unit=vtk(f)%u,fmt='(A,3'//FI4P//')', iostat=E_IO)'DIMENSIONS ',Nx,Ny,Nz + write(unit=vtk(f)%u,fmt='(A,'//FI4P//',A)',iostat=E_IO)'X_COORDINATES ',Nx,' float' + write(unit=vtk(f)%u,fmt=FR4P, iostat=E_IO)(X(n1),n1=1,Nx) + write(unit=vtk(f)%u,fmt='(A,'//FI4P//',A)',iostat=E_IO)'Y_COORDINATES ',Ny,' float' + write(unit=vtk(f)%u,fmt=FR4P, iostat=E_IO)(Y(n1),n1=1,Ny) + write(unit=vtk(f)%u,fmt='(A,'//FI4P//',A)',iostat=E_IO)'Z_COORDINATES ',Nz,' float' + write(unit=vtk(f)%u,fmt=FR4P, iostat=E_IO)(Z(n1),n1=1,Nz) + case(binary) + write(s_buffer, fmt='(A,3'//FI4P//')', iostat=E_IO)'DIMENSIONS ',Nx,Ny,Nz + write(unit=vtk(f)%u, iostat=E_IO)trim(s_buffer)//end_rec + write(s_buffer, fmt='(A,'//FI4P//',A)',iostat=E_IO)'X_COORDINATES ',Nx,' float' + write(unit=vtk(f)%u, iostat=E_IO)trim(s_buffer)//end_rec + write(unit=vtk(f)%u, iostat=E_IO)(X(n1),n1=1,Nx) + write(unit=vtk(f)%u, iostat=E_IO)end_rec + write(s_buffer, fmt='(A,'//FI4P//',A)',iostat=E_IO)'Y_COORDINATES ',Ny,' float' + write(unit=vtk(f)%u, iostat=E_IO)trim(s_buffer)//end_rec + write(unit=vtk(f)%u, iostat=E_IO)(Y(n1),n1=1,Ny) + write(unit=vtk(f)%u, iostat=E_IO)end_rec + write(s_buffer, fmt='(A,'//FI4P//',A)',iostat=E_IO)'Z_COORDINATES ',Nz,' float' + write(unit=vtk(f)%u, iostat=E_IO)trim(s_buffer)//end_rec + write(unit=vtk(f)%u, iostat=E_IO)(Z(n1),n1=1,Nz) + write(unit=vtk(f)%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) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: NN !< Number of nodes. + real(R8P), intent(IN):: X(1:NN) !< X coordinates of all nodes. + real(R8P), intent(IN):: Y(1:NN) !< Y coordinates of all nodes. + real(R8P), intent(IN):: Z(1:NN) !< Z coordinates of all nodes. + 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):: n1 !< Counter. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + select case(vtk(f)%f) + case(ascii) + write(unit=vtk(f)%u,fmt='(A,'//FI4P//',A)',iostat=E_IO)'POINTS ',NN,' double' + write(unit=vtk(f)%u,fmt='(3'//FR8P//')', iostat=E_IO)(X(n1),Y(n1),Z(n1),n1=1,NN) + case(binary) + write(s_buffer, fmt='(A,'//FI4P//',A)',iostat=E_IO)'POINTS ',NN,' double' + write(unit=vtk(f)%u, iostat=E_IO)trim(s_buffer)//end_rec + write(unit=vtk(f)%u, iostat=E_IO)(X(n1),Y(n1),Z(n1),n1=1,NN) + write(unit=vtk(f)%u, iostat=E_IO)end_rec + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_GEO_UNST_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) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: NN !< number of nodes. + real(R4P), intent(IN):: X(1:NN) !< x coordinates of all nodes. + real(R4P), intent(IN):: Y(1:NN) !< y coordinates of all nodes. + real(R4P), intent(IN):: Z(1:NN) !< z coordinates of all nodes. + 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):: n1 !< counter. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + select case(vtk(f)%f) + case(ascii) + write(unit=vtk(f)%u,fmt='(A,'//FI4P//',A)',iostat=E_IO)'POINTS ',NN,' float' + write(unit=vtk(f)%u,fmt='(3'//FR4P//')', iostat=E_IO)(X(n1),Y(n1),Z(n1),n1=1,NN) + case(binary) + write(s_buffer, fmt='(A,'//FI4P//',A)',iostat=E_IO)'POINTS ',NN,' float' + write(unit=vtk(f)%u, iostat=E_IO)trim(s_buffer)//end_rec + write(unit=vtk(f)%u, iostat=E_IO)(X(n1),Y(n1),Z(n1),n1=1,NN) + write(unit=vtk(f)%u, iostat=E_IO)end_rec + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_GEO_UNST_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) 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):: 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. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + ncon = size(connect,1) + select case(vtk(f)%f) + case(ascii) + write(unit=vtk(f)%u,fmt='(A,2'//FI4P//')',iostat=E_IO)'CELLS ',NC,ncon + write(unit=vtk(f)%u,fmt=FI4P, iostat=E_IO)connect + write(unit=vtk(f)%u,fmt='(A,'//FI4P//')', iostat=E_IO)'CELL_TYPES ',NC + write(unit=vtk(f)%u,fmt=FI4P, iostat=E_IO)cell_type + case(binary) + write(s_buffer, fmt='(A,2'//FI4P//')',iostat=E_IO)'CELLS ',NC,ncon + write(unit=vtk(f)%u, iostat=E_IO)trim(s_buffer)//end_rec + write(unit=vtk(f)%u, iostat=E_IO)connect + write(unit=vtk(f)%u, iostat=E_IO)end_rec + write(s_buffer, fmt='(A,'//FI4P//')', iostat=E_IO)'CELL_TYPES ',NC + write(unit=vtk(f)%u, iostat=E_IO)trim(s_buffer)//end_rec + write(unit=vtk(f)%u, iostat=E_IO)cell_type + write(unit=vtk(f)%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) 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):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + character(len=maxlen):: s_buffer !< Buffer string. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + select case(vtk(f)%f) + case(ascii) + select case(trim(Upper_Case(var_location))) + case('CELL') + write(unit=vtk(f)%u,fmt='(A,'//FI4P//')',iostat=E_IO)'CELL_DATA ',NC_NN + case('NODE') + write(unit=vtk(f)%u,fmt='(A,'//FI4P//')',iostat=E_IO)'POINT_DATA ',NC_NN + endselect + case(binary) + 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(f)%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(f)%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) 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):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + select case(vtk(f)%f) + case(ascii) + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)'SCALARS '//trim(varname)//' double 1' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)'LOOKUP_TABLE default' + write(unit=vtk(f)%u,fmt=FR8P, iostat=E_IO)var + case(binary) + write(unit=vtk(f)%u,iostat=E_IO)'SCALARS '//trim(varname)//' double 1'//end_rec + write(unit=vtk(f)%u,iostat=E_IO)'LOOKUP_TABLE default'//end_rec + write(unit=vtk(f)%u,iostat=E_IO)var + write(unit=vtk(f)%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) 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):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + select case(vtk(f)%f) + case(ascii) + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)'SCALARS '//trim(varname)//' float 1' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)'LOOKUP_TABLE default' + write(unit=vtk(f)%u,fmt=FR4P, iostat=E_IO)var + case(binary) + write(unit=vtk(f)%u,iostat=E_IO)'SCALARS '//trim(varname)//' float 1'//end_rec + write(unit=vtk(f)%u,iostat=E_IO)'LOOKUP_TABLE default'//end_rec + write(unit=vtk(f)%u,iostat=E_IO)var + write(unit=vtk(f)%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) 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):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + select case(vtk(f)%f) + case(ascii) + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)'SCALARS '//trim(varname)//' int 1' + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)'LOOKUP_TABLE default' + write(unit=vtk(f)%u,fmt=FI4P, iostat=E_IO)var + case(binary) + write(unit=vtk(f)%u,iostat=E_IO)'SCALARS '//trim(varname)//' int 1'//end_rec + write(unit=vtk(f)%u,iostat=E_IO)'LOOKUP_TABLE default'//end_rec + write(unit=vtk(f)%u,iostat=E_IO)var + write(unit=vtk(f)%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) 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):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + integer(I8P):: n1 !< Counter. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + select case(vtk(f)%f) + case(ascii) + select case(Upper_Case(trim(vec_type))) + case('VECT') + write(unit=vtk(f)%u,fmt='(A)', iostat=E_IO)'VECTORS '//trim(varname)//' double' + case('NORM') + write(unit=vtk(f)%u,fmt='(A)', iostat=E_IO)'NORMALS '//trim(varname)//' double' + endselect + write(unit=vtk(f)%u,fmt='(3'//FR8P//')',iostat=E_IO)(varX(n1),varY(n1),varZ(n1),n1=1,NC_NN) + case(binary) + select case(Upper_Case(trim(vec_type))) + case('VECT') + write(unit=vtk(f)%u,iostat=E_IO)'VECTORS '//trim(varname)//' double'//end_rec + case('NORM') + write(unit=vtk(f)%u,iostat=E_IO)'NORMALS '//trim(varname)//' double'//end_rec + endselect + write(unit=vtk(f)%u,iostat=E_IO)(varX(n1),varY(n1),varZ(n1),n1=1,NC_NN) + write(unit=vtk(f)%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) 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):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + integer(I8P):: n1 !< Counter. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + select case(vtk(f)%f) + case(ascii) + select case(Upper_Case(trim(vec_type))) + case('vect') + write(unit=vtk(f)%u,fmt='(A)', iostat=E_IO)'VECTORS '//trim(varname)//' float' + case('norm') + write(unit=vtk(f)%u,fmt='(A)', iostat=E_IO)'NORMALS '//trim(varname)//' float' + endselect + write(unit=vtk(f)%u,fmt='(3'//FR4P//')',iostat=E_IO)(varX(n1),varY(n1),varZ(n1),n1=1,NC_NN) + case(binary) + select case(Upper_Case(trim(vec_type))) + case('vect') + write(unit=vtk(f)%u,iostat=E_IO)'VECTORS '//trim(varname)//' float'//end_rec + case('norm') + write(unit=vtk(f)%u,iostat=E_IO)'NORMALS '//trim(varname)//' float'//end_rec + endselect + write(unit=vtk(f)%u,iostat=E_IO)(varX(n1),varY(n1),varZ(n1),n1=1,NC_NN) + write(unit=vtk(f)%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) 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):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + integer(I8P):: n1 !< Counter. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + select case(vtk(f)%f) + case(ascii) + write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)'VECTORS '//trim(varname)//' int' + write(unit=vtk(f)%u,fmt='(3'//FI4P//')',iostat=E_IO)(varX(n1),varY(n1),varZ(n1),n1=1,NC_NN) + case(binary) + write(unit=vtk(f)%u,iostat=E_IO)'VECTORS '//trim(varname)//' int'//end_rec + write(unit=vtk(f)%u,iostat=E_IO)(varX(n1),varY(n1),varZ(n1),n1=1,NC_NN) + write(unit=vtk(f)%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) 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):: 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):: n1,n2 !< Counters. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + select case(vtk(f)%f) + case(ascii) + write(unit=vtk(f)%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(f)%u,fmt=trim(s_buffer),iostat=E_IO)((textCoo(n1,n2),n2=1,dimm),n1=1,NC_NN) + case(binary) + write(s_buffer,fmt='(A,1X,'//FI4P//',1X,A)',iostat=E_IO)'TEXTURE_COORDINATES '//trim(varname),dimm,' double' + write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec + write(unit=vtk(f)%u,iostat=E_IO)((textCoo(n1,n2),n2=1,dimm),n1=1,NC_NN) + write(unit=vtk(f)%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) 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):: 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):: n1,n2 !< Counters. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + select case(vtk(f)%f) + case(ascii) + write(unit=vtk(f)%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(f)%u,fmt=trim(s_buffer),iostat=E_IO)((textCoo(n1,n2),n2=1,dimm),n1=1,NC_NN) + case(binary) + write(s_buffer,fmt='(A,1X,'//FI4P//',1X,A)',iostat=E_IO)'TEXTURE_COORDINATES '//trim(varname),dimm,' float' + write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec + write(unit=vtk(f)%u,iostat=E_IO)((textCoo(n1,n2),n2=1,dimm),n1=1,NC_NN) + write(unit=vtk(f)%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. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (present(cf)) f = cf + close(unit=vtk(f)%u,iostat=E_IO) + call vtk_update(act='remove') + if (present(cf)) cf = f + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_END +endmodule Lib_VTK_IO