diff --git a/code/libs.f90 b/code/libs.f90 index 72ae1f71e..b683bcad8 100644 --- a/code/libs.f90 +++ b/code/libs.f90 @@ -30,5 +30,6 @@ end module libs #include "../lib/kdtree2.f90" #endif #include "../lib/IR_Precision.f90" +#include "../lib/Lib_Base64.f90" #include "../lib/Lib_VTK_IO.f90" diff --git a/lib/IR_Precision.f90 b/lib/IR_Precision.f90 index e995ac898..da3f68cdf 100644 --- a/lib/IR_Precision.f90 +++ b/lib/IR_Precision.f90 @@ -12,26 +12,31 @@ !> @ingroup Library !> @{ !> @defgroup IR_PrecisionLibrary IR_Precision +!> Portable kind-parameters module !> @} !> @ingroup Interface !> @{ !> @defgroup IR_PrecisionInterface IR_Precision +!> Portable kind-parameters module !> @} !> @ingroup GlobalVarPar !> @{ !> @defgroup IR_PrecisionGlobalVarPar IR_Precision +!> Portable kind-parameters module !> @} !> @ingroup PublicProcedure !> @{ !> @defgroup IR_PrecisionPublicProcedure IR_Precision +!> Portable kind-parameters module !> @} !> @ingroup PrivateProcedure !> @{ !> @defgroup IR_PrecisionPrivateProcedure IR_Precision +!> Portable kind-parameters module !> @} !> @brief Module IR_Precision makes available some portable kind-parameters and some useful procedures to deal with them. @@ -58,9 +63,7 @@ USE, intrinsic:: ISO_FORTRAN_ENV, only: stdout => OUTPUT_UNIT, stderr => ERROR_U 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 @@ -69,9 +72,11 @@ public:: I4P, FI4P, DI4P, MinI4P, MaxI4P, BII4P, BYI4P public:: I2P, FI2P, DI2P, MinI2P, MaxI2P, BII2P, BYI2P public:: I1P, FI1P, DI1P, MinI1P, MaxI1P, BII1P, BYI1P public:: I_P, FI_P, DI_P, MinI_P, MaxI_P, BII_P, BYI_P +public:: NRknd, RPl, FRl +public:: NIknd, RIl, FIl public:: check_endian -public:: bit_size -public:: str, strz, cton +public:: bit_size,byte_size +public:: str, strz, cton, bstr, bcton public:: ir_initialized,IR_Init public:: IR_Print !----------------------------------------------------------------------------------------------------------------------------------- @@ -89,6 +94,8 @@ integer:: endian = endianL !< Bit ordering: Little endian (endianL), ! Real precision definitions: #ifdef r16p integer, parameter:: R16P = selected_real_kind(33,4931) !< 33 digits, range \f$[10^{-4931}, 10^{+4931} - 1]\f$; 128 bits. +#else +integer, parameter:: R16P = selected_real_kind(15,307) !< Defined as R8P; 64 bits. #endif integer, parameter:: R8P = selected_real_kind(15,307) !< 15 digits, range \f$[10^{-307} , 10^{+307} - 1]\f$; 64 bits. integer, parameter:: R4P = selected_real_kind(6,37) !< 6 digits, range \f$[10^{-37} , 10^{+37} - 1]\f$; 32 bits. @@ -102,16 +109,12 @@ 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. @@ -132,62 +135,62 @@ integer, parameter:: DI4P = 11 !< Number of digits of output format I4P. integer, parameter:: DI2P = 6 !< Number of digits of output format I2P. integer, parameter:: DI1P = 4 !< Number of digits of output format I1P. integer, parameter:: DI_P = DI4P !< Number of digits of output format I_P. +! List of kinds +integer, parameter:: NRknd=4 !< Number of defined real kinds. +integer, parameter:: RPl(1:NRknd)=[R16P,R8P,R4P,R_P] !< List of defined real kinds. +character(10), parameter:: FRl(1:NRknd)=[FR16P,FR8P,FR4P//' ',FR_P] !< List of defined real kinds output format. +integer, parameter:: NIknd=5 !< Number of defined integer kinds. +integer, parameter:: RIl(1:NIknd)=[I8P,I4P,I2P,I1P,I_P] !< List of defined integer kinds. +character(5), parameter:: FIl(1:NIknd)=[FI8P,FI4P,FI2P//' ',FI1P//' ',FI_P] !< List of defined integer kinds output format. ! Useful parameters for handling numbers ranges. ! Real min and max values: -#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(I2P):: BIR16P, BYR16P !< Number of bits/bytes of kind=R16P variable. integer(I1P):: BIR8P, BYR8P !< Number of bits/bytes of kind=R8P variable. integer(I1P):: BIR4P, BYR4P !< Number of bits/bytes of kind=R4P variable. integer(I1P):: BIR_P, BYR_P !< Number of bits/bytes of kind=R_P variable. ! Real smallest values: -#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(I8P), parameter:: MinI8P = -huge(1_I8P), MaxI8P = huge(1_I8P) !< Min and max values of kind=I8P variable. +integer(I4P), parameter:: MinI4P = -huge(1_I4P), MaxI4P = huge(1_I4P) !< Min and max values of kind=I4P variable. +integer(I2P), parameter:: MinI2P = -huge(1_I2P), MaxI2P = huge(1_I2P) !< Min and max values of kind=I2P variable. +integer(I1P), parameter:: MinI1P = -huge(1_I1P), MaxI1P = huge(1_I1P) !< Min and max values of kind=I1P variable. +integer(I_P), parameter:: MinI_P = MinI4P, MaxI_P = MaxI4P !< Min and max values of kind=I_P variable. ! Integer number of bits/bytes: integer(I8P), parameter:: BII8P = bit_size(MaxI8P), BYI8P = bit_size(MaxI8P)/8_I8P !< Number of bits/bytes of kind=I8P variable. integer(I4P), parameter:: BII4P = bit_size(MaxI4P), BYI4P = bit_size(MaxI4P)/8_I4P !< Number of bits/bytes of kind=I4P variable. -integer(I2P), parameter:: BII2P = bit_size(MaxI4P), BYI2P = bit_size(MaxI2P)/8_I2P !< Number of bits/bytes of kind=I2P variable. +integer(I2P), parameter:: BII2P = bit_size(MaxI2P), BYI2P = bit_size(MaxI2P)/8_I2P !< Number of bits/bytes of kind=I2P variable. integer(I1P), parameter:: BII1P = bit_size(MaxI1P), BYI1P = bit_size(MaxI1P)/8_I1P !< Number of bits/bytes of kind=I1P variable. integer(I_P), parameter:: BII_P = bit_size(MaxI_P), BYI_P = bit_size(MaxI_P)/8_I_P !< Number of bits/bytes of kind=I_P variable. ! Smallest real representable difference by the running calculator. -#ifdef 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(R16P), parameter:: ZeroR16 = 0._R16P real(R8P), parameter:: ZeroR8 = 0._R8P real(R4P), parameter:: ZeroR4 = 0._R4P #else +real(R16P), parameter:: ZeroR16 = nearest(1._R16P, 1._R16P) - & + nearest(1._R16P,-1._R16P) !< Smallest representable difference of kind=R16P variable. real(R8P), parameter:: ZeroR8 = nearest(1._R8P, 1._R8P) - & - nearest(1._R8P,-1._R8P) !< Smallest representable difference of kind=R8P variable. + 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. + 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. +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; +!> @brief Overloading of the intrinsic "bit_size" function for computing the number of bits of (also) real and character variables; +!> variable, intent(\b IN):: \em n input; !> integer(I1P), intent(\b OUT):: \em bits output number of bits of input number. !> @ingroup IR_PrecisionInterface interface bit_size @@ -196,9 +199,25 @@ interface bit_size bit_size_R16p, & #endif bit_size_R8P, & - bit_size_R4P + bit_size_R4P, & + bit_size_chr endinterface -!> @brief Function for converting number, real and integer, to string (number to string type casting); +!> @brief Overloading of the "byte_size" function for computing the number of bytes. +!> @ingroup IR_PrecisionInterface +interface byte_size + module procedure & + byte_size_I8P, & + byte_size_I4P, & + byte_size_I2P, & + byte_size_I1P, & +#ifdef r16p + byte_size_R16p, & +#endif + byte_size_R8P, & + byte_size_R4P, & + byte_size_chr +endinterface +!> @brief Procedure for converting number, real and integer, to string (number to string type casting); !> logical, intent(\b IN), optional:: \em no_sign flag for do not write sign; !> number, intent(\b IN):: \em n input number; !> string, intent(\b OUT):: \em str output string. @@ -206,17 +225,17 @@ endinterface interface str module procedure & #ifdef r16p - str_R16P,strf_R16P,& + strf_R16P,str_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 + strf_R8P ,str_R8P, & + strf_R4P ,str_R4P, & + strf_I8P ,str_I8P, & + strf_I4P ,str_I4P, & + strf_I2P ,str_I2P, & + strf_I1P ,str_I1P endinterface -!> @brief Function for converting number, integer, to string, prefixing with the right number of zeros (number to string type -!> casting with zero padding); +!> @brief Procedure for converting number, integer, to string, prefixing with the right number of zeros (number to string type +!> casting with zero padding); !> number, intent(\b IN), optional:: \em no_zpad number of padding zeros; !> number, intent(\b IN):: \em n input number; !> string, intent(\b OUT):: \em str output string. @@ -227,7 +246,7 @@ interface strz strz_I2P, & strz_I1P endinterface -!> @brief Function for converting string to number, real or initeger, (string to number type casting); +!> @brief Procedure for converting string to number, real or initeger, (string to number type casting); !> string, intent(\b IN):: \em str input string; !> number, intent(\b OUT):: \em n output number. !> @ingroup IR_PrecisionInterface @@ -243,11 +262,43 @@ interface cton ctoi_I2P, & ctoi_I1P endinterface +!> @brief Procedure for converting number, real and integer, to bit-string (number to bit-string type casting); +!> number, intent(\b IN):: \em n input number; +!> string, intent(\b OUT):: \em bstr output bit-string. +!> @ingroup IR_PrecisionInterface +interface bstr + module procedure & +#ifdef r16p + bstr_R16P,& +#endif + bstr_R8P, & + bstr_R4P, & + bstr_I8P, & + bstr_I4P, & + bstr_I2P, & + bstr_I1P +endinterface +!> @brief Procedure for converting bit-string to number, real or initeger, (bit-string to number type casting); +!> string, intent(\b IN):: \em bstr input bit-string; +!> number, intent(\b OUT):: \em n output number. +!> @ingroup IR_PrecisionInterface +interface bcton + module procedure & +#ifdef r16p + bctor_R16P, & +#endif + bctor_R8P, & + bctor_R4P, & + bctoi_I8P, & + bctoi_I4P, & + bctoi_I2P, & + bctoi_I1P +endinterface !----------------------------------------------------------------------------------------------------------------------------------- contains !> @ingroup IR_PrecisionPublicProcedure !> @{ - !>Function for checking if the type of the bit ordering of the running architecture is little endian. + !> @brief Procedure for checking if the type of the bit ordering of the running architecture is little endian. pure function is_little_endian() result(is_little) !--------------------------------------------------------------------------------------------------------------------------------- implicit none @@ -262,9 +313,8 @@ contains !--------------------------------------------------------------------------------------------------------------------------------- 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 + !> @brief Subroutine for checking the type of bit ordering (big or little endian) of the running architecture; the result is + !> stored into the "endian" global variable. subroutine check_endian() !--------------------------------------------------------------------------------------------------------------------------------- implicit none @@ -283,55 +333,179 @@ contains !> @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) + !> @brief Procedure for computing the number of bits of a real variable. + elemental function bit_size_R16P(r) result(bits) !--------------------------------------------------------------------------------------------------------------------------------- implicit none - real(R16P), intent(IN):: i !< Real variable of which number of bits must be computed. - integer(I1P):: bits !< Number of bits of i. + real(R16P), intent(IN):: r !< Real variable whose number of bits must be computed. + integer(I2P):: bits !< Number of bits of r. integer(I1P):: mold(1) !< "Molding" dummy variable for bits counting. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - bits = size(transfer(i,mold))*8_I1P + bits = size(transfer(r,mold),dim=1,kind=I2P)*8_I2P 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) + !> @brief Procedure for computing the number of bits of a real variable. + elemental function bit_size_R8P(r) result(bits) !--------------------------------------------------------------------------------------------------------------------------------- implicit none - real(R8P), intent(IN):: i !< Real variable of which number of bits must be computed. - integer(I1P):: bits !< Number of bits of i. + real(R8P), intent(IN):: r !< Real variable whose number of bits must be computed. + integer(I1P):: bits !< Number of bits of r. integer(I1P):: mold(1) !< "Molding" dummy variable for bits counting. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - bits = size(transfer(i,mold))*8_I1P + bits = size(transfer(r,mold),dim=1,kind=I1P)*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) + !> @brief Procedure for computing the number of bits of a real variable. + elemental function bit_size_R4P(r) result(bits) !--------------------------------------------------------------------------------------------------------------------------------- implicit none - real(R4P), intent(IN):: i !< Real variable of which number of bits must be computed. - integer(I1P):: bits !< Number of bits of i. + real(R4P), intent(IN):: r !< Real variable whose number of bits must be computed. + integer(I1P):: bits !< Number of bits of r. integer(I1P):: mold(1) !< "Molding" dummy variable for bits counting. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - bits = size(transfer(i,mold))*8_I1P + bits = size(transfer(r,mold),dim=1,kind=I1P)*8_I1P return !--------------------------------------------------------------------------------------------------------------------------------- endfunction bit_size_R4P -#ifdef r16p - !> @brief Function for converting real to string. This function achieves casting of real to string. + !> @brief Procedure for computing the number of bits of a character variable. + elemental function bit_size_chr(c) result(bits) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + character(*), intent(IN):: c !< Character variable whose number of bits must be computed. + integer(I4P):: bits !< Number of bits of c. + integer(I1P):: mold(1) !< "Molding" dummy variable for bits counting. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + bits = size(transfer(c,mold),dim=1,kind=I1P)*8_I4P + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction bit_size_chr + + !> @brief Procedure for computing the number of bytes of an integer variable. + elemental function byte_size_I8P(i) result(bytes) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I8P), intent(IN):: i !< Integer variable whose number of bytes must be computed. + integer(I1P):: bytes !< Number of bytes of i. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + bytes = bit_size(i)/8_I1P + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction byte_size_I8P + + !> @brief Procedure for computing the number of bytes of an integer variable. + elemental function byte_size_I4P(i) result(bytes) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: i !< Integer variable whose number of bytes must be computed. + integer(I1P):: bytes !< Number of bytes of i. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + bytes = bit_size(i)/8_I1P + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction byte_size_I4P + + !> @brief Procedure for computing the number of bytes of an integer variable. + elemental function byte_size_I2P(i) result(bytes) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I2P), intent(IN):: i !< Integer variable whose number of bytes must be computed. + integer(I1P):: bytes !< Number of bytes of i. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + bytes = bit_size(i)/8_I1P + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction byte_size_I2P + + !> @brief Procedure for computing the number of bytes of an integer variable. + elemental function byte_size_I1P(i) result(bytes) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I1P), intent(IN):: i !< Integer variable whose number of bytes must be computed. + integer(I1P):: bytes !< Number of bytes of i. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + bytes = bit_size(i)/8_I1P + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction byte_size_I1P + + !> @brief Procedure for computing the number of bytes of a real variable. + elemental function byte_size_R16P(r) result(bytes) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + real(R16P), intent(IN):: r !< Real variable whose number of bytes must be computed. + integer(I1P):: bytes !< Number of bytes of r. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + bytes = bit_size(r)/8_I1P + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction byte_size_R16P + + !> @brief Procedure for computing the number of bytes of a real variable. + elemental function byte_size_R8P(r) result(bytes) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + real(R8P), intent(IN):: r !< Real variable whose number of bytes must be computed. + integer(I1P):: bytes !< Number of bytes of r. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + bytes = bit_size(r)/8_I1P + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction byte_size_R8P + + !> @brief Procedure for computing the number of bytes of a real variable. + elemental function byte_size_R4P(r) result(bytes) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + real(R4P), intent(IN):: r !< Real variable whose number of bytes must be computed. + integer(I1P):: bytes !< Number of bytes of r. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + bytes = bit_size(r)/8_I1P + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction byte_size_R4P + + !> @brief Procedure for computing the number of bytes of a character variable. + elemental function byte_size_chr(c) result(bytes) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + character(*), intent(IN):: c !< Character variable whose number of bytes must be computed. + integer(I4P):: bytes !< Number of bytes of c. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + bytes = bit_size(c)/8_I4P + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction byte_size_chr + + !> @brief Procedure for converting real to string. This function achieves casting of real to string. elemental function strf_R16P(fm,n) result(str) !--------------------------------------------------------------------------------------------------------------------------------- implicit none @@ -345,9 +519,8 @@ contains return !--------------------------------------------------------------------------------------------------------------------------------- endfunction strf_R16P -#endif - !> @brief Function for converting real to string. This function achieves casting of real to string. + !> @brief Procedure for converting real to string. This function achieves casting of real to string. elemental function strf_R8P(fm,n) result(str) !--------------------------------------------------------------------------------------------------------------------------------- implicit none @@ -362,7 +535,7 @@ contains !--------------------------------------------------------------------------------------------------------------------------------- endfunction strf_R8P - !> @brief Function for converting real to string. This function achieves casting of real to string. + !> @brief Procedure for converting real to string. This function achieves casting of real to string. elemental function strf_R4P(fm,n) result(str) !--------------------------------------------------------------------------------------------------------------------------------- implicit none @@ -377,7 +550,7 @@ contains !--------------------------------------------------------------------------------------------------------------------------------- endfunction strf_R4P - !> @brief Function for converting integer to string. This function achieves casting of integer to string. + !> @brief Procedure for converting integer to string. This function achieves casting of integer to string. elemental function strf_I8P(fm,n) result(str) !--------------------------------------------------------------------------------------------------------------------------------- implicit none @@ -392,7 +565,7 @@ contains !--------------------------------------------------------------------------------------------------------------------------------- endfunction strf_I8P - !> @brief Function for converting integer to string. This function achieves casting of integer to string. + !> @brief Procedure for converting integer to string. This function achieves casting of integer to string. elemental function strf_I4P(fm,n) result(str) !--------------------------------------------------------------------------------------------------------------------------------- implicit none @@ -407,7 +580,7 @@ contains !--------------------------------------------------------------------------------------------------------------------------------- endfunction strf_I4P - !> @brief Function for converting integer to string. This function achieves casting of integer to string. + !> @brief Procedure for converting integer to string. This function achieves casting of integer to string. elemental function strf_I2P(fm,n) result(str) !--------------------------------------------------------------------------------------------------------------------------------- implicit none @@ -422,7 +595,7 @@ contains !--------------------------------------------------------------------------------------------------------------------------------- endfunction strf_I2P - !> @brief Function for converting integer to string. This function achieves casting of integer to string. + !> @brief Procedure for converting integer to string. This function achieves casting of integer to string. elemental function strf_I1P(fm,n) result(str) !--------------------------------------------------------------------------------------------------------------------------------- implicit none @@ -437,8 +610,7 @@ contains !--------------------------------------------------------------------------------------------------------------------------------- endfunction strf_I1P -#ifdef r16p - !> @brief Function for converting real to string. This function achieves casting of real to string. + !> @brief Procedure for converting real to string. This function achieves casting of real to string. elemental function str_R16P(no_sign,n) result(str) !--------------------------------------------------------------------------------------------------------------------------------- implicit none @@ -454,9 +626,8 @@ contains return !--------------------------------------------------------------------------------------------------------------------------------- endfunction str_R16P -#endif - !> @brief Function for converting real to string. This function achieves casting of real to string. + !> @brief Procedure for converting real to string. This function achieves casting of real to string. elemental function str_R8P(no_sign,n) result(str) !--------------------------------------------------------------------------------------------------------------------------------- implicit none @@ -473,7 +644,7 @@ contains !--------------------------------------------------------------------------------------------------------------------------------- endfunction str_R8P - !> @brief Function for converting real to string. This function achieves casting of real to string. + !> @brief Procedure for converting real to string. This function achieves casting of real to string. elemental function str_R4P(no_sign,n) result(str) !--------------------------------------------------------------------------------------------------------------------------------- implicit none @@ -490,7 +661,7 @@ contains !--------------------------------------------------------------------------------------------------------------------------------- endfunction str_R4P - !> @brief Function for converting integer to string. This function achieves casting of integer to string. + !> @brief Procedure for converting integer to string. This function achieves casting of integer to string. elemental function str_I8P(no_sign,n) result(str) !--------------------------------------------------------------------------------------------------------------------------------- implicit none @@ -508,7 +679,7 @@ contains !--------------------------------------------------------------------------------------------------------------------------------- endfunction str_I8P - !> @brief Function for converting integer to string. This function achieves casting of integer to string. + !> @brief Procedure for converting integer to string. This function achieves casting of integer to string. elemental function str_I4P(no_sign,n) result(str) !--------------------------------------------------------------------------------------------------------------------------------- implicit none @@ -526,7 +697,7 @@ contains !--------------------------------------------------------------------------------------------------------------------------------- endfunction str_I4P - !> @brief Function for converting integer to string. This function achieves casting of integer to string. + !> @brief Procedure for converting integer to string. This function achieves casting of integer to string. elemental function str_I2P(no_sign,n) result(str) !--------------------------------------------------------------------------------------------------------------------------------- implicit none @@ -544,7 +715,7 @@ contains !--------------------------------------------------------------------------------------------------------------------------------- endfunction str_I2P - !> @brief Function for converting integer to string. This function achieves casting of integer to string. + !> @brief Procedure for converting integer to string. This function achieves casting of integer to string. elemental function str_I1P(no_sign,n) result(str) !--------------------------------------------------------------------------------------------------------------------------------- implicit none @@ -562,7 +733,7 @@ contains !--------------------------------------------------------------------------------------------------------------------------------- endfunction str_I1P - !> @brief Function for converting integer to string, prefixing with the right number of zeros. This function achieves casting of + !> @brief Procedure for converting integer to string, prefixing with the right number of zeros. This function achieves casting of !> integer to string. elemental function strz_I8P(nz_pad,n) result(str) !--------------------------------------------------------------------------------------------------------------------------------- @@ -580,7 +751,7 @@ contains !--------------------------------------------------------------------------------------------------------------------------------- endfunction strz_I8P - !> @brief Function for converting integer to string, prefixing with the right number of zeros. This function achieves casting of + !> @brief Procedure for converting integer to string, prefixing with the right number of zeros. This function achieves casting of !> integer to string. elemental function strz_I4P(nz_pad,n) result(str) !--------------------------------------------------------------------------------------------------------------------------------- @@ -598,7 +769,7 @@ contains !--------------------------------------------------------------------------------------------------------------------------------- endfunction strz_I4P - !> @brief Function for converting integer to string, prefixing with the right number of zeros. This function achieves casting of + !> @brief Procedure for converting integer to string, prefixing with the right number of zeros. This function achieves casting of !> integer to string. elemental function strz_I2P(nz_pad,n) result(str) !--------------------------------------------------------------------------------------------------------------------------------- @@ -616,7 +787,7 @@ contains !--------------------------------------------------------------------------------------------------------------------------------- endfunction strz_I2P - !> @brief Function for converting integer to string, prefixing with the right number of zeros. This function achieves casting of + !> @brief Procedure for converting integer to string, prefixing with the right number of zeros. This function achieves casting of !> integer to string. elemental function strz_I1P(nz_pad,n) result(str) !--------------------------------------------------------------------------------------------------------------------------------- @@ -634,8 +805,7 @@ contains !--------------------------------------------------------------------------------------------------------------------------------- endfunction strz_I1P -#ifdef r16p - !> @brief Function for converting string to real. This function achieves casting of string to real. + !> @brief Procedure for converting string to real. This function achieves casting of string to real. function ctor_R16P(str,knd) result(n) !--------------------------------------------------------------------------------------------------------------------------------- implicit none @@ -655,9 +825,8 @@ contains return !--------------------------------------------------------------------------------------------------------------------------------- endfunction ctor_R16P -#endif - !> @brief Function for converting string to real. This function achieves casting of string to real. + !> @brief Procedure for converting string to real. This function achieves casting of string to real. function ctor_R8P(str,knd) result(n) !--------------------------------------------------------------------------------------------------------------------------------- implicit none @@ -678,7 +847,7 @@ contains !--------------------------------------------------------------------------------------------------------------------------------- endfunction ctor_R8P - !> @brief Function for converting string to real. This function achieves casting of string to real. + !> @brief Procedure for converting string to real. This function achieves casting of string to real. function ctor_R4P(str,knd) result(n) !--------------------------------------------------------------------------------------------------------------------------------- implicit none @@ -699,7 +868,7 @@ contains !--------------------------------------------------------------------------------------------------------------------------------- endfunction ctor_R4P - !> @brief Function for converting string to integer. This function achieves casting of string to integer. + !> @brief Procedure for converting string to integer. This function achieves casting of string to integer. function ctoi_I8P(str,knd) result(n) !--------------------------------------------------------------------------------------------------------------------------------- implicit none @@ -720,7 +889,7 @@ contains !--------------------------------------------------------------------------------------------------------------------------------- endfunction ctoi_I8P - !> @brief Function for converting string to integer. This function achieves casting of string to integer. + !> @brief Procedure for converting string to integer. This function achieves casting of string to integer. function ctoi_I4P(str,knd) result(n) !--------------------------------------------------------------------------------------------------------------------------------- implicit none @@ -741,7 +910,7 @@ contains !--------------------------------------------------------------------------------------------------------------------------------- endfunction ctoi_I4P - !> @brief Function for converting string to integer. This function achieves casting of string to integer. + !> @brief Procedure for converting string to integer. This function achieves casting of string to integer. function ctoi_I2P(str,knd) result(n) !--------------------------------------------------------------------------------------------------------------------------------- implicit none @@ -762,7 +931,7 @@ contains !--------------------------------------------------------------------------------------------------------------------------------- endfunction ctoi_I2P - !> @brief Function for converting string to integer. This function achieves casting of string to integer. + !> @brief Procedure for converting string to integer. This function achieves casting of string to integer. function ctoi_I1P(str,knd) result(n) !--------------------------------------------------------------------------------------------------------------------------------- implicit none @@ -782,6 +951,201 @@ contains return !--------------------------------------------------------------------------------------------------------------------------------- endfunction ctoi_I1P + + !> @brief Procedure for converting real to string of bits. This function achieves casting of real to bit-string. + !> @note It is assumed that R16P is represented by means of 128 bits, but this is not ensured in all architectures. + elemental function bstr_R16P(n) result(bstr) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + real(R8P), intent(IN):: n !< Real to be converted. + character(128):: bstr !< Returned bit-string containing input number. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + write(bstr,'(B128.128)')n ! Casting of n to bit-string. + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction bstr_R16P + + !> @brief Procedure for converting real to string of bits. This function achieves casting of real to bit-string. + !> @note It is assumed that R8P is represented by means of 64 bits, but this is not ensured in all architectures. + elemental function bstr_R8P(n) result(bstr) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + real(R8P), intent(IN):: n !< Real to be converted. + character(64):: bstr !< Returned bit-string containing input number. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + write(bstr,'(B64.64)')n ! Casting of n to bit-string. + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction bstr_R8P + + !> @brief Procedure for converting real to string of bits. This function achieves casting of real to bit-string. + !> @note It is assumed that R4P is represented by means of 32 bits, but this is not ensured in all architectures. + elemental function bstr_R4P(n) result(bstr) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + real(R4P), intent(IN):: n !< Real to be converted. + character(32):: bstr !< Returned bit-string containing input number. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + write(bstr,'(B32.32)')n ! Casting of n to bit-string. + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction bstr_R4P + + !> @brief Procedure for converting integer to string of bits. This function achieves casting of integer to bit-string. + !> @note It is assumed that I8P is represented by means of 64 bits, but this is not ensured in all architectures. + elemental function bstr_I8P(n) result(bstr) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I8P), intent(IN):: n !< Real to be converted. + character(64):: bstr !< Returned bit-string containing input number. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + write(bstr,'(B64.64)')n ! Casting of n to bit-string. + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction bstr_I8P + + !> @brief Procedure for converting integer to string of bits. This function achieves casting of integer to bit-string. + !> @note It is assumed that I4P is represented by means of 32 bits, but this is not ensured in all architectures. + elemental function bstr_I4P(n) result(bstr) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: n !< Real to be converted. + character(32):: bstr !< Returned bit-string containing input number. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + write(bstr,'(B32.32)')n ! Casting of n to bit-string. + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction bstr_I4P + + !> @brief Procedure for converting integer to string of bits. This function achieves casting of integer to bit-string. + !> @note It is assumed that I2P is represented by means of 16 bits, but this is not ensured in all architectures. + elemental function bstr_I2P(n) result(bstr) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I2P), intent(IN):: n !< Real to be converted. + character(16):: bstr !< Returned bit-string containing input number. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + write(bstr,'(B16.16)')n ! Casting of n to bit-string. + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction bstr_I2P + + !> @brief Procedure for converting integer to string of bits. This function achieves casting of integer to bit-string. + !> @note It is assumed that I1P is represented by means of 8 bits, but this is not ensured in all architectures. + elemental function bstr_I1P(n) result(bstr) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I1P), intent(IN):: n !< Real to be converted. + character(8):: bstr !< Returned bit-string containing input number. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + write(bstr,'(B8.8)')n ! Casting of n to bit-string. + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction bstr_I1P + + !> @brief Procedure for converting bit-string to real. This function achieves casting of bit-string to real. + elemental function bctor_R8P(bstr,knd) result(n) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + character(*), intent(IN):: bstr !< String containing input number. + real(R8P), intent(IN):: knd !< Number kind. + real(R8P):: n !< Number returned. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + read(bstr,'(B'//trim(str(.true.,bit_size(knd)))//'.'//trim(str(.true.,bit_size(knd)))//')')n ! Casting of bstr to n. + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction bctor_R8P + + !> @brief Procedure for converting bit-string to real. This function achieves casting of bit-string to real. + elemental function bctor_R4P(bstr,knd) result(n) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + character(*), intent(IN):: bstr !< String containing input number. + real(R4P), intent(IN):: knd !< Number kind. + real(R4P):: n !< Number returned. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + read(bstr,'(B'//trim(str(.true.,bit_size(knd)))//'.'//trim(str(.true.,bit_size(knd)))//')')n ! Casting of bstr to n. + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction bctor_R4P + + !> @brief Procedure for converting bit-string to integer. This function achieves casting of bit-string to integer. + elemental function bctoi_I8P(bstr,knd) result(n) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + character(*), intent(IN):: bstr !< String containing input number. + integer(I8P), intent(IN):: knd !< Number kind. + integer(I8P):: n !< Number returned. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + read(bstr,'(B'//trim(str(.true.,bit_size(knd)))//'.'//trim(str(.true.,bit_size(knd)))//')')n ! Casting of bstr to n. + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction bctoi_I8P + + !> @brief Procedure for converting bit-string to integer. This function achieves casting of bit-string to integer. + elemental function bctoi_I4P(bstr,knd) result(n) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + character(*), intent(IN):: bstr !< String containing input number. + integer(I4P), intent(IN):: knd !< Number kind. + integer(I4P):: n !< Number returned. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + read(bstr,'(B'//trim(str(.true.,bit_size(knd)))//'.'//trim(str(.true.,bit_size(knd)))//')')n ! Casting of bstr to n. + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction bctoi_I4P + + !> @brief Procedure for converting bit-string to integer. This function achieves casting of bit-string to integer. + elemental function bctoi_I2P(bstr,knd) result(n) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + character(*), intent(IN):: bstr !< String containing input number. + integer(I2P), intent(IN):: knd !< Number kind. + integer(I2P):: n !< Number returned. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + read(bstr,'(B'//trim(str(.true.,bit_size(knd)))//'.'//trim(str(.true.,bit_size(knd)))//')')n ! Casting of bstr to n. + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction bctoi_I2P + + !> @brief Procedure for converting bit-string to integer. This function achieves casting of bit-string to integer. + elemental function bctoi_I1P(bstr,knd) result(n) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + character(*), intent(IN):: bstr !< String containing input number. + integer(I1P), intent(IN):: knd !< Number kind. + integer(I1P):: n !< Number returned. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + read(bstr,'(B'//trim(str(.true.,bit_size(knd)))//'.'//trim(str(.true.,bit_size(knd)))//')')n ! Casting of bstr to n. + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction bctoi_I1P !> @} !> Subroutine for initilizing module's variables that are not initialized into the definition specification. @@ -795,12 +1159,10 @@ contains ! 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 + BIR16P = bit_size(r=MaxR16P) ; BYR16P = BIR16P/8_I2P + BIR8P = bit_size(r=MaxR8P) ; BYR8P = BIR8P/8_I1P + BIR4P = bit_size(r=MaxR4P) ; BYR4P = BIR4P/8_I1P + BIR_P = bit_size(r=MaxR_P) ; BYR_P = BIR_P/8_I1P ir_initialized = .true. return !--------------------------------------------------------------------------------------------------------------------------------- @@ -808,60 +1170,57 @@ contains !>Subroutine for printing to the standard output the kind definition of reals and integers and the utility variables. !> @ingroup IR_PrecisionPublicProcedure - subroutine IR_Print() + subroutine IR_Print(myrank,Nproc) !--------------------------------------------------------------------------------------------------------------------------------- implicit none + integer(I4P), intent(IN), optional:: myrank !< Actual rank process necessary for concurrent multi-processes calls. + integer(I4P), intent(IN), optional:: Nproc !< Number of MPI processes used. + character(DI4P):: rks !< String containing myrank. + integer(I4P):: rank,Np !< Dummy temporary variables. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - call IR_init + if (.not.ir_initialized) call IR_init + rank = 0 ; if (present(myrank)) rank = myrank ; Np = 1 ; if (present(Nproc)) Np = Nproc ; rks = 'rank'//trim(strz(Np,rank)) ! printing informations if (endian==endianL) then - write(stdout,'(A)') ' This architecture has LITTLE Endian bit ordering' + write(stdout,'(A)') trim(rks)//' This architecture has LITTLE Endian bit ordering' else - write(stdout,'(A)') ' This architecture has BIG Endian bit ordering' + write(stdout,'(A)') trim(rks)//' 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 + write(stdout,'(A)') trim(rks)//' Reals kind precision definition' + write(stdout,'(A,I2,A,I2,A)')trim(rks)//' R16P Kind "',R16P,'" | FR16P format "'//FR16P//'" | DR16P chars "',DR16P,'"' + write(stdout,'(A,I2,A,I2,A)')trim(rks)//' R8P Kind "',R8P, '" | FR8P format "'//FR8P// '" | DR8P chars "',DR8P ,'"' + write(stdout,'(A,I2,A,I2,A)')trim(rks)//' R4P Kind "',R4P, '" | FR4P format "'//FR4P//'" | DR4P chars "',DR4P ,'"' + write(stdout,'(A)') trim(rks)//' Integers kind precision definition' + write(stdout,'(A,I2,A,I2,A)')trim(rks)//' I8P Kind "',I8P,'" | FI8P format "'//FI8P// '" | DI8P chars "',DI8P,'"' + write(stdout,'(A,I2,A,I2,A)')trim(rks)//' I4P Kind "',I4P,'" | FI4P format "'//FI4P// '" | DI4P chars "',DI4P,'"' + write(stdout,'(A,I2,A,I2,A)')trim(rks)//' I2P Kind "',I2P,'" | FI2P format "'//FI2P//'" | DI2P chars "',DI2P,'"' + write(stdout,'(A,I2,A,I2,A)')trim(rks)//' I1P Kind "',I1P,'" | FI1P format "'//FI1P//'" | DI1P chars "',DI1P,'"' + write(stdout,'(A)') trim(rks)//' Reals minimum and maximum values' + write(stdout,'(A)') trim(rks)//' MinR16P "'//trim(str(n=MinR16P))//'" | MaxR16P "'//trim(str(n=MaxR16P))//'"' + write(stdout,'(A)') trim(rks)//' MinR8P "'//trim(str(n=MinR8P))// '" | MaxR8P "'//trim(str(n=MaxR8P))// '"' + write(stdout,'(A)') trim(rks)//' MinR4P "'//trim(str(n=MinR4P))// '" | MaxR4P "'//trim(str(n=MaxR4P))// '"' + write(stdout,'(A)') trim(rks)//' Reals bits/bytes sizes' + write(stdout,'(A,I2,A,I2,A)')trim(rks)//' R16P bits "',BIR16P,'", bytes "',BYR16P,'"' + write(stdout,'(A,I2,A,I2,A)')trim(rks)//' R8P bits "', BIR8P, '", bytes "',BYR8P, '"' + write(stdout,'(A,I2,A,I2,A)')trim(rks)//' R4P bits "', BIR4P, '", bytes "',BYR4P, '"' + write(stdout,'(A,I2,A,I2,A)')trim(rks)//' R_P bits "', BIR_P, '", bytes "',BYR_P, '"' + write(stdout,'(A)') trim(rks)//' Integers minimum and maximum values' + write(stdout,'(A)') trim(rks)//' MinI8P "'//trim(str(n=MinI8P))//'" | MaxI8P "'//trim(str(n=MaxI8P))//'"' + write(stdout,'(A)') trim(rks)//' MinI4P "'//trim(str(n=MinI4P))//'" | MaxI4P "'//trim(str(n=MaxI4P))//'"' + write(stdout,'(A)') trim(rks)//' MinI2P "'//trim(str(n=MinI2P))//'" | MaxI2P "'//trim(str(n=MaxI2P))//'"' + write(stdout,'(A)') trim(rks)//' MinI1P "'//trim(str(n=MinI1P))//'" | MaxI1P "'//trim(str(n=MaxI1P))//'"' + write(stdout,'(A)') trim(rks)//' Integers bits/bytes sizes' + write(stdout,'(A,I2,A,I2,A)')trim(rks)//' I8P bits "',BII8P,'", bytes "',BYI8P,'"' + write(stdout,'(A,I2,A,I2,A)')trim(rks)//' I4P bits "',BII4P,'", bytes "',BYI4P,'"' + write(stdout,'(A,I2,A,I2,A)')trim(rks)//' I2P bits "',BII2P,'", bytes "',BYI2P,'"' + write(stdout,'(A,I2,A,I2,A)')trim(rks)//' I1P bits "',BII1P,'", bytes "',BYI1P,'"' + write(stdout,'(A,I2,A,I2,A)')trim(rks)//' I_P bits "',BII_P,'", bytes "',BYI_P,'"' + write(stdout,'(A)') trim(rks)//' Machine precisions' + write(stdout,'(A)') trim(rks)//' ZeroR16 "'//trim(str(.true.,ZeroR16))//'"' + write(stdout,'(A)') trim(rks)//' ZeroR8 "'//trim(str(.true.,ZeroR8 ))//'"' + write(stdout,'(A)') trim(rks)//' ZeroR4 "'//trim(str(.true.,ZeroR4 ))//'"' !--------------------------------------------------------------------------------------------------------------------------------- endsubroutine IR_Print endmodule IR_Precision diff --git a/lib/Lib_Base64.f90 b/lib/Lib_Base64.f90 new file mode 100644 index 000000000..03de85c04 --- /dev/null +++ b/lib/Lib_Base64.f90 @@ -0,0 +1,909 @@ +!> @ingroup Library +!> @{ +!> @defgroup Lib_Base64Library Lib_Base64 +!> base64 encoding/decoding library +!> @} + +!> @ingroup Interface +!> @{ +!> @defgroup Lib_Base64Interface Lib_Base64 +!> base64 encoding/decoding library +!> @} + +!> @ingroup PublicProcedure +!> @{ +!> @defgroup Lib_Base64PublicProcedure Lib_Base64 +!> base64 encoding/decoding library +!> @} + +!> @ingroup PrivateProcedure +!> @{ +!> @defgroup Lib_Base64PrivateProcedure Lib_Base64 +!> base64 encoding/decoding library +!> @} + +!> @ingroup GlobalVarPar +!> @{ +!> @defgroup Lib_Base64GlobalVarPar Lib_Base64 +!> base64 encoding/decoding library +!> @} + +!> @ingroup PrivateVarPar +!> @{ +!> @defgroup Lib_Base64PrivateVarPar Lib_Base64 +!> base64 encoding/decoding library +!> @} + +!> This module contains base64 encoding/decoding procedures. +!> @todo \b Decoding: Implement decoding functions. +!> @todo \b DocComplete: Complete the documentation. +!> @ingroup Lib_Base64Library +module Lib_Base64 +!----------------------------------------------------------------------------------------------------------------------------------- +USE IR_Precision ! Integers and reals precision definition. +!----------------------------------------------------------------------------------------------------------------------------------- + +!----------------------------------------------------------------------------------------------------------------------------------- +implicit none +private +public:: b64_encode +!public:: b64_decode +public:: pack_data +!----------------------------------------------------------------------------------------------------------------------------------- + +!----------------------------------------------------------------------------------------------------------------------------------- +!> @ingroup Lib_Base64GlobalVarPar +!> @{ +!> @} +!> @ingroup Lib_Base64PrivateVarPar +!> @{ +character(64):: base64="ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" !< Base64 alphabet. +!> @} +!----------------------------------------------------------------------------------------------------------------------------------- + +!----------------------------------------------------------------------------------------------------------------------------------- +!> @brief Subroutine for encoding numbers (integer and real) to base64. +!> @ingroup Lib_Base64Interface +interface b64_encode + module procedure b64_encode_R8_a, & + b64_encode_R4_a, & + b64_encode_I8_a, & + b64_encode_I4_a, & + b64_encode_I2_a, & + b64_encode_I1_a +endinterface +!!> @brief Subroutine for decoding numbers (integer and real) from base64. +!!> @ingroup Lib_Base64Interface +!interface b64_decode +! module procedure b64_decode_R8_a, & +! b64_decode_R4_a, & +! b64_decode_I8_a, & +! b64_decode_I4_a, & +! b64_decode_I2_a, & +! b64_decode_I1_a +!endinterface +!> @brief Subroutine for packing different kinds of data into single I1P array. This is useful for encoding different kinds +!> variables into a single stream of bits. +!> @ingroup Lib_Base64Interface +interface pack_data + module procedure pack_data_R8_R4,pack_data_R8_I8,pack_data_R8_I4,pack_data_R8_I2,pack_data_R8_I1, & + pack_data_R4_R8,pack_data_R4_I8,pack_data_R4_I4,pack_data_R4_I2,pack_data_R4_I1, & + pack_data_I8_R8,pack_data_I8_R4,pack_data_I8_I4,pack_data_I8_I2,pack_data_I8_I1, & + pack_data_I4_R8,pack_data_I4_R4,pack_data_I4_I8,pack_data_I4_I2,pack_data_I4_I1, & + pack_data_I2_R8,pack_data_I2_R4,pack_data_I2_I8,pack_data_I2_I4,pack_data_I2_I1, & + pack_data_I1_R8,pack_data_I1_R4,pack_data_I1_I8,pack_data_I1_I4,pack_data_I1_I2 +endinterface +!----------------------------------------------------------------------------------------------------------------------------------- +contains + !> @ingroup Lib_Base64PrivateProcedure + !> @{ + !> @brief Subroutine for packing different kinds of data into single I1P array. + pure subroutine pack_data_R8_R4(a1,a2,packed) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + real(R8P), intent(IN):: a1(1:) !< Firs data stream. + real(R4P), intent(IN):: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. + integer(I4P):: np !< Size of temporary packed data. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) + np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) + if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] + deallocate(p1,p2) + return + !--------------------------------------------------------------------------------------------------------------------------------- + endsubroutine pack_data_R8_R4 + + !> @brief Subroutine for packing different kinds of data into single I1P array. + pure subroutine pack_data_R8_I8(a1,a2,packed) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + real(R8P), intent(IN):: a1(1:) !< First data stream. + integer(I8P), intent(IN):: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. + integer(I4P):: np !< Size of temporary packed data. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) + np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) + if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] + deallocate(p1,p2) + return + !--------------------------------------------------------------------------------------------------------------------------------- + endsubroutine pack_data_R8_I8 + + !> @brief Subroutine for packing different kinds of data into single I1P array. + pure subroutine pack_data_R8_I4(a1,a2,packed) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + real(R8P), intent(IN):: a1(1:) !< First data stream. + integer(I4P), intent(IN):: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. + integer(I4P):: np !< Size of temporary packed data. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) + np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) + if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] + deallocate(p1,p2) + return + !--------------------------------------------------------------------------------------------------------------------------------- + endsubroutine pack_data_R8_I4 + + !> @brief Subroutine for packing different kinds of data into single I1P array. + pure subroutine pack_data_R8_I2(a1,a2,packed) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + real(R8P), intent(IN):: a1(1:) !< First data stream. + integer(I2P), intent(IN):: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. + integer(I4P):: np !< Size of temporary packed data. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) + np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) + if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] + deallocate(p1,p2) + return + !--------------------------------------------------------------------------------------------------------------------------------- + endsubroutine pack_data_R8_I2 + + !> @brief Subroutine for packing different kinds of data into single I1P array. + pure subroutine pack_data_R8_I1(a1,a2,packed) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + real(R8P), intent(IN):: a1(1:) !< First data stream. + integer(I1P), intent(IN):: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. + integer(I4P):: np !< Size of temporary packed data. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) + np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) + if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] + deallocate(p1,p2) + return + !--------------------------------------------------------------------------------------------------------------------------------- + endsubroutine pack_data_R8_I1 + + !> @brief Subroutine for packing different kinds of data into single I1P array. + pure subroutine pack_data_R4_R8(a1,a2,packed) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + real(R4P), intent(IN):: a1(1:) !< Firs data stream. + real(R8P), intent(IN):: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. + integer(I4P):: np !< Size of temporary packed data. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) + np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) + if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] + deallocate(p1,p2) + return + !--------------------------------------------------------------------------------------------------------------------------------- + endsubroutine pack_data_R4_R8 + + !> @brief Subroutine for packing different kinds of data into single I1P array. + pure subroutine pack_data_R4_I8(a1,a2,packed) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + real(R4P), intent(IN):: a1(1:) !< First data stream. + integer(I8P), intent(IN):: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. + integer(I4P):: np !< Size of temporary packed data. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) + np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) + if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] + deallocate(p1,p2) + return + !--------------------------------------------------------------------------------------------------------------------------------- + endsubroutine pack_data_R4_I8 + + !> @brief Subroutine for packing different kinds of data into single I1P array. + pure subroutine pack_data_R4_I4(a1,a2,packed) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + real(R4P), intent(IN):: a1(1:) !< First data stream. + integer(I4P), intent(IN):: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. + integer(I4P):: np !< Size of temporary packed data. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) + np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) + if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] + deallocate(p1,p2) + return + !--------------------------------------------------------------------------------------------------------------------------------- + endsubroutine pack_data_R4_I4 + + !> @brief Subroutine for packing different kinds of data into single I1P array. + pure subroutine pack_data_R4_I2(a1,a2,packed) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + real(R4P), intent(IN):: a1(1:) !< First data stream. + integer(I2P), intent(IN):: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. + integer(I4P):: np !< Size of temporary packed data. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) + np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) + if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] + deallocate(p1,p2) + return + !--------------------------------------------------------------------------------------------------------------------------------- + endsubroutine pack_data_R4_I2 + + !> @brief Subroutine for packing different kinds of data into single I1P array. + pure subroutine pack_data_R4_I1(a1,a2,packed) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + real(R4P), intent(IN):: a1(1:) !< First data stream. + integer(I1P), intent(IN):: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. + integer(I4P):: np !< Size of temporary packed data. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) + np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) + if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] + deallocate(p1,p2) + return + !--------------------------------------------------------------------------------------------------------------------------------- + endsubroutine pack_data_R4_I1 + + !> @brief Subroutine for packing different kinds of data into single I1P array. + pure subroutine pack_data_I8_R8(a1,a2,packed) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I8P), intent(IN):: a1(1:) !< First data stream. + real(R8P), intent(IN):: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. + integer(I4P):: np !< Size of temporary packed data. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) + np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) + if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] + deallocate(p1,p2) + return + !--------------------------------------------------------------------------------------------------------------------------------- + endsubroutine pack_data_I8_R8 + + !> @brief Subroutine for packing different kinds of data into single I1P array. + pure subroutine pack_data_I8_R4(a1,a2,packed) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I8P), intent(IN):: a1(1:) !< First data stream. + real(R4P), intent(IN):: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. + integer(I4P):: np !< Size of temporary packed data. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) + np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) + if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] + deallocate(p1,p2) + return + !--------------------------------------------------------------------------------------------------------------------------------- + endsubroutine pack_data_I8_R4 + + !> @brief Subroutine for packing different kinds of data into single I1P array. + pure subroutine pack_data_I8_I4(a1,a2,packed) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I8P), intent(IN):: a1(1:) !< First data stream. + integer(I4P), intent(IN):: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. + integer(I4P):: np !< Size of temporary packed data. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) + np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) + if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] + deallocate(p1,p2) + return + !--------------------------------------------------------------------------------------------------------------------------------- + endsubroutine pack_data_I8_I4 + + !> @brief Subroutine for packing different kinds of data into single I1P array. + pure subroutine pack_data_I8_I2(a1,a2,packed) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I8P), intent(IN):: a1(1:) !< First data stream. + integer(I2P), intent(IN):: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. + integer(I4P):: np !< Size of temporary packed data. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) + np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) + if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] + deallocate(p1,p2) + return + !--------------------------------------------------------------------------------------------------------------------------------- + endsubroutine pack_data_I8_I2 + + !> @brief Subroutine for packing different kinds of data into single I1P array. + pure subroutine pack_data_I8_I1(a1,a2,packed) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I8P), intent(IN):: a1(1:) !< First data stream. + integer(I1P), intent(IN):: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. + integer(I4P):: np !< Size of temporary packed data. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) + np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) + if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] + deallocate(p1,p2) + return + !--------------------------------------------------------------------------------------------------------------------------------- + endsubroutine pack_data_I8_I1 + + !> @brief Subroutine for packing different kinds of data into single I1P array. + pure subroutine pack_data_I4_R8(a1,a2,packed) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: a1(1:) !< First data stream. + real(R8P), intent(IN):: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. + integer(I4P):: np !< Size of temporary packed data. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) + np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) + if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] + deallocate(p1,p2) + return + !--------------------------------------------------------------------------------------------------------------------------------- + endsubroutine pack_data_I4_R8 + + !> @brief Subroutine for packing different kinds of data into single I1P array. + pure subroutine pack_data_I4_R4(a1,a2,packed) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: a1(1:) !< First data stream. + real(R4P), intent(IN):: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. + integer(I4P):: np !< Size of temporary packed data. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) + np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) + if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] + deallocate(p1,p2) + return + !--------------------------------------------------------------------------------------------------------------------------------- + endsubroutine pack_data_I4_R4 + + !> @brief Subroutine for packing different kinds of data into single I1P array. + pure subroutine pack_data_I4_I8(a1,a2,packed) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: a1(1:) !< First data stream. + integer(I8P), intent(IN):: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. + integer(I4P):: np !< Size of temporary packed data. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) + np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) + if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] + deallocate(p1,p2) + return + !--------------------------------------------------------------------------------------------------------------------------------- + endsubroutine pack_data_I4_I8 + + !> @brief Subroutine for packing different kinds of data into single I1P array. + pure subroutine pack_data_I4_I2(a1,a2,packed) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: a1(1:) !< First data stream. + integer(I2P), intent(IN):: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. + integer(I4P):: np !< Size of temporary packed data. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) + np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) + if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] + deallocate(p1,p2) + return + !--------------------------------------------------------------------------------------------------------------------------------- + endsubroutine pack_data_I4_I2 + + !> @brief Subroutine for packing different kinds of data into single I1P array. + pure subroutine pack_data_I4_I1(a1,a2,packed) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: a1(1:) !< First data stream. + integer(I1P), intent(IN):: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. + integer(I4P):: np !< Size of temporary packed data. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) + np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) + if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] + deallocate(p1,p2) + return + !--------------------------------------------------------------------------------------------------------------------------------- + endsubroutine pack_data_I4_I1 + + !> @brief Subroutine for packing different kinds of data into single I1P array. + pure subroutine pack_data_I2_R8(a1,a2,packed) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I2P), intent(IN):: a1(1:) !< First data stream. + real(R8P), intent(IN):: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. + integer(I4P):: np !< Size of temporary packed data. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) + np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) + if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] + deallocate(p1,p2) + return + !--------------------------------------------------------------------------------------------------------------------------------- + endsubroutine pack_data_I2_R8 + + !> @brief Subroutine for packing different kinds of data into single I1P array. + pure subroutine pack_data_I2_R4(a1,a2,packed) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I2P), intent(IN):: a1(1:) !< First data stream. + real(R4P), intent(IN):: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. + integer(I4P):: np !< Size of temporary packed data. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) + np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) + if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] + deallocate(p1,p2) + return + !--------------------------------------------------------------------------------------------------------------------------------- + endsubroutine pack_data_I2_R4 + + !> @brief Subroutine for packing different kinds of data into single I1P array. + pure subroutine pack_data_I2_I8(a1,a2,packed) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I2P), intent(IN):: a1(1:) !< First data stream. + integer(I8P), intent(IN):: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. + integer(I4P):: np !< Size of temporary packed data. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) + np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) + if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] + deallocate(p1,p2) + return + !--------------------------------------------------------------------------------------------------------------------------------- + endsubroutine pack_data_I2_I8 + + !> @brief Subroutine for packing different kinds of data into single I1P array. + pure subroutine pack_data_I2_I4(a1,a2,packed) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I2P), intent(IN):: a1(1:) !< First data stream. + integer(I4P), intent(IN):: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. + integer(I4P):: np !< Size of temporary packed data. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) + np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) + if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] + deallocate(p1,p2) + return + !--------------------------------------------------------------------------------------------------------------------------------- + endsubroutine pack_data_I2_I4 + + !> @brief Subroutine for packing different kinds of data into single I1P array. + pure subroutine pack_data_I2_I1(a1,a2,packed) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I2P), intent(IN):: a1(1:) !< First data stream. + integer(I1P), intent(IN):: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. + integer(I4P):: np !< Size of temporary packed data. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) + np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) + if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] + deallocate(p1,p2) + return + !--------------------------------------------------------------------------------------------------------------------------------- + endsubroutine pack_data_I2_I1 + + !> @brief Subroutine for packing different kinds of data into single I1P array. + pure subroutine pack_data_I1_R8(a1,a2,packed) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I1P), intent(IN):: a1(1:) !< First data stream. + real(R8P), intent(IN):: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. + integer(I4P):: np !< Size of temporary packed data. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) + np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) + if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] + deallocate(p1,p2) + return + !--------------------------------------------------------------------------------------------------------------------------------- + endsubroutine pack_data_I1_R8 + + !> @brief Subroutine for packing different kinds of data into single I1P array. + pure subroutine pack_data_I1_R4(a1,a2,packed) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I1P), intent(IN):: a1(1:) !< First data stream. + real(R4P), intent(IN):: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. + integer(I4P):: np !< Size of temporary packed data. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) + np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) + if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] + deallocate(p1,p2) + return + !--------------------------------------------------------------------------------------------------------------------------------- + endsubroutine pack_data_I1_R4 + + !> @brief Subroutine for packing different kinds of data into single I1P array. + pure subroutine pack_data_I1_I8(a1,a2,packed) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I1P), intent(IN):: a1(1:) !< First data stream. + integer(I8P), intent(IN):: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. + integer(I4P):: np !< Size of temporary packed data. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) + np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) + if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] + deallocate(p1,p2) + return + !--------------------------------------------------------------------------------------------------------------------------------- + endsubroutine pack_data_I1_I8 + + !> @brief Subroutine for packing different kinds of data into single I1P array. + pure subroutine pack_data_I1_I4(a1,a2,packed) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I1P), intent(IN):: a1(1:) !< First data stream. + integer(I4P), intent(IN):: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. + integer(I4P):: np !< Size of temporary packed data. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) + np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) + if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] + deallocate(p1,p2) + return + !--------------------------------------------------------------------------------------------------------------------------------- + endsubroutine pack_data_I1_I4 + + !> @brief Subroutine for packing different kinds of data into single I1P array. + pure subroutine pack_data_I1_I2(a1,a2,packed) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I1P), intent(IN):: a1(1:) !< First data stream. + integer(I2P), intent(IN):: a2(1:) !< Second data stream. + integer(I1P), allocatable, intent(INOUT):: packed(:) !< Packed data into I1P array. + integer(I1P), allocatable:: p1(:) !< Temporary packed data of first stream. + integer(I1P), allocatable:: p2(:) !< Temporary packed data of second stream. + integer(I4P):: np !< Size of temporary packed data. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + np = size(transfer(a1,p1)) ; allocate(p1(1:np)) ; p1 = transfer(a1,p1) + np = size(transfer(a2,p2)) ; allocate(p2(1:np)) ; p2 = transfer(a2,p2) + if (allocated(packed)) deallocate(packed) ; allocate(packed(1:size(p1,dim=1)+size(p2,dim=1))) ; packed = [p1,p2] + deallocate(p1,p2) + return + !--------------------------------------------------------------------------------------------------------------------------------- + endsubroutine pack_data_I1_I2 + + !> @brief Subroutine for encoding bits (must be multiple of 24 bits) into base64 charcaters code (of length multiple of 4). + !> @note The bits stream are encoded in chunks of 24 bits as the following example (in little endian order): + !> @code + !> +--first octet--+-second octet--+--third octet--+ + !> |7 6 5 4 3 2 1 0|7 6 5 4 3 2 1 0|7 6 5 4 3 2 1 0| + !> +-----------+---+-------+-------+---+-----------+ + !> |5 4 3 2 1 0|5 4 3 2 1 0|5 4 3 2 1 0|5 4 3 2 1 0| + !> +--1.index--+--2.index--+--3.index--+--4.index--+ + !> @endcode + !> The 4 indexes are stored into 4 elements 8 bits array, thus 2 bits of each array element are not used. + pure subroutine encode_bits(bits,padd,code) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I1P), intent(IN):: bits(1:) !< Bits to be encoded. + integer(I4P), intent(IN):: padd !< Number of padding characters ('='). + character(1), intent(OUT):: code(1:) !< Characters code. + integer(I1P):: sixb(1:4) !< 6 bits slices (stored into 8 bits integer) of 24 bits input. + integer(I8P):: c,e !< Counters. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + c = 1_I8P + do e=1_I8P,size(bits,dim=1),3_I8P ! loop over array elements: 3 bytes (24 bits) scanning + sixb = 0_I1P + call mvbits(bits(e ),2,6,sixb(1),0) + call mvbits(bits(e ),0,2,sixb(2),4) ; call mvbits(bits(e+1),4,4,sixb(2),0) + call mvbits(bits(e+1),0,4,sixb(3),2) ; call mvbits(bits(e+2),6,2,sixb(3),0) + call mvbits(bits(e+2),0,6,sixb(4),0) + sixb = sixb + 1_I1P + code(c :c )(1:1) = base64(sixb(1):sixb(1)) + code(c+1:c+1)(1:1) = base64(sixb(2):sixb(2)) + code(c+2:c+2)(1:1) = base64(sixb(3):sixb(3)) + code(c+3:c+3)(1:1) = base64(sixb(4):sixb(4)) + c = c + 4_I8P + enddo + if (padd>0) code(size(code,dim=1)-padd+1:)(1:1)='=' + return + !--------------------------------------------------------------------------------------------------------------------------------- + endsubroutine encode_bits + + !> @brief Subroutine for encoding array numbers to base64 (R8P). + pure subroutine b64_encode_R8_a(nB,n,code) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: nB !< Number of bytes of single element of n. + real(R8P), intent(IN):: n(1:) !< Array of numbers to be encoded. + character(1), allocatable, intent(OUT):: code(:) !< Encoded array. + integer(I1P):: nI1P(1:((size(n,dim=1)*nB+2)/3)*3) !< One byte integer array containing n. + integer(I4P):: padd !< Number of padding characters ('='). + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (allocated(code)) deallocate(code) ; allocate(code(1:((size(n,dim=1)*nB+2)/3)*4)) ! allocating code chars + nI1P = transfer(n,nI1P) ! casting n to integer array of 1 byte elem + padd = mod((size(n,dim=1)*nB),3_I4P) ; if (padd>0_I4P) padd = 3_I4P - padd ! computing the number of padding characters + call encode_bits(bits=nI1P,padd=padd,code=code) ! encoding bits + return + !--------------------------------------------------------------------------------------------------------------------------------- + endsubroutine b64_encode_R8_a + + !> @brief Subroutine for encoding array numbers to base64 (R4P). + pure subroutine b64_encode_R4_a(nB,n,code) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: nB !< Number of bytes of single element of n. + real(R4P), intent(IN):: n(1:) !< Array of numbers to be encoded. + character(1), allocatable, intent(OUT):: code(:) !< Encoded array. + integer(I1P):: nI1P(1:((size(n,dim=1)*nB+2)/3)*3) !< One byte integer array containing n. + integer(I4P):: padd !< Number of padding characters ('='). + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (allocated(code)) deallocate(code) ; allocate(code(1:((size(n,dim=1)*nB+2)/3)*4)) ! allocating code chars + nI1P = transfer(n,nI1P) ! casting n to integer array of 1 byte elem + padd = mod((size(n,dim=1)*nB),3_I4P) ; if (padd>0_I4P) padd = 3_I4P - padd ! computing the number of padding characters + call encode_bits(bits=nI1P,padd=padd,code=code) ! encoding bits + return + !--------------------------------------------------------------------------------------------------------------------------------- + endsubroutine b64_encode_R4_a + + !> @brief Subroutine for encoding array numbers to base64 (I8P). + pure subroutine b64_encode_I8_a(nB,n,code) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: nB !< Number of bytes of single element of n. + integer(I8P), intent(IN):: n(1:) !< Array of numbers to be encoded. + character(1), allocatable, intent(OUT):: code(:) !< Encoded array. + integer(I1P):: nI1P(1:((size(n,dim=1)*nB+2)/3)*3) !< One byte integer array containing n. + integer(I4P):: padd !< Number of padding characters ('='). + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (allocated(code)) deallocate(code) ; allocate(code(1:((size(n,dim=1)*nB+2)/3)*4)) ! allocating code chars + nI1P = transfer(n,nI1P) ! casting n to integer array of 1 byte elem + padd = mod((size(n,dim=1)*nB),3_I4P) ; if (padd>0_I4P) padd = 3_I4P - padd ! computing the number of padding characters + call encode_bits(bits=nI1P,padd=padd,code=code) ! encoding bits + return + !--------------------------------------------------------------------------------------------------------------------------------- + endsubroutine b64_encode_I8_a + + !> @brief Subroutine for encoding array numbers to base64 (I4P). + pure subroutine b64_encode_I4_a(nB,n,code) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: nB !< Number of bytes of single element of n. + integer(I4P), intent(IN):: n(1:) !< Array of numbers to be encoded. + character(1), allocatable, intent(OUT):: code(:) !< Encoded array. + integer(I1P):: nI1P(1:((size(n,dim=1)*nB+2)/3)*3) !< One byte integer array containing n. + integer(I4P):: padd !< Number of padding characters ('='). + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (allocated(code)) deallocate(code) ; allocate(code(1:((size(n,dim=1)*nB+2)/3)*4)) ! allocating code chars + nI1P = transfer(n,nI1P) ! casting n to integer array of 1 byte elem + padd = mod((size(n,dim=1)*nB),3_I4P) ; if (padd>0_I4P) padd = 3_I4P - padd ! computing the number of padding characters + call encode_bits(bits=nI1P,padd=padd,code=code) ! encoding bits + return + !--------------------------------------------------------------------------------------------------------------------------------- + endsubroutine b64_encode_I4_a + + !> @brief Subroutine for encoding array numbers to base64 (I2P). + pure subroutine b64_encode_I2_a(nB,n,code) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: nB !< Number of bytes of single element of n. + integer(I2P), intent(IN):: n(1:) !< Array of numbers to be encoded. + character(1), allocatable, intent(OUT):: code(:) !< Encoded array. + integer(I1P):: nI1P(1:((size(n,dim=1)*nB+2)/3)*3) !< One byte integer array containing n. + integer(I4P):: padd !< Number of padding characters ('='). + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (allocated(code)) deallocate(code) ; allocate(code(1:((size(n,dim=1)*nB+2)/3)*4)) ! allocating code chars + nI1P = transfer(n,nI1P) ! casting n to integer array of 1 byte elem + padd = mod((size(n,dim=1)*nB),3_I4P) ; if (padd>0_I4P) padd = 3_I4P - padd ! computing the number of padding characters + call encode_bits(bits=nI1P,padd=padd,code=code) ! encoding bits + return + !--------------------------------------------------------------------------------------------------------------------------------- + endsubroutine b64_encode_I2_a + + !> @brief Subroutine for encoding array numbers to base64 (I1P). + pure subroutine b64_encode_I1_a(nB,n,code) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: nB !< Number of bytes of single element of n. + integer(I1P), intent(IN):: n(1:) !< Array of numbers to be encoded. + character(1), allocatable, intent(OUT):: code(:) !< Encoded array. + integer(I1P):: nI1P(1:((size(n,dim=1)*nB+2)/3)*3) !< One byte integer array containing n. + integer(I4P):: padd !< Number of padding characters ('='). + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + if (allocated(code)) deallocate(code) ; allocate(code(1:((size(n,dim=1)*nB+2)/3)*4)) ! allocating code chars + nI1P = transfer(n,nI1P) ! casting n to integer array of 1 byte elem + padd = mod((size(n,dim=1)*nB),3_I4P) ; if (padd>0_I4P) padd = 3_I4P - padd ! computing the number of padding characters + call encode_bits(bits=nI1P,padd=padd,code=code) ! encoding bits + return + !--------------------------------------------------------------------------------------------------------------------------------- + endsubroutine b64_encode_I1_a + + !!> @brief Subroutine for decoding array numbers from base64 (R8P). + !pure subroutine b64_decode_R8_a(code,n) + !!-------------------------------------------------------------------------------------------------------------------------------- + !implicit none + !real(R8P), intent(OUT):: n(1:) !< Number to be decoded. + !character(ncR8P*size(n,dim=1)), intent(IN):: code !< Encoded number. + !integer(I4P):: c,d !< Counters. + !!-------------------------------------------------------------------------------------------------------------------------------- + + !!-------------------------------------------------------------------------------------------------------------------------------- + !d = 1_I4P + !do c=1,len(code),ncR8P + ! call b64_decode_R8_s(code=code(c:c+ncR8P-1),n=n(d)) + ! d = d + 1_I4P + !enddo + !return + !!-------------------------------------------------------------------------------------------------------------------------------- + !endsubroutine b64_decode_R8_a + !> @} +endmodule Lib_Base64 diff --git a/lib/Lib_VTK_IO.f90 b/lib/Lib_VTK_IO.f90 index a4fcf7af6..e47942ab1 100644 --- a/lib/Lib_VTK_IO.f90 +++ b/lib/Lib_VTK_IO.f90 @@ -1,3 +1,14 @@ +!> @addtogroup PrivateVarPar Private Variables and Parameters +!> List of private variables and parameters. +!> @addtogroup Interface Interfaces +!> List of explicitly defined interface. +!> @addtogroup Library Modules Libraries +!> List of modules containing libraries of procedures. +!> @addtogroup PublicProcedure Public Procedures +!> List of public procedures. +!> @addtogroup PrivateProcedure Private Procedures +!> List of private procedures. + !> @ingroup Library !> @{ !> @defgroup Lib_VTK_IOLibrary Lib_VTK_IO @@ -26,16 +37,15 @@ !> @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 +!> but it only an exporter/importer of the VTK data format written in pure Fortran language (standard Fortran 2003 or +!> higher) that can be used by Fortran coders (yes, there are still a lot of these brave coders...) without mixing Fortran +!> with C++ language. Fortran is still the best language for high performance computing for scientific purpose, like CFD !> computing. It is necessary a tool to deal with VTK standard directly by Fortran code. The library was made to fill !> this empty: it is a simple Fortran module able to export native Fortran data into VTK data format and to import VTK !> data into a Fortran code, both in ascii and binary file format. !> !> The library provides an automatic way to deal with VTK data format: all the formatting processes is nested into the -!> library and users communicate with it by a simple API passing only native Fortran data (native Fortran scalar, vector -!> and matrix). +!> library and users communicate with it by a simple API passing only native Fortran data (Fortran scalars and arrays). !> !> The library is still in developing and testing, this is first usable release, but there are not all the features of !> the stable release (the importer is totally absent and the exporter is not complete). Surely there are a lot of bugs @@ -67,11 +77,11 @@ !> - 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). +!> @libvtk can handle multiple concurrent files and it is \b thread/processor-safe (meaning that can be safely used into +!> parallel frameworks as OpenMP or MPI, see \ref SpeedUP "Parallel Frameworks Benchmarks"). !> !> The library is an open source project, it is distributed under the GPL v3. Anyone is interest to use, to develop or -!> to contribute to Lib_VTK_IO is welcome. +!> to contribute to @libvtk is welcome. !> !> It can be found at: https://github.com/szaghi/Lib_VTK_IO !> @@ -106,19 +116,47 @@ !> 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 +!> functions are used without the necessity of calling a different function for each different input type. +!> Dynamic dispatching is based on the internal kind-precision/rank selecting convention: Fortran 90/95 standard has introduced some !> useful functions to achieve the portability of reals and integers precision and @libvtk uses these functions to define portable !> kind-precision; to this aim @libvtk uses IR_Precision module. !> @author Stefano Zaghi !> @version 1.1 -!> @date 2013-03-28 +!> @date 2013-05-23 !> @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. +!> - Added packed API and 3D(or higher) arrays for VTK_VAR_XML function: this avoids the necessity of explicit reshape of +!> multi-dimensional arrays containing saved variables in VAR callings; the following inputs are now available: +!> - scalar input: +!> - input is 1D-rank array: var[1:NC_NN]; +!> - input is 3D-rank array: var[nx1:nx2,ny1:ny2,nz1:nz2]; +!> - vectorial inputs: +!> - inputs are 1D-rank arrays: varX[1:NC_NN],varY[1:NC_NN],varZ[1:NC_NN]; +!> - inputs are 3D-rank arrays: varX[nx1:nx2,ny1:ny2,nz1:nz2],varY[nx1:nx2,ny1:ny2,nz1:nz2],varX[nx1:nx2,ny1:ny2,nz1:nz2]; +!> - 3D(or higher) vectorial inputs: +!> - input is 1D-rank (packed API): var[1:N_COL,1:NC_NN]; +!> - input is 3D-rank (packed API): var[1:N_COL,nx1:nx2,ny1:ny2,nz1:nz2]. +!> - Added packed API and 3D arrays for VTK_GEO and VTK_GEO_XML function: this avoids the necessity of explicit reshape of +!> multi-dimensional arrays containing X, Y and Z coordinates in GEO callings; the following inputs are now available: +!> - StructuredGrid (NN is the number of grid points, n\#1-n\#2, \#x,y,z are the domain extents): +!> - 1D arrays of size NN: X[1:NN],Y[1:NN],Z[1:NN]; +!> - 3D arrays of size NN: X[nx1:nx2,ny1:ny2,nz1:nz2],Y[nx1:nx2,ny1:ny2,nz1:nz2],Z[nx1:nx2,ny1:ny2,nz1:nz2]; +!> - 1D array of size 3*NN (packed API): XYZ[1:3,1:NN]; +!> - 3D array of size 3*NN (packed API): XYZ[1:3,nx1:nx2,ny1:ny2,nz1:nz2]. +!> - UnStructuredGrid (NN is the number of grid points): +!> - 1D arrays of size NN: X[1:NN],Y[1:NN],Z[1:NN]; +!> - 1D array of size 3*NN (packed API): XYZ[1:3,1:NN]. +!> - Added base64 encoding format: the output format specifier of VTK_INI_XML has been changed: +!> - output_format = 'ascii' means \b ascii data, the same as the previous version; +!> - output_format = 'binary' means \b base64 encoded data, different from the previous version where it meant appended +!> raw-binary data; base64 encoding was missing in the previous version; +!> - output_format = 'raw' means \b appended \b raw-binary data, as 'binary' of the previous version; +!> - Added support for OpenMP multi-threads framework; +!> - Correct bug affecting binary output; +!> - implement concurrent multiple files IO capability; +!> - implement FieldData tag for XML files, useful for tagging dataset with global auxiliary data, e.g. time, time step, ecc; +!> - implement Parallel (Partitioned) XML files support (.pvtu,.pvts,.pvtr); +!> - implement Driver testing program for providing practical examples of @libvtk usage; +!> - added support for parallel framework, namely OpenMP (thread-safe) and MPI (process-safe). !> @copyright GNU Public License version 3. !> @note The supported compilers are GNU gfortran 4.7.x (or higher) and Intel Fortran 12.x (or higher). @libvtk needs a modern !> compiler providing support for some Fortran standard 2003 features. @@ -126,28 +164,16 @@ !> @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. +!> @bug XML-Efficiency: \n This is not properly a bug. There is an inefficiency when saving XML raw (binary) file. To write +!> raw data into XML file @libvtk uses a temporary scratch file to save binary data while saving all +!> formatting data to the final XML file. Only when all XML formatting data have been written the +!> scratch file is rewind and the binary data is saved in the final tag of XML file as \b raw +!> \b appended data. This approach is not efficient. !> @ingroup Lib_VTK_IOLibrary module Lib_VTK_IO !----------------------------------------------------------------------------------------------------------------------------------- USE IR_Precision ! Integers and reals precision definition. +USE Lib_Base64 ! Base64 encoding/decoding procedures. USE, intrinsic:: ISO_FORTRAN_ENV, only: stdout=>OUTPUT_UNIT, stderr=>ERROR_UNIT ! Standard output/error logical units. !----------------------------------------------------------------------------------------------------------------------------------- @@ -184,84 +210,6 @@ 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. @@ -289,8 +237,18 @@ interface VTK_FLD_XML 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 +!> VTK_GEO_XML is an interface to 15 different functions; there are 2 functions for each of 3 topologies supported and a function !> for closing XML pieces: one function for mesh coordinates with R8P precision and one for mesh coordinates with R4P precision. +!> @remark 1D/3D-rank arrays and packed API for any kinds \n +!> - For StructuredGrid there are 4 functions for each real kinds: +!> - inputs are 1D-rank arrays: X[1:NN],Y[1:NN],Z[1:NN]; +!> - inputs are 3D-rank arrays: X[nx1:nx2,ny1:ny2,nz1:nz2],Y[nx1:nx2,ny1:ny2,nz1:nz2],Z[nx1:nx2,ny1:ny2,nz1:nz2]; +!> - input is 1D-rank array (packed API): XYZ[1:3,1:NN]; +!> - input is 3D-rank array (packed API): XYZ[1:3,nx1:nx2,ny1:ny2,nz1:nz2]. +!> - For UnStructuredGrid there are 2 functions for each real kinds: +!> - inputs are 1D arrays: X[1:NN],Y[1:NN],Z[1:NN]; +!> - input is 1D array (packed API): XYZ[1:3,1:NN]. +!> !> @remark VTK_GEO_XML must be called after VTK_INI_XML. It saves the mesh geometry. The inputs that must be passed !> change depending on the topologies chosen. Not all VTK topologies have been implemented (\em polydata topologies are absent). !> @note The XML standard is more powerful than legacy. XML file can contain more than 1 mesh with its @@ -325,19 +283,35 @@ endinterface !> ... @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 + module procedure VTK_GEO_XML_STRG_1DA_R8, VTK_GEO_XML_STRG_3DA_R8, & ! real(R8P) StructuredGrid, 1D/3D Arrays + VTK_GEO_XML_STRG_1DAP_R8,VTK_GEO_XML_STRG_3DAP_R8, & ! real(R8P) StructuredGrid, 1D/3D Arrays packed API + VTK_GEO_XML_STRG_1DA_R4, VTK_GEO_XML_STRG_3DA_R4, & ! real(R4P) StructuredGrid, 1D/3D Arrays + VTK_GEO_XML_STRG_1DAP_R4,VTK_GEO_XML_STRG_3DAP_R4, & ! real(R4P) StructuredGrid, 1D/3D Arrays packed API + VTK_GEO_XML_RECT_R8, & ! real(R8P) RectilinearGrid + VTK_GEO_XML_RECT_R4, & ! real(R4P) RectilinearGrid + VTK_GEO_XML_UNST_R8,VTK_GEO_XML_UNST_PACK_R4, & ! real(R8P) UnstructuredGrid, standard and packed API + VTK_GEO_XML_UNST_R4,VTK_GEO_XML_UNST_PACK_R8, & ! real(R4P) UnstructuredGrid, standard and packed API + VTK_GEO_XML_CLOSEP ! closing tag "Piece" function endinterface !> @brief Function for saving data variable(s) in VTK-XML standard. -!> VTK_VAR_XML is an interface to 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. +!> VTK_VAR_XML is an interface to 36 different functions, there are 6 functions for scalar variables, 6 functions for vectorial +!> variables and 6 functions for 3D(or higher) vectorial variables: for all of types the precision can be R8P, R4P, I8P, I4P, I2P +!> and I1P. This function saves the data variables related (cell-centered or node-centered) to geometric mesh. +!> @remark 1D/3D-rank arrays and packed API for any kinds \n +!> The inputs arrays can be passed as 1D-rank or 3D-rank and the vectorial variables can be component-separated (one for each of +!> the 3 components) or packed into one multidimensional array: +!> - scalar input: +!> - input is 1D-rank array: var[1:NC_NN]; +!> - input is 3D-rank array: var[nx1:nx2,ny1:ny2,nz1:nz2]; +!> - vectorial inputs: +!> - inputs are 1D-rank arrays: varX[1:NC_NN],varY[1:NC_NN],varZ[1:NC_NN]; +!> - inputs are 3D-rank arrays: varX[nx1:nx2,ny1:ny2,nz1:nz2],varY[nx1:nx2,ny1:ny2,nz1:nz2],varX[nx1:nx2,ny1:ny2,nz1:nz2]; +!> - 3D(or higher) vectorial inputs: +!> - input is 1D-rank (packed API): var[1:N_COL,1:NC_NN]; +!> - input is 3D-rank (packed API): var[1:N_COL,nx1:nx2,ny1:ny2,nz1:nz2]. +!> +!> @remark Note that the inputs that must be passed change depending on the data variables type. +!> !> @note Examples of usage are: \n !> \b Scalar data calling: \n !> @code ... @@ -355,24 +329,104 @@ endinterface !> ... @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 + module procedure VTK_VAR_XML_SCAL_1DA_R8,VTK_VAR_XML_SCAL_3DA_R8, & ! real(R8P) scalar 1D/3D array + VTK_VAR_XML_SCAL_1DA_R4,VTK_VAR_XML_SCAL_3DA_R4, & ! real(R4P) scalar 1D/3D array + VTK_VAR_XML_SCAL_1DA_I8,VTK_VAR_XML_SCAL_3DA_I8, & ! integer(I8P) scalar 1D/3D array + VTK_VAR_XML_SCAL_1DA_I4,VTK_VAR_XML_SCAL_3DA_I4, & ! integer(I4P) scalar 1D/3D array + VTK_VAR_XML_SCAL_1DA_I2,VTK_VAR_XML_SCAL_3DA_I2, & ! integer(I2P) scalar 1D/3D array + VTK_VAR_XML_SCAL_1DA_I1,VTK_VAR_XML_SCAL_3DA_I1, & ! integer(I1P) scalar 1D/3D array + VTK_VAR_XML_VECT_1DA_R8,VTK_VAR_XML_VECT_3DA_R8, & ! real(R8P) vectorial 1D/3D arrays + VTK_VAR_XML_VECT_1DA_R4,VTK_VAR_XML_VECT_3DA_R4, & ! real(R4P) vectorial 1D/3D arrays + VTK_VAR_XML_VECT_1DA_I8,VTK_VAR_XML_VECT_3DA_I8, & ! integer(I8P) vectorial 1D/3D arrays + VTK_VAR_XML_VECT_1DA_I4,VTK_VAR_XML_VECT_3DA_I4, & ! integer(I4P) vectorial 1D/3D arrays + VTK_VAR_XML_VECT_1DA_I2,VTK_VAR_XML_VECT_3DA_I2, & ! integer(I2P) vectorial 1D/3D arrays + VTK_VAR_XML_VECT_1DA_I1,VTK_VAR_XML_VECT_3DA_I1, & ! integer(I1P) vectorial 1D/3D arrays + VTK_VAR_XML_LIST_1DA_R8,VTK_VAR_XML_LIST_3DA_R8, & ! real(R8P) list 1D/3D array + VTK_VAR_XML_LIST_1DA_R4,VTK_VAR_XML_LIST_3DA_R4, & ! real(R4P) list 1D/3D array + VTK_VAR_XML_LIST_1DA_I8,VTK_VAR_XML_LIST_3DA_I8, & ! integer(I4P) list 1D/3D array + VTK_VAR_XML_LIST_1DA_I4,VTK_VAR_XML_LIST_3DA_I4, & ! integer(I4P) list 1D/3D array + VTK_VAR_XML_LIST_1DA_I2,VTK_VAR_XML_LIST_3DA_I2, & ! integer(I2P) list 1D/3D array + VTK_VAR_XML_LIST_1DA_I1,VTK_VAR_XML_LIST_3DA_I1 ! integer(I1P) list 1D/3D array +endinterface +!> @brief Function for saving mesh with different topologies in VTK-legacy standard. +!> VTK_GEO is an interface to 16 different functions, there are 2 functions for each of 4 different topologies actually supported: +!> one function for mesh coordinates with R8P precision and one for mesh coordinates with R4P precision. +!> @remark This function must be called after VTK_INI. It saves the mesh geometry. The inputs that must be passed change depending +!> on the topologies chosen. Not all VTK topologies have been implemented (\em polydata topologies are absent). +!> @note Examples of usage are: \n +!> \b Structured points calling: \n +!> @code ... +!> integer(I4P):: Nx,Ny,Nz +!> real(I8P):: X0,Y0,Z0,Dx,Dy,Dz +!> ... +!> E_IO=VTK_GEO(Nx,Ny,Nz,X0,Y0,Z0,Dx,Dy,Dz) +!> ... @endcode +!> \b Structured grid calling: \n +!> @code ... +!> integer(I4P):: Nx,Ny,Nz,Nnodes +!> real(R8P):: X(1:Nnodes),Y(1:Nnodes),Z(1:Nnodes) +!> ... +!> E_IO=VTK_GEO(Nx,Ny,Nz,Nnodes,X,Y,Z) +!> ... @endcode +!> \b Rectilinear grid calling: \n +!> @code ... +!> integer(I4P):: Nx,Ny,Nz +!> real(R8P):: X(1:Nx),Y(1:Ny),Z(1:Nz) +!> ... +!> E_IO=VTK_GEO(Nx,Ny,Nz,X,Y,Z) +!> ... @endcode +!> \b Unstructured grid calling: \n +!> @code ... +!> integer(I4P):: NN +!> real(R4P):: X(1:NN),Y(1:NN),Z(1:NN) +!> ... +!> E_IO=VTK_GEO(NN,X,Y,Z) +!> ... @endcode +!> @ingroup Lib_VTK_IOInterface +interface VTK_GEO + module procedure VTK_GEO_UNST_R8,VTK_GEO_UNST_P_R8, & ! real(R8P) UNSTRUCTURED_GRID, standard and packed API + VTK_GEO_UNST_R4,VTK_GEO_UNST_P_R4, & ! real(R4P) UNSTRUCTURED_GRID, standard and packed API + VTK_GEO_STRP_R8, & ! real(R8P) STRUCTURED_POINTS + VTK_GEO_STRP_R4, & ! real(R4P) STRUCTURED_POINTS + VTK_GEO_STRG_1DA_R8, VTK_GEO_STRG_3DA_R8, & ! real(R8P) STRUCTURED_GRID 1D/3D arrays + VTK_GEO_STRG_1DAP_R8,VTK_GEO_STRG_3DAP_R8, & ! real(R8P) STRUCTURED_GRID 1D/3D arrays, packed API + VTK_GEO_STRG_1DA_R4, VTK_GEO_STRG_3DA_R4, & ! real(R4P) STRUCTURED_GRID 1D/3D arrays + VTK_GEO_STRG_1DAP_R4,VTK_GEO_STRG_3DAP_R4, & ! real(R4P) STRUCTURED_GRID 1D/3D arrays, packed API + VTK_GEO_RECT_R8, & ! real(R8P) RECTILINEAR_GRID + VTK_GEO_RECT_R4 ! real(R4P) RECTILINEAR_GRID +endinterface +!> @brief Function for saving data variable(s) in VTK-legacy standard. +!> VTK_VAR is an interface to 8 different functions, there are 3 functions for scalar variables, 3 functions for vectorial +!> variables and 2 functions texture variables: scalar and vectorial data can be R8P, R4P and I4P data while texture variables can +!> be only R8P or R4P. +!> This function saves the data variables related to geometric mesh. +!> @remark The inputs that must be passed change depending on the data +!> variables type. +!> @note Examples of usage are: \n +!> \b Scalar data calling: \n +!> @code ... +!> integer(I4P):: NN +!> real(R4P):: var(1:NN) +!> ... +!> E_IO=VTK_VAR(NN,'Sca',var) +!> ... @endcode +!> \b Vectorial data calling: \n +!> @code ... +!> integer(I4P):: NN +!> real(R4P):: varX(1:NN),varY(1:NN),varZ(1:NN) +!> ... +!> E_IO=VTK_VAR('vect',NN,'Vec',varX,varY,varZ) +!> ... @endcode +!> @ingroup Lib_VTK_IOInterface +interface VTK_VAR + module procedure VTK_VAR_SCAL_R8, & ! real(R8P) scalar + VTK_VAR_SCAL_R4, & ! real(R4P) scalar + VTK_VAR_SCAL_I4, & ! integer(I4P) scalar + VTK_VAR_VECT_R8, & ! real(R8P) vectorial + VTK_VAR_VECT_R4, & ! real(R4P) vectorial + VTK_VAR_VECT_I4, & ! integer(I4P) vectorial + VTK_VAR_TEXT_R8, & ! real(R8P) vectorial (texture) + VTK_VAR_TEXT_R4 ! real(R4P) vectorial (texture) endinterface !----------------------------------------------------------------------------------------------------------------------------------- @@ -385,9 +439,11 @@ endinterface 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. +integer(I4P), parameter:: binary = 1 !< Base64-output-format parameter identifier. +integer(I4P), parameter:: raw = 2 !< Raw-appended-binary-output-format parameter identifier. +integer(I4P), parameter:: bin_app = 3 !< Base64-appended-output-format parameter identifier. ! VTK file data: -type Type_VTK_File +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. @@ -399,12 +455,14 @@ type Type_VTK_File #endif integer(I8P):: ioffset = 0_I8P !< Offset pointer. integer(I4P):: indent = 0_I4P !< Indent pointer. + contains + procedure:: byte_update ! Procedure for updating N_Byte and ioffset pointer. endtype Type_VTK_File type(Type_VTK_File), allocatable:: vtk(:) !< Global data of VTK files [1:Nvtk]. integer(I4P):: Nvtk = 0_I4P !< Number of (concurrent) VTK files. integer(I4P):: f = 0_I4P !< Current VTK file index. ! VTM file data: -type Type_VTM_File +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. @@ -413,9 +471,7 @@ 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. - + ! The library uses five auxiliary procedures that are private thus they cannot be called outside the library. !> @ingroup Lib_VTK_IOPrivateProcedure !> @{ !> @brief Function for getting a free logic unit. The users of @libvtk does not know which is the logical @@ -425,7 +481,7 @@ contains integer function Get_Unit(Free_Unit) !--------------------------------------------------------------------------------------------------------------------------------- implicit none - integer(I4P), intent(OUT), optional:: Free_Unit !< Free logic unit. + integer, intent(OUT), optional:: Free_Unit !< Free logic unit. integer:: n1 !< Counter. integer:: ios !< Inquiring flag. logical:: lopen !< Inquiring flag. @@ -436,7 +492,7 @@ contains n1=1 do if ((n1/=stdout).AND.(n1/=stderr)) then - inquire (unit=n1,opened=lopen,iostat=ios) + 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 @@ -456,7 +512,7 @@ contains !> 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) + elemental function Upper_Case(string) !--------------------------------------------------------------------------------------------------------------------------------- implicit none character(len=*), intent(IN):: string !< String to be converted. @@ -476,33 +532,46 @@ contains !--------------------------------------------------------------------------------------------------------------------------------- endfunction Upper_Case - !> @brief Subroutine for updating vtk(f)%ioffset pointer. - subroutine ioffset_update(N_Byte) + !> @brief Subroutine for updating N_Byte and ioffset pointer. + elemental subroutine byte_update(vtk,N_Byte) !--------------------------------------------------------------------------------------------------------------------------------- implicit none + class(Type_VTK_File), intent(INOUT):: vtk !< Global data of VTK file. #ifdef HUGE - integer(I8P), intent(IN):: N_Byte !< Number of bytes saved. + integer(I8P), intent(IN):: N_Byte !< Number of bytes saved. #else - integer(I4P), intent(IN):: N_Byte !< Number of bytes saved. + integer(I4P), intent(IN):: N_Byte !< Number of bytes saved. #endif !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- + vtk%N_Byte = N_Byte + if (vtk%f==raw) then #ifdef HUGE - vtk(f)%ioffset = vtk(f)%ioffset + BYI8P + N_Byte + vtk%ioffset = vtk%ioffset + BYI8P + N_Byte #else - vtk(f)%ioffset = vtk(f)%ioffset + BYI4P + N_Byte + vtk%ioffset = vtk%ioffset + BYI4P + N_Byte #endif + else +#ifdef HUGE + vtk%ioffset = vtk%ioffset + ((N_Byte + BYI8P + 2_I8P)/3_I8P)*4_I8P +#else + vtk%ioffset = vtk%ioffset + ((N_Byte + BYI4P + 2_I4P)/3_I4P)*4_I4P +#endif + endif return !--------------------------------------------------------------------------------------------------------------------------------- - endsubroutine ioffset_update + endsubroutine byte_update !> @brief Subroutine for updating (adding and removing elements into) vtk array. - subroutine vtk_update(act) + pure subroutine vtk_update(act,cf,Nvtk,vtk) !--------------------------------------------------------------------------------------------------------------------------------- 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. + character(*), intent(IN):: act !< Action: 'ADD' one more element, 'REMOVE' current element file. + integer(I4P), intent(INOUT):: cf !< Current file index (for concurrent files IO). + integer(I4P), intent(INOUT):: Nvtk !< Number of (concurrent) VTK files. + type(Type_VTK_File), allocatable, intent(INOUT):: vtk(:) !< VTK files data. + type(Type_VTK_File), allocatable:: vtk_tmp(:) !< Temporary array of VTK files data. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- @@ -516,44 +585,72 @@ contains allocate(vtk(1:Nvtk)) vtk(1:Nvtk-1) = vtk_tmp deallocate(vtk_tmp) - f = Nvtk + cf = Nvtk else Nvtk = 1_I4P allocate(vtk(1:Nvtk)) - f = Nvtk + cf = Nvtk endif - case('REMOVE') + case default if (Nvtk>1_I4P) then allocate(vtk_tmp(1:Nvtk-1)) - if (f==Nvtk) then + if (cf==Nvtk) then vtk_tmp = vtk(1:Nvtk-1) else - vtk_tmp(1:f-1) = vtk(1 :f-1) - vtk_tmp(f: ) = vtk(f+1: ) + vtk_tmp(1 :cf-1) = vtk(1 :cf-1) + vtk_tmp(cf: ) = vtk(cf+1: ) endif deallocate(vtk) Nvtk = Nvtk - 1 allocate(vtk(1:Nvtk)) vtk = vtk_tmp deallocate(vtk_tmp) - f = 1_I4P + cf = 1_I4P else Nvtk = 0_I4P if (allocated(vtk)) deallocate(vtk) - f = Nvtk + cf = Nvtk endif endselect return !--------------------------------------------------------------------------------------------------------------------------------- endsubroutine vtk_update + + !> @brief Function for converting array of 1 character to a string of characters. It is used for writing the stream of base64 + !> encoded data. + pure function tochar(string) result (char_string) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + character(1), intent(IN):: string(1:) !< Array of 1 character. + character(size(string,dim=1)):: char_string !< String of characters. + integer(I4P):: i !< Counter. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + forall(i = 1:size(string,dim=1)) + char_string(i:i) = string(i) + endforall + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction tochar !> @} !> @brief Function for initializing VTK-XML file. !> The XML standard is more powerful than legacy one. It is flexible but on the other hand is (but not so more using a library - !> like @libvtk...) complex than legacy standard. The output of XML functions is a well-formated 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). + !> like @libvtk...) complex than legacy standard. The output of XML functions is a well-formated valid XML file, at least for the + !> ascii, binary and binary appended formats (in the raw-binary format @libvtk uses raw-binary-appended format that is not a valid + !> XML file). !> Note that the XML functions have the same name of legacy functions with the suffix \em XML. !> @remark This function must be the first to be called. + !> @note Supported output formats are (the passed specifier value is case insensitive): + !> - ASCII: data are saved in ASCII format; + !> - BINARY: data are saved in base64 encoded format; + !> - RAW: data are saved in raw-binary format in the appended tag of the XML file; + !> - BINARY-APPENDED: data are saved in base64 encoded format in the appended tag of the XML file. + !> @note Supported topologies are: + !> - RectilinearGrid; + !> - StructuredGrid; + !> - UnstructuredGrid. !> @note An example of usage is: \n !> @code ... !> integer(I4P):: nx1,nx2,ny1,ny2,nz1,nz2 @@ -563,9 +660,12 @@ contains !> 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) + function VTK_INI_XML(output_format,filename,mesh_topology,cf,nx1,nx2,ny1,ny2,nz1,nz2) result(E_IO) !--------------------------------------------------------------------------------------------------------------------------------- implicit none + character(*), intent(IN):: output_format !< Output format: ASCII, BINARY, RAW or BINARY-APPENDED. + character(*), intent(IN):: filename !< File name. + character(*), intent(IN):: mesh_topology !< Mesh topology. integer(I4P), intent(OUT), optional:: cf !< Current file index (for concurrent files IO). integer(I4P), intent(IN), optional:: nx1 !< Initial node of x axis. integer(I4P), intent(IN), optional:: nx2 !< Final node of x axis. @@ -573,65 +673,89 @@ contains 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. + integer(I4P):: rf !< Real file index. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- + E_IO = -1_I4P if (.not.ir_initialized) call IR_Init - call vtk_update(act='add') - if (present(cf)) cf = f - vtk(f)%topology = trim(mesh_topology) + call vtk_update(act='add',cf=rf,Nvtk=Nvtk,vtk=vtk) + f = rf + if (present(cf)) cf = rf + vtk(rf)%topology = trim(mesh_topology) select case(trim(Upper_Case(output_format))) case('ASCII') - vtk(f)%f = ascii - open(unit=Get_Unit(vtk(f)%u),file=trim(filename),form='FORMATTED',& + vtk(rf)%f = ascii + open(unit=Get_Unit(vtk(rf)%u),file=trim(filename),form='FORMATTED',& access='SEQUENTIAL',action='WRITE',status='REPLACE',iostat=E_IO) ! writing header of file - write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)'' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)'' if (endian==endianL) then - s_buffer = '' + s_buffer = '' else - s_buffer = '' + 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)) + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(rf)%indent = 2 + select case(trim(vtk(rf)%topology)) case('RectilinearGrid','StructuredGrid') - s_buffer = repeat(' ',vtk(f)%indent)//'<'//trim(vtk(f)%topology)//' WholeExtent="'//& - trim(str(n=nx1))//' '//trim(str(n=nx2))//' '// & - trim(str(n=ny1))//' '//trim(str(n=ny2))//' '// & + s_buffer = repeat(' ',vtk(rf)%indent)//'<'//trim(vtk(rf)%topology)//' WholeExtent="'//& + trim(str(n=nx1))//' '//trim(str(n=nx2))//' '// & + trim(str(n=ny1))//' '//trim(str(n=ny2))//' '// & trim(str(n=nz1))//' '//trim(str(n=nz2))//'">' case('UnstructuredGrid') - s_buffer = repeat(' ',vtk(f)%indent)//'<'//trim(vtk(f)%topology)//'>' + s_buffer = repeat(' ',vtk(rf)%indent)//'<'//trim(vtk(rf)%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) + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(rf)%indent = vtk(rf)%indent + 2 + case('RAW','BINARY-APPENDED') + vtk(rf)%f = raw + if (trim(Upper_Case(output_format))=='BINARY-APPENDED') vtk(rf)%f = bin_app + open(unit=Get_Unit(vtk(rf)%u),file=trim(filename),& + form='UNFORMATTED',access='STREAM',action='WRITE',status='REPLACE',iostat=E_IO) ! writing header of file - write(unit=vtk(f)%u,iostat=E_IO)''//end_rec + write(unit=vtk(rf)%u,iostat=E_IO)''//end_rec if (endian==endianL) then - s_buffer = '' + s_buffer = '' else - s_buffer = '' + 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)) + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = 2 + select case(trim(vtk(rf)%topology)) case('RectilinearGrid','StructuredGrid') - s_buffer = repeat(' ',vtk(f)%indent)//'<'//trim(vtk(f)%topology)//' WholeExtent="'//& - trim(str(n=nx1))//' '//trim(str(n=nx2))//' '// & - trim(str(n=ny1))//' '//trim(str(n=ny2))//' '// & + s_buffer = repeat(' ',vtk(rf)%indent)//'<'//trim(vtk(rf)%topology)//' WholeExtent="'//& + trim(str(n=nx1))//' '//trim(str(n=nx2))//' '// & + trim(str(n=ny1))//' '//trim(str(n=ny2))//' '// & trim(str(n=nz1))//' '//trim(str(n=nz2))//'">' case('UnstructuredGrid') - s_buffer = repeat(' ',vtk(f)%indent)//'<'//trim(vtk(f)%topology)//'>' + s_buffer = repeat(' ',vtk(rf)%indent)//'<'//trim(vtk(rf)%topology)//'>' endselect - write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(f)%indent = vtk(f)%indent + 2 + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 ! opening the SCRATCH file used for appending raw binary data - open(unit=Get_Unit(vtk(f)%ua), form='UNFORMATTED', access='STREAM', action='READWRITE', status='SCRATCH', iostat=E_IO) - vtk(f)%ioffset = 0 ! initializing offset pointer + open(unit=Get_Unit(vtk(rf)%ua), form='UNFORMATTED', access='STREAM', action='READWRITE', status='SCRATCH', iostat=E_IO) + vtk(rf)%ioffset = 0 ! initializing offset pointer + case('BINARY') + vtk(rf)%f = binary + open(unit=Get_Unit(vtk(rf)%u),file=trim(filename),& + form='UNFORMATTED',access='STREAM',action='WRITE',status='REPLACE',iostat=E_IO) + ! writing header of file + write(unit=vtk(rf)%u,iostat=E_IO)''//end_rec + if (endian==endianL) then + s_buffer = '' + else + s_buffer = '' + endif + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = 2 + select case(trim(vtk(rf)%topology)) + case('RectilinearGrid','StructuredGrid') + s_buffer = repeat(' ',vtk(rf)%indent)//'<'//trim(vtk(rf)%topology)//' WholeExtent="'//& + trim(str(n=nx1))//' '//trim(str(n=nx2))//' '// & + trim(str(n=ny1))//' '//trim(str(n=ny2))//' '// & + trim(str(n=nz1))//' '//trim(str(n=nz2))//'">' + case('UnstructuredGrid') + s_buffer = repeat(' ',vtk(rf)%indent)//'<'//trim(vtk(rf)%topology)//'>' + endselect + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 endselect return !--------------------------------------------------------------------------------------------------------------------------------- @@ -641,30 +765,35 @@ contains !> @{ !> 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) + function VTK_FLD_XML_OC(fld_action,cf) 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), intent(IN), optional:: cf !< Current file index (for concurrent files IO). integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + integer(I4P):: rf !< Real file index. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - if (present(cf)) f = cf + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif select case(trim(Upper_Case(fld_action))) case('OPEN') - select case(vtk(f)%f) + select case(vtk(rf)%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 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent + 2 + case(raw,binary,bin_app) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 endselect case('CLOSE') - select case(vtk(f)%f) + select case(vtk(rf)%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 + vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,binary,bin_app) + vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec endselect endselect return @@ -673,30 +802,44 @@ contains !> 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) + function VTK_FLD_XML_R8(fld,fname,cf) 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), intent(IN), optional:: cf !< Current file index (for concurrent files IO). integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. character(len=maxlen):: s_buffer !< Buffer string. + integer(I1P), allocatable:: fldp(:) !< Packed field data. + character(1), allocatable:: fld64(:) !< Field data encoded in base64. + integer(I4P):: rf !< Real file index. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - if (present(cf)) f = cf - select case(vtk(f)%f) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) case(ascii) - s_buffer = repeat(' ',vtk(f)%indent)//''//& - trim(str(n=fld))//'' - write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + s_buffer=repeat(' ',vtk(rf)%indent)//''//& + trim(str(n=fld))//'' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + case(raw,bin_app) + s_buffer=repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = int(BYR8P,I4P)) + write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R8',1_I4P + write(unit=vtk(rf)%ua,iostat=E_IO)fld case(binary) - s_buffer = repeat(' ',vtk(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 + s_buffer=repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call pack_data(a1=[int(BYR8P,I4P)],a2=[fld],packed=fldp) + call b64_encode(nB=int(BYI1P,I4P),n=fldp,code=fld64) ; deallocate(fldp) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(fld64)//end_rec ; deallocate(fld64) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec endselect return !--------------------------------------------------------------------------------------------------------------------------------- @@ -704,30 +847,44 @@ contains !> 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) + function VTK_FLD_XML_R4(fld,fname,cf) 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), intent(IN), optional:: cf !< Current file index (for concurrent files IO). integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. character(len=maxlen):: s_buffer !< Buffer string. + integer(I1P), allocatable:: fldp(:) !< Packed field data. + character(1), allocatable:: fld64(:) !< Field data encoded in base64. + integer(I4P):: rf !< Real file index. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - if (present(cf)) f = cf - select case(vtk(f)%f) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) case(ascii) - s_buffer = repeat(' ',vtk(f)%indent)//''//& - trim(str(n=fld))//'' - write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + s_buffer=repeat(' ',vtk(rf)%indent)//''//& + trim(str(n=fld))//'' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + case(raw,bin_app) + s_buffer=repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = int(BYR4P,I4P)) + write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R4',1_I4P + write(unit=vtk(rf)%ua,iostat=E_IO)fld case(binary) - s_buffer = repeat(' ',vtk(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 + s_buffer=repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call pack_data(a1=[int(BYR4P,I4P)],a2=[fld],packed=fldp) + call b64_encode(nB=int(BYI1P,I4P),n=fldp,code=fld64) ; deallocate(fldp) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(fld64)//end_rec ; deallocate(fld64) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec endselect return !--------------------------------------------------------------------------------------------------------------------------------- @@ -735,30 +892,44 @@ contains !> 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) + function VTK_FLD_XML_I8(fld,fname,cf) 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), intent(IN), optional:: cf !< Current file index (for concurrent files IO). integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. character(len=maxlen):: s_buffer !< Buffer string. + integer(I1P), allocatable:: fldp(:) !< Packed field data. + character(1), allocatable:: fld64(:) !< Field data encoded in base64. + integer(I4P):: rf !< Real file index. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - if (present(cf)) f = cf - select case(vtk(f)%f) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) case(ascii) - s_buffer = repeat(' ',vtk(f)%indent)//''// & + s_buffer = repeat(' ',vtk(rf)%indent)//''// & trim(str(n=fld))//'' - write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = int(BYI8P,I4P)) + write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I8',1_I4P + write(unit=vtk(rf)%ua,iostat=E_IO)fld case(binary) - s_buffer = repeat(' ',vtk(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 + s_buffer=repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call pack_data(a1=[int(BYI8P,I4P)],a2=[fld],packed=fldp) + call b64_encode(nB=int(BYI1P,I4P),n=fldp,code=fld64) ; deallocate(fldp) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(fld64)//end_rec ; deallocate(fld64) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec endselect return !--------------------------------------------------------------------------------------------------------------------------------- @@ -766,30 +937,46 @@ contains !> 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) + function VTK_FLD_XML_I4(fld,fname,cf) 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), intent(IN), optional:: cf !< Current file index (for concurrent files IO). integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. character(len=maxlen):: s_buffer !< Buffer string. + integer(I1P), allocatable:: fldp(:) !< Packed field data. + character(1), allocatable:: fld64(:) !< Field data encoded in base64. + integer(I4P):: rf !< Real file index. + integer(I8P):: Nfldp !< Dimension of fldp, packed data. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - if (present(cf)) f = cf - select case(vtk(f)%f) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) case(ascii) - s_buffer = repeat(' ',vtk(f)%indent)//''// & + s_buffer = repeat(' ',vtk(rf)%indent)//''// & trim(str(n=fld))//'' - write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = int(BYI4P,I4P)) + write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I4',1_I4P + write(unit=vtk(rf)%ua,iostat=E_IO)fld case(binary) - s_buffer = repeat(' ',vtk(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 + s_buffer=repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + Nfldp=size(transfer([int(BYI4P,I4P),fld],fldp)) ; if (allocated(fldp)) deallocate(fldp) ; allocate(fldp(1:Nfldp)) + fldp = transfer([int(BYI4P,I4P),fld],fldp) + call b64_encode(nB=int(BYI1P,I4P),n=fldp,code=fld64) ; deallocate(fldp) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(fld64)//end_rec ; deallocate(fld64) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec endselect return !--------------------------------------------------------------------------------------------------------------------------------- @@ -797,30 +984,44 @@ contains !> 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) + function VTK_FLD_XML_I2(fld,fname,cf) 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), intent(IN), optional:: cf !< Current file index (for concurrent files IO). integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. character(len=maxlen):: s_buffer !< Buffer string. + integer(I1P), allocatable:: fldp(:) !< Packed field data. + character(1), allocatable:: fld64(:) !< Field data encoded in base64. + integer(I4P):: rf !< Real file index. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - if (present(cf)) f = cf - select case(vtk(f)%f) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) case(ascii) - s_buffer = repeat(' ',vtk(f)%indent)//''// & + s_buffer = repeat(' ',vtk(rf)%indent)//''// & trim(str(n=fld))//'' - write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = int(BYI2P,I4P)) + write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I2',1_I4P + write(unit=vtk(rf)%ua,iostat=E_IO)fld case(binary) - s_buffer = repeat(' ',vtk(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 + s_buffer=repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call pack_data(a1=[int(BYI2P,I4P)],a2=[fld],packed=fldp) + call b64_encode(nB=int(BYI1P,I4P),n=fldp,code=fld64) ; deallocate(fldp) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(fld64)//end_rec ; deallocate(fld64) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec endselect return !--------------------------------------------------------------------------------------------------------------------------------- @@ -828,41 +1029,54 @@ contains !> 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) + function VTK_FLD_XML_I1(fld,fname,cf) 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), intent(IN), optional:: cf !< Current file index (for concurrent files IO). integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. character(len=maxlen):: s_buffer !< Buffer string. + integer(I1P), allocatable:: fldp(:) !< Packed field data. + character(1), allocatable:: fld64(:) !< Field data encoded in base64. + integer(I4P):: rf !< Real file index. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - if (present(cf)) f = cf - select case(vtk(f)%f) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) case(ascii) - s_buffer = repeat(' ',vtk(f)%indent)//''// & + s_buffer = repeat(' ',vtk(rf)%indent)//''// & trim(str(n=fld))//'' - write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = int(BYI1P,I4P)) + write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I1',1_I4P + write(unit=vtk(rf)%ua,iostat=E_IO)fld case(binary) - s_buffer = repeat(' ',vtk(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 + s_buffer=repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call pack_data(a1=[int(BYI1P,I4P)],a2=[fld],packed=fldp) + call b64_encode(nB=int(BYI1P,I4P),n=fldp,code=fld64) ; deallocate(fldp) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(fld64)//end_rec ; deallocate(fld64) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec endselect return !--------------------------------------------------------------------------------------------------------------------------------- endfunction VTK_FLD_XML_I1 - !> Function for saving mesh with \b StructuredGrid topology (R8P). + !> Function for saving mesh with \b StructuredGrid topology (R8P, 1D Arrays). !> @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) + function VTK_GEO_XML_STRG_1DA_R8(nx1,nx2,ny1,ny2,nz1,nz2,NN,X,Y,Z,cf) result(E_IO) !--------------------------------------------------------------------------------------------------------------------------------- implicit none - integer(I4P), intent(IN), 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. @@ -870,165 +1084,716 @@ contains 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. + real(R8P), intent(IN):: X(1:) !< X coordinates [1:NN]. + real(R8P), intent(IN):: Y(1:) !< Y coordinates [1:NN]. + real(R8P), intent(IN):: Z(1:) !< Z coordinates [1:NN]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + integer(I1P), allocatable:: XYZp(:) !< Packed coordinates data. + character(1), allocatable:: XYZ64(:) !< X, Y, Z coordinates encoded in base64. character(len=maxlen):: s_buffer !< Buffer string. + integer(I4P):: rf !< Real file index. integer(I4P):: n1 !< Counter. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - if (present(cf)) f = cf - select case(vtk(f)%f) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) case(ascii) - s_buffer = repeat(' ',vtk(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)// & + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(rf)%indent = vtk(rf)%indent + 2 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent + 2 + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + do n1=1,NN + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//str(n=X(n1))//' '//str(n=Y(n1))//' '//str(n=Z(n1)) + enddo + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent - 2 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + s_buffer = repeat(' ',vtk(rf)%indent)// & '' - write(unit=vtk(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)//'' + trim(str(.true.,vtk(rf)%ioffset))//'"/>' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = 3*NN*BYR8P) + write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R8',3*NN + write(unit=vtk(rf)%ua,iostat=E_IO)(X(n1),Y(n1),Z(n1),n1=1,NN) + vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec case(binary) - s_buffer = repeat(' ',vtk(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 + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call pack_data(a1=[int(3*NN*BYR8P,I4P)],a2=[(X(n1),Y(n1),Z(n1),n1=1,NN)],packed=XYZp) + call b64_encode(nB=int(BYI1P,I4P),n=XYZp,code=XYZ64) ; deallocate(XYZp) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(XYZ64)//end_rec ; deallocate(XYZ64) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec endselect return !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_GEO_XML_STRG_R4 + endfunction VTK_GEO_XML_STRG_1DA_R8 - !> Function for saving mesh with \b RectilinearGrid topology (R8P). + !> Function for saving mesh with \b StructuredGrid topology (R8P, 3D Arrays). !> @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) + function VTK_GEO_XML_STRG_3DA_R8(nx1,nx2,ny1,ny2,nz1,nz2,NN,X,Y,Z,cf) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: nx1 !< Initial node of x axis. + integer(I4P), intent(IN):: nx2 !< Final node of x axis. + integer(I4P), intent(IN):: ny1 !< Initial node of y axis. + integer(I4P), intent(IN):: ny2 !< Final node of y axis. + integer(I4P), intent(IN):: nz1 !< Initial node of z axis. + integer(I4P), intent(IN):: nz2 !< Final node of z axis. + integer(I4P), intent(IN):: NN !< Number of all nodes. + real(R8P), intent(IN):: X(nx1:,ny1:,nz1:) !< X coordinates [nx1:nx2,ny1:ny2,nz1:nz2]. + real(R8P), intent(IN):: Y(nx1:,ny1:,nz1:) !< Y coordinates [nx1:nx2,ny1:ny2,nz1:nz2]. + real(R8P), intent(IN):: Z(nx1:,ny1:,nz1:) !< Z coordinates [nx1:nx2,ny1:ny2,nz1:nz2]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + integer(I1P), allocatable:: XYZp(:) !< Packed coordinates data. + character(1), allocatable:: XYZ64(:) !< X, Y, Z coordinates encoded in base64. + character(len=maxlen):: s_buffer !< Buffer string. + integer(I4P):: rf !< Real file index. + integer(I4P):: nx,ny,nz !< Counters. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) + case(ascii) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(rf)%indent = vtk(rf)%indent + 2 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent + 2 + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + do nz=nz1,nz2 + do ny=ny1,ny2 + do nx=nx1,nx2 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//& + str(n=X(nx,ny,nz))//' '//str(n=Y(nx,ny,nz))//' '//str(n=Z(nx,ny,nz)) + enddo + enddo + enddo + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent - 2 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + s_buffer = repeat(' ',vtk(rf)%indent)// & + '' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = 3*NN*BYR8P) + write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R8',3*NN + write(unit=vtk(rf)%ua,iostat=E_IO)(((X(nx,ny,nz),Y(nx,ny,nz),Z(nx,ny,nz),nx=nx1,nx2),ny=ny1,ny2),nz=nz1,nz2) + vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + case(binary) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call pack_data(a1=[int(3*NN*BYR8P,I4P)],a2=[(((X(nx,ny,nz),Y(nx,ny,nz),Z(nx,ny,nz),nx=nx1,nx2),ny=ny1,ny2),nz=nz1,nz2)],& + packed=XYZp) + call b64_encode(nB=int(BYI1P,I4P),n=XYZp,code=XYZ64) ; deallocate(XYZp) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(XYZ64)//end_rec ; deallocate(XYZ64) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_GEO_XML_STRG_3DA_R8 + + !> Function for saving mesh with \b StructuredGrid topology (R8P, 1D Arrays, packed API). + !> @return E_IO: integer(I4P) error flag + function VTK_GEO_XML_STRG_1DAP_R8(nx1,nx2,ny1,ny2,nz1,nz2,NN,XYZ,cf) result(E_IO) !--------------------------------------------------------------------------------------------------------------------------------- implicit none - integer(I4P), intent(IN), 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), intent(IN):: NN !< Number of all nodes. + real(R8P), intent(IN):: XYZ(1:,1:) !< X, Y, Z coordinates (packed API) [1:3,1:NN]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + integer(I1P), allocatable:: XYZp(:) !< Packed coordinates data. + character(1), allocatable:: XYZ64(:) !< X, Y, Z coordinates encoded in base64. character(len=maxlen):: s_buffer !< Buffer string. + integer(I4P):: rf !< Real file index. integer(I4P):: n1 !< Counter. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - if (present(cf)) f = cf - select case(vtk(f)%f) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) case(ascii) - s_buffer = repeat(' ',vtk(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)//'' + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(rf)%indent = vtk(rf)%indent + 2 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent + 2 + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + do n1=1,NN + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//& + str(n=XYZ(1,n1))//' '//str(n=XYZ(2,n1))//' '//str(n=XYZ(3,n1)) + enddo + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent - 2 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + s_buffer = repeat(' ',vtk(rf)%indent)// & + '' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = 3*NN*BYR8P) + write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R8',3*NN + write(unit=vtk(rf)%ua,iostat=E_IO)XYZ + vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec case(binary) - s_buffer = repeat(' ',vtk(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 + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call pack_data(a1=[int(3*NN*BYR8P,I4P)],a2=reshape(XYZ,[3*NN]),packed=XYZp) + call b64_encode(nB=int(BYI1P,I4P),n=XYZp,code=XYZ64) ; deallocate(XYZp) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(XYZ64)//end_rec ; deallocate(XYZ64) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_GEO_XML_STRG_1DAP_R8 + + !> Function for saving mesh with \b StructuredGrid topology (R8P, 3D Arrays, packed API). + !> @return E_IO: integer(I4P) error flag + function VTK_GEO_XML_STRG_3DAP_R8(nx1,nx2,ny1,ny2,nz1,nz2,NN,XYZ,cf) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: nx1 !< Initial node of x axis. + integer(I4P), intent(IN):: nx2 !< Final node of x axis. + integer(I4P), intent(IN):: ny1 !< Initial node of y axis. + integer(I4P), intent(IN):: ny2 !< Final node of y axis. + integer(I4P), intent(IN):: nz1 !< Initial node of z axis. + integer(I4P), intent(IN):: nz2 !< Final node of z axis. + integer(I4P), intent(IN):: NN !< Number of all nodes. + real(R8P), intent(IN):: XYZ(1:,nx1:,ny1:,nz1:) !< X, Y, Z coordinates (packed API). + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + integer(I1P), allocatable:: XYZp(:) !< Packed coordinates data. + character(1), allocatable:: XYZ64(:) !< X, Y, Z coordinates encoded in base64. + character(len=maxlen):: s_buffer !< Buffer string. + integer(I4P):: rf !< Real file index. + integer(I4P):: nx,ny,nz !< Counters. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) + case(ascii) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(rf)%indent = vtk(rf)%indent + 2 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent + 2 + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + do nz=nz1,nz2 + do ny=ny1,ny2 + do nx=nx1,nx2 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//& + str(n=XYZ(1,nx,ny,nz))//' '//str(n=XYZ(2,nx,ny,nz))//' '//str(n=XYZ(3,nx,ny,nz)) + enddo + enddo + enddo + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent - 2 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + s_buffer = repeat(' ',vtk(rf)%indent)// & + '' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = 3*NN*BYR8P) + write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R8',3*NN + write(unit=vtk(rf)%ua,iostat=E_IO)XYZ + vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + case(binary) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call pack_data(a1=[int(3*NN*BYR8P,I4P)],a2=reshape(XYZ,[3*NN]),packed=XYZp) + call b64_encode(nB=int(BYI1P,I4P),n=XYZp,code=XYZ64) ; deallocate(XYZp) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(XYZ64)//end_rec ; deallocate(XYZ64) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_GEO_XML_STRG_3DAP_R8 + + !> Function for saving mesh with \b StructuredGrid topology (R4P, 1D Arrays). + !> @return E_IO: integer(I4P) error flag + function VTK_GEO_XML_STRG_1DA_R4(nx1,nx2,ny1,ny2,nz1,nz2,NN,X,Y,Z,cf) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: nx1 !< Initial node of x axis. + integer(I4P), intent(IN):: nx2 !< Final node of x axis. + integer(I4P), intent(IN):: ny1 !< Initial node of y axis. + integer(I4P), intent(IN):: ny2 !< Final node of y axis. + integer(I4P), intent(IN):: nz1 !< Initial node of z axis. + integer(I4P), intent(IN):: nz2 !< Final node of z axis. + integer(I4P), intent(IN):: NN !< Number of all nodes. + real(R4P), intent(IN):: X(1:) !< X coordinates [1:NN]. + real(R4P), intent(IN):: Y(1:) !< Y coordinates [1:NN]. + real(R4P), intent(IN):: Z(1:) !< Z coordinates [1:NN]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + character(len=maxlen):: s_buffer !< Buffer string. + integer(I1P), allocatable:: XYZp(:) !< Packed data. + character(1), allocatable:: XYZ64(:) !< X, Y, Z coordinates encoded in base64. + integer(I4P):: rf !< Real file index. + integer(I4P):: n1 !< Counter. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) + case(ascii) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(rf)%indent = vtk(rf)%indent + 2 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent + 2 + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + do n1=1,NN + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//str(n=X(n1))//' '//str(n=Y(n1))//' '//str(n=Z(n1)) + enddo + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent - 2 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + s_buffer = repeat(' ',vtk(rf)%indent)// & + '' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = 3*NN*BYR4P) + write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R4',3*NN + write(unit=vtk(rf)%ua,iostat=E_IO)(X(n1),Y(n1),Z(n1),n1=1,NN) + vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + case(binary) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call pack_data(a1=[int(3*NN*BYR4P,I4P)],a2=[(X(n1),Y(n1),Z(n1),n1=1,NN)],packed=XYZp) + call b64_encode(nB=int(BYI1P,I4P),n=XYZp,code=XYZ64) ; deallocate(XYZp) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(XYZ64)//end_rec ; deallocate(XYZ64) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_GEO_XML_STRG_1DA_R4 + + !> Function for saving mesh with \b StructuredGrid topology (R4P, 3D Arrays). + !> @return E_IO: integer(I4P) error flag + function VTK_GEO_XML_STRG_3DA_R4(nx1,nx2,ny1,ny2,nz1,nz2,NN,X,Y,Z,cf) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: nx1 !< Initial node of x axis. + integer(I4P), intent(IN):: nx2 !< Final node of x axis. + integer(I4P), intent(IN):: ny1 !< Initial node of y axis. + integer(I4P), intent(IN):: ny2 !< Final node of y axis. + integer(I4P), intent(IN):: nz1 !< Initial node of z axis. + integer(I4P), intent(IN):: nz2 !< Final node of z axis. + integer(I4P), intent(IN):: NN !< Number of all nodes. + real(R4P), intent(IN):: X(nx1:,ny1:,nz1:) !< X coordinates [nx1:nx2,ny1:ny2,nz1:nz2]. + real(R4P), intent(IN):: Y(nx1:,ny1:,nz1:) !< Y coordinates [nx1:nx2,ny1:ny2,nz1:nz2]. + real(R4P), intent(IN):: Z(nx1:,ny1:,nz1:) !< Z coordinates [nx1:nx2,ny1:ny2,nz1:nz2]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + character(len=maxlen):: s_buffer !< Buffer string. + integer(I1P), allocatable:: XYZp(:) !< Packed data. + character(1), allocatable:: XYZ64(:) !< X, Y, Z coordinates encoded in base64. + integer(I4P):: rf !< Real file index. + integer(I4P):: nx,ny,nz !< Counters. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) + case(ascii) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(rf)%indent = vtk(rf)%indent + 2 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent + 2 + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + do nz=nz1,nz2 + do ny=ny1,ny2 + do nx=nx1,nx2 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//& + str(n=X(nx,ny,nz))//' '//str(n=Y(nx,ny,nz))//' '//str(n=Z(nx,ny,nz)) + enddo + enddo + enddo + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent - 2 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + s_buffer = repeat(' ',vtk(rf)%indent)// & + '' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = 3*NN*BYR4P) + write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R4',3*NN + write(unit=vtk(rf)%ua,iostat=E_IO)(((X(nx,ny,nz),Y(nx,ny,nz),Z(nx,ny,nz),nx=nx1,nx2),ny=ny1,ny2),nz=nz1,nz2) + vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + case(binary) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call pack_data(a1=[int(3*NN*BYR4P,I4P)],a2=[(((X(nx,ny,nz),Y(nx,ny,nz),Z(nx,ny,nz),nx=nx1,nx2),ny=ny1,ny2),nz=nz1,nz2)], & + packed=XYZp) + call b64_encode(nB=int(BYI1P,I4P),n=XYZp,code=XYZ64) ; deallocate(XYZp) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(XYZ64)//end_rec ; deallocate(XYZ64) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_GEO_XML_STRG_3DA_R4 + + !> Function for saving mesh with \b StructuredGrid topology (R4P, 1D Arrays, packed API). + !> @return E_IO: integer(I4P) error flag + function VTK_GEO_XML_STRG_1DAP_R4(nx1,nx2,ny1,ny2,nz1,nz2,NN,XYZ,cf) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: nx1 !< Initial node of x axis. + integer(I4P), intent(IN):: nx2 !< Final node of x axis. + integer(I4P), intent(IN):: ny1 !< Initial node of y axis. + integer(I4P), intent(IN):: ny2 !< Final node of y axis. + integer(I4P), intent(IN):: nz1 !< Initial node of z axis. + integer(I4P), intent(IN):: nz2 !< Final node of z axis. + integer(I4P), intent(IN):: NN !< Number of all nodes. + real(R4P), intent(IN):: XYZ(1:,1:) !< X, Y, Z coordinates (packed API) [1:3,1:NN]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + character(len=maxlen):: s_buffer !< Buffer string. + integer(I1P), allocatable:: XYZp(:) !< Packed data. + character(1), allocatable:: XYZ64(:) !< X, Y, Z coordinates encoded in base64. + integer(I4P):: rf !< Real file index. + integer(I4P):: n1 !< Counter. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) + case(ascii) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(rf)%indent = vtk(rf)%indent + 2 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent + 2 + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + do n1=1,NN + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//& + str(n=XYZ(1,n1))//' '//str(n=XYZ(2,n1))//' '//str(n=XYZ(3,n1)) + enddo + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent - 2 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + s_buffer = repeat(' ',vtk(rf)%indent)// & + '' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = 3*NN*BYR4P) + write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R4',3*NN + write(unit=vtk(rf)%ua,iostat=E_IO)XYZ + vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + case(binary) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call pack_data(a1=[int(3*NN*BYR4P,I4P)],a2=reshape(XYZ,[3*NN]),packed=XYZp) + call b64_encode(nB=int(BYI1P,I4P),n=XYZp,code=XYZ64) ; deallocate(XYZp) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(XYZ64)//end_rec ; deallocate(XYZ64) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_GEO_XML_STRG_1DAP_R4 + + !> Function for saving mesh with \b StructuredGrid topology (R4P, 3D Arrays, packed API). + !> @return E_IO: integer(I4P) error flag + function VTK_GEO_XML_STRG_3DAP_R4(nx1,nx2,ny1,ny2,nz1,nz2,NN,XYZ,cf) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: nx1 !< Initial node of x axis. + integer(I4P), intent(IN):: nx2 !< Final node of x axis. + integer(I4P), intent(IN):: ny1 !< Initial node of y axis. + integer(I4P), intent(IN):: ny2 !< Final node of y axis. + integer(I4P), intent(IN):: nz1 !< Initial node of z axis. + integer(I4P), intent(IN):: nz2 !< Final node of z axis. + integer(I4P), intent(IN):: NN !< Number of all nodes. + real(R4P), intent(IN):: XYZ(1:,nx1:,ny1:,nz1:) !< X, Y, Z coordinates (packed API) [1:3,nx1:nx2,ny1:ny2,nz1:nz2]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + character(len=maxlen):: s_buffer !< Buffer string. + integer(I1P), allocatable:: XYZp(:) !< Packed data. + character(1), allocatable:: XYZ64(:) !< X, Y, Z coordinates encoded in base64. + integer(I4P):: rf !< Real file index. + integer(I4P):: nx,ny,nz !< Counters. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) + case(ascii) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(rf)%indent = vtk(rf)%indent + 2 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent + 2 + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + do nz=nz1,nz2 + do ny=ny1,ny2 + do nx=nx1,nx2 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//& + str(n=XYZ(1,nx,ny,nz))//' '//str(n=XYZ(2,nx,ny,nz))//' '//str(n=XYZ(3,nx,ny,nz)) + enddo + enddo + enddo + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent - 2 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + s_buffer = repeat(' ',vtk(rf)%indent)// & + '' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = 3*NN*BYR4P) + write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R4',3*NN + write(unit=vtk(rf)%ua,iostat=E_IO)XYZ + vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + case(binary) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call pack_data(a1=[int(3*NN*BYR4P,I4P)],a2=reshape(XYZ,[3*NN]),packed=XYZp) + call b64_encode(nB=int(BYI1P,I4P),n=XYZp,code=XYZ64) ; deallocate(XYZp) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(XYZ64)//end_rec ; deallocate(XYZ64) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_GEO_XML_STRG_3DAP_R4 + + !> Function for saving mesh with \b RectilinearGrid topology (R8P). + !> @return E_IO: integer(I4P) error flag + function VTK_GEO_XML_RECT_R8(nx1,nx2,ny1,ny2,nz1,nz2,X,Y,Z,cf) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: nx1 !< Initial node of x axis. + integer(I4P), intent(IN):: nx2 !< Final node of x axis. + integer(I4P), intent(IN):: ny1 !< Initial node of y axis. + integer(I4P), intent(IN):: ny2 !< Final node of y axis. + integer(I4P), intent(IN):: nz1 !< Initial node of z axis. + integer(I4P), intent(IN):: nz2 !< Final node of z axis. + real(R8P), intent(IN):: X(nx1:nx2) !< X coordinates. + real(R8P), intent(IN):: Y(ny1:ny2) !< Y coordinates. + real(R8P), intent(IN):: Z(nz1:nz2) !< Z coordinates. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + character(len=maxlen):: s_buffer !< Buffer string. + integer(I1P), allocatable:: XYZp(:) !< Packed data. + character(1), allocatable:: XYZ64(:) !< X, Y, Z coordinates encoded in base64. + integer(I4P):: rf !< Real file index. + integer(I4P):: n1 !< Counter. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) + case(ascii) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(rf)%indent = vtk(rf)%indent + 2 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent + 2 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,fmt=FR8P, iostat=E_IO)(X(n1),n1=nx1,nx2) + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,fmt=FR8P, iostat=E_IO)(Y(n1),n1=ny1,ny2) + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,fmt=FR8P, iostat=E_IO)(Z(n1),n1=nz1,nz2) + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent - 2 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = (nx2-nx1+1)*BYR8P) + write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R8',(nx2-nx1+1) + write(unit=vtk(rf)%ua,iostat=E_IO)(X(n1),n1=nx1,nx2) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = (ny2-ny1+1)*BYR8P) + write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R8',(ny2-ny1+1) + write(unit=vtk(rf)%ua,iostat=E_IO)(Y(n1),n1=ny1,ny2) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = (nz2-nz1+1)*BYR8P) + write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R8',(nz2-nz1+1) + write(unit=vtk(rf)%ua,iostat=E_IO)(Z(n1),n1=nz1,nz2) + vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + case(binary) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call pack_data(a1=[int((nx2-nx1+1)*BYR8P,I4P)],a2=X,packed=XYZp) + call b64_encode(nB=int(BYI1P,I4P),n=XYZp,code=XYZ64) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(XYZ64)//end_rec + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call pack_data(a1=[int((ny2-ny1+1)*BYR8P,I4P)],a2=Y,packed=XYZp) + call b64_encode(nB=int(BYI1P,I4P),n=XYZp,code=XYZ64) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(XYZ64)//end_rec + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call pack_data(a1=[int((nz2-nz1+1)*BYR8P,I4P)],a2=Z,packed=XYZp) + call b64_encode(nB=int(BYI1P,I4P),n=XYZp,code=XYZ64) ; deallocate(XYZp) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(XYZ64)//end_rec ; deallocate(XYZ64) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + vtk(rf)%indent = vtk(rf)%indent - 2 + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec endselect return !--------------------------------------------------------------------------------------------------------------------------------- @@ -1036,68 +1801,102 @@ contains !> 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) + function VTK_GEO_XML_RECT_R4(nx1,nx2,ny1,ny2,nz1,nz2,X,Y,Z,cf) result(E_IO) !--------------------------------------------------------------------------------------------------------------------------------- implicit none - integer(I4P), intent(IN), 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. + integer(I4P), intent(IN):: nx1 !< Initial node of x axis. + integer(I4P), intent(IN):: nx2 !< Final node of x axis. + integer(I4P), intent(IN):: ny1 !< Initial node of y axis. + integer(I4P), intent(IN):: ny2 !< Final node of y axis. + integer(I4P), intent(IN):: nz1 !< Initial node of z axis. + integer(I4P), intent(IN):: nz2 !< Final node of z axis. + real(R4P), intent(IN):: X(nx1:nx2) !< X coordinates. + real(R4P), intent(IN):: Y(ny1:ny2) !< Y coordinates. + real(R4P), intent(IN):: Z(nz1:nz2) !< Z coordinates. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + character(len=maxlen):: s_buffer !< Buffer string. + integer(I1P), allocatable:: XYZp(:) !< Packed data. + character(1), allocatable:: XYZ64(:) !< X, Y, Z coordinates encoded in base64. + integer(I4P):: rf !< Real file index. + integer(I4P):: n1 !< Counter. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - if (present(cf)) f = cf - select case(vtk(f)%f) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) case(ascii) - s_buffer = repeat(' ',vtk(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)//'' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(rf)%indent = vtk(rf)%indent + 2 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent + 2 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,fmt=FR4P, iostat=E_IO)(X(n1),n1=nx1,nx2) + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,fmt=FR4P, iostat=E_IO)(Y(n1),n1=ny1,ny2) + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,fmt=FR4P, iostat=E_IO)(Z(n1),n1=nz1,nz2) + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent - 2 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = (nx2-nx1+1)*BYR4P) + write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R4',(nx2-nx1+1) + write(unit=vtk(rf)%ua,iostat=E_IO)(X(n1),n1=nx1,nx2) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = (ny2-ny1+1)*BYR4P) + write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R4',(ny2-ny1+1) + write(unit=vtk(rf)%ua,iostat=E_IO)(Y(n1),n1=ny1,ny2) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = (nz2-nz1+1)*BYR4P) + write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R4',(nz2-nz1+1) + write(unit=vtk(rf)%ua,iostat=E_IO)(Z(n1),n1=nz1,nz2) + vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec case(binary) - s_buffer = repeat(' ',vtk(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 + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call pack_data(a1=[int((nx2-nx1+1)*BYR4P,I4P)],a2=X,packed=XYZp) + call b64_encode(nB=int(BYI1P,I4P),n=XYZp,code=XYZ64) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(XYZ64)//end_rec + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call pack_data(a1=[int((ny2-ny1+1)*BYR4P,I4P)],a2=Y,packed=XYZp) + call b64_encode(nB=int(BYI1P,I4P),n=XYZp,code=XYZ64) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(XYZ64)//end_rec + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call pack_data(a1=[int((nz2-nz1+1)*BYR4P,I4P)],a2=Z,packed=XYZp) + call b64_encode(nB=int(BYI1P,I4P),n=XYZp,code=XYZ64) ; deallocate(XYZp) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(XYZ64)//end_rec ; deallocate(XYZ64) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + vtk(rf)%indent = vtk(rf)%indent - 2 + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec endselect return !--------------------------------------------------------------------------------------------------------------------------------- @@ -1105,94 +1904,282 @@ contains !> 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) + function VTK_GEO_XML_UNST_R8(NN,NC,X,Y,Z,cf) 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), intent(IN), optional:: cf !< Current file index (for concurrent files IO). integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. character(len=maxlen):: s_buffer !< Buffer string. + real(R8P), allocatable:: XYZa(:) !< X, Y, Z coordinates. + integer(I1P), allocatable:: XYZp(:) !< Packed data. + character(1), allocatable:: XYZ64(:) !< X, Y, Z coordinates encoded in base64. + integer(I4P):: rf !< Real file index. integer(I4P):: n1 !< Counter. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - if (present(cf)) f = cf - select case(vtk(f)%f) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) case(ascii) - s_buffer = repeat(' ',vtk(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)// & + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(rf)%indent = vtk(rf)%indent + 2 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent + 2 + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + do n1=1,NN + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//str(n=X(n1))//' '//str(n=Y(n1))//' '//str(n=Z(n1)) + enddo + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent - 2 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + s_buffer = repeat(' ',vtk(rf)%indent)// & '' - write(unit=vtk(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 + trim(str(.true.,vtk(rf)%ioffset))//'"/>' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = 3*NN*BYR8P) + write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R8',3*NN + write(unit=vtk(rf)%ua,iostat=E_IO)(X(n1),Y(n1),Z(n1),n1=1,NN) + vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + case(binary) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + allocate(XYZa(1:3*NN)) + do n1 = 1,NN + XYZa(1+(n1-1)*3:1+(n1-1)*3+2)=[X(n1),Y(n1),Z(n1)] + enddo + call pack_data(a1=[int(3*NN*BYR8P,I4P)],a2=XYZa,packed=XYZp) ; deallocate(XYZa) + call b64_encode(nB=int(BYI1P,I4P),n=XYZp,code=XYZ64) ; deallocate(XYZp) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(XYZ64)//end_rec ; deallocate(XYZ64) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec endselect return !--------------------------------------------------------------------------------------------------------------------------------- endfunction VTK_GEO_XML_UNST_R8 - !> Function for saving mesh with \b UnstructuredGrid topology (R4P). + !> Function for saving mesh with \b UnstructuredGrid topology (R8P, packed API). !> @return E_IO: integer(I4P) error flag - function VTK_GEO_XML_UNST_R4(cf,NN,NC,X,Y,Z) result(E_IO) + function VTK_GEO_XML_UNST_PACK_R8(NN,NC,XYZ,cf) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: NN !< Number of nodes. + integer(I4P), intent(IN):: NC !< Number of cells. + real(R8P), intent(IN):: XYZ(1:3,1:NN) !< X, Y, Z coordinates (packed API). + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + character(len=maxlen):: s_buffer !< Buffer string. + real(R8P), allocatable:: XYZa(:) !< X, Y, Z coordinates. + integer(I1P), allocatable:: XYZp(:) !< Packed data. + character(1), allocatable:: XYZ64(:) !< X, Y, Z coordinates encoded in base64. + integer(I4P):: rf !< Real file index. + integer(I4P):: n1 !< Counter. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) + case(ascii) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(rf)%indent = vtk(rf)%indent + 2 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent + 2 + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + do n1=1,NN + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//& + str(n=XYZ(1,n1))//' '//str(n=XYZ(2,n1))//' '//str(n=XYZ(3,n1)) + enddo + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent - 2 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + s_buffer = repeat(' ',vtk(rf)%indent)// & + '' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = 3*NN*BYR8P) + write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R8',3*NN + write(unit=vtk(rf)%ua,iostat=E_IO)XYZ + vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + case(binary) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + allocate(XYZa(1:3*NN)) + do n1 = 1,NN + XYZa(1+(n1-1)*3:1+(n1-1)*3+2)=XYZ(1:3,n1) + enddo + call pack_data(a1=[int(3*NN*BYR8P,I4P)],a2=XYZa,packed=XYZp) ; deallocate(XYZa) + call b64_encode(nB=int(BYI1P,I4P),n=XYZp,code=XYZ64) ; deallocate(XYZp) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(XYZ64)//end_rec ; deallocate(XYZ64) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_GEO_XML_UNST_PACK_R8 + + !> Function for saving mesh with \b UnstructuredGrid topology (R4P). + !> @return E_IO: integer(I4P) error flag + function VTK_GEO_XML_UNST_R4(NN,NC,X,Y,Z,cf) result(E_IO) !--------------------------------------------------------------------------------------------------------------------------------- implicit none - integer(I4P), intent(IN), 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), intent(IN), optional:: cf !< Current file index (for concurrent files IO). integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. character(len=maxlen):: s_buffer !< Buffer string. + real(R4P), allocatable:: XYZa(:) !< X, Y, Z coordinates. + integer(I1P), allocatable:: XYZp(:) !< Packed data. + character(1), allocatable:: XYZ64(:) !< X, Y, Z coordinates encoded in base64. + integer(I4P):: rf !< Real file index. integer(I4P):: n1 !< Counter. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - if (present(cf)) f = cf - select case(vtk(f)%f) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) case(ascii) - s_buffer = repeat(' ',vtk(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)// & + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(rf)%indent = vtk(rf)%indent + 2 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent + 2 + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + do n1=1,NN + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//str(n=X(n1))//' '//str(n=Y(n1))//' '//str(n=Z(n1)) + enddo + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent - 2 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + s_buffer = repeat(' ',vtk(rf)%indent)// & '' - write(unit=vtk(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 + trim(str(.true.,vtk(rf)%ioffset))//'"/>' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = 3*NN*BYR4P) + write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R4',3*NN + write(unit=vtk(rf)%ua,iostat=E_IO)(X(n1),Y(n1),Z(n1),n1=1,NN) + vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + case(binary) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + allocate(XYZa(1:3*NN)) + do n1 = 1,NN + XYZa(1+(n1-1)*3:1+(n1-1)*3+2)=[X(n1),Y(n1),Z(n1)] + enddo + call pack_data(a1=[int(3*NN*BYR4P,I4P)],a2=XYZa,packed=XYZp) ; deallocate(XYZa) + call b64_encode(nB=int(BYI1P,I4P),n=XYZp,code=XYZ64) ; deallocate(XYZp) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(XYZ64)//end_rec ; deallocate(XYZ64) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec endselect return !--------------------------------------------------------------------------------------------------------------------------------- endfunction VTK_GEO_XML_UNST_R4 + !> Function for saving mesh with \b UnstructuredGrid topology (R4P, packed API). + !> @return E_IO: integer(I4P) error flag + function VTK_GEO_XML_UNST_PACK_R4(NN,NC,XYZ,cf) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: NN !< Number of nodes. + integer(I4P), intent(IN):: NC !< Number of cells. + real(R4P), intent(IN):: XYZ(1:3,1:NN) !< X, Y, Z coordinates (packed API). + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + character(len=maxlen):: s_buffer !< Buffer string. + real(R4P), allocatable:: XYZa(:) !< X, Y, Z coordinates. + integer(I1P), allocatable:: XYZp(:) !< Packed data. + character(1), allocatable:: XYZ64(:) !< X, Y, Z coordinates encoded in base64. + integer(I4P):: rf !< Real file index. + integer(I4P):: n1 !< Counter. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) + case(ascii) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(rf)%indent = vtk(rf)%indent + 2 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent + 2 + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + do n1=1,NN + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//& + str(n=XYZ(1,n1))//' '//str(n=XYZ(2,n1))//' '//str(n=XYZ(3,n1)) + enddo + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent - 2 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + s_buffer = repeat(' ',vtk(rf)%indent)// & + '' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = 3*NN*BYR4P) + write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R4',3*NN + write(unit=vtk(rf)%ua,iostat=E_IO)XYZ + vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + case(binary) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + allocate(XYZa(1:3*NN)) + do n1 = 1,NN + XYZa(1+(n1-1)*3:1+(n1-1)*3+2)=XYZ(1:3,n1) + enddo + call pack_data(a1=[int(3*NN*BYR4P,I4P)],a2=XYZa,packed=XYZp) ; deallocate(XYZa) + call b64_encode(nB=int(BYI1P,I4P),n=XYZp,code=XYZ64) ; deallocate(XYZp) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(XYZ64)//end_rec ; deallocate(XYZ64) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_GEO_XML_UNST_PACK_R4 + !> @brief Function for closing mesh block data. !> @return E_IO: integer(I4P) error flag function VTK_GEO_XML_CLOSEP(cf) result(E_IO) @@ -1200,16 +2187,21 @@ contains implicit none integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + integer(I4P):: rf !< Real file index. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - if (present(cf)) f = cf - vtk(f)%indent = vtk(f)%indent - 2 - select case(vtk(f)%f) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + vtk(rf)%indent = vtk(rf)%indent - 2 + select case(vtk(rf)%f) case(ascii) - write(unit=vtk(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 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,binary,bin_app) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec endselect return !--------------------------------------------------------------------------------------------------------------------------------- @@ -1258,56 +2250,105 @@ contains !> 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) + function VTK_CON_XML(NC,connect,offset,cell_type,idx,cf) 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. + integer(I4P), intent(IN):: NC !< Number of cells. + integer(I4P), intent(IN):: connect(1:) !< Mesh connectivity. + integer(I4P), intent(IN):: offset(1:NC) !< Cell offset. + integer(I1P), intent(IN):: cell_type(1:) !< VTK cell type. + integer(I1P), intent(IN), optional:: idx !< Id offset to convert Fortran (first id 1) to C (first id 0) standards. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + character(len=maxlen):: s_buffer !< Buffer string. + integer(I1P), allocatable:: cocp(:) !< Packed data. + character(1), allocatable:: coc64(:) !< Data encoded in base64. + integer(I1P):: incr !< Actual id offset increment. + integer(I4P):: rf !< Real file index. + integer(I4P):: n1 !< Counter. + integer(I8P):: Ncocp !< Dimension of cocp, packed data. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - if (present(cf)) f = cf - select case(vtk(f)%f) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + incr = 0_I1P + if (present(idx)) then + incr = idx + endif + select case(vtk(rf)%f) case(ascii) - write(unit=vtk(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)//'' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent + 2 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//& + '' + write(unit=vtk(rf)%u,fmt=FI4P, iostat=E_IO)(connect(n1)+incr,n1=1,offset(NC)) + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,fmt=FI4P, iostat=E_IO)(offset(n1),n1=1,NC) + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + if (lbound(cell_type,dim=1)==ubound(cell_type,dim=1)) then + write(unit=vtk(rf)%u,fmt=FI1P, iostat=E_IO)(cell_type(1),n1=1,NC) + else + write(unit=vtk(rf)%u,fmt=FI1P, iostat=E_IO)(cell_type(n1),n1=1,NC) + endif + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent - 2 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,bin_app) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = offset(NC)*BYI4P) + write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I4',offset(NC) + write(unit=vtk(rf)%ua,iostat=E_IO)(connect(n1)+incr,n1=1,offset(NC)) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = NC*BYI4P) + write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I4',NC + write(unit=vtk(rf)%ua,iostat=E_IO)(offset(n1),n1=1,NC) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = NC*BYI1P) + write(unit=vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I1',NC + if (lbound(cell_type,dim=1)==ubound(cell_type,dim=1)) then + write(unit=vtk(rf)%ua,iostat=E_IO)(cell_type(1),n1=1,NC) + else + write(unit=vtk(rf)%ua,iostat=E_IO)(cell_type(n1),n1=1,NC) + endif + vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec case(binary) - write(unit=vtk(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 + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent + 2 + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//& + ''//end_rec + Ncocp=size(transfer([int(offset(NC)*BYI4P,I4P),connect],cocp)) ; if (allocated(cocp)) deallocate(cocp) ; allocate(cocp(1:Ncocp)) + cocp = transfer([int(offset(NC)*BYI4P,I4P),connect],cocp) + call b64_encode(nB=int(BYI1P,I4P),n=cocp,code=coc64) + deallocate(cocp) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(coc64)//end_rec + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + Ncocp=size(transfer([int(NC*BYI4P,I4P),offset],cocp)) ; if (allocated(cocp)) deallocate(cocp) ; allocate(cocp(1:Ncocp)) + cocp = transfer([int(NC*BYI4P,I4P),offset],cocp) + call b64_encode(nB=int(BYI1P,I4P),n=cocp,code=coc64) + deallocate(cocp) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(coc64)//end_rec + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + if (lbound(cell_type,dim=1)==ubound(cell_type,dim=1)) then + call pack_data(a1=[int(NC*BYI1P,I4P)],a2=[(cell_type(1),n1=1,NC)],packed=cocp) + else + call pack_data(a1=[int(NC*BYI1P,I4P)],a2=cell_type,packed=cocp) + endif + call b64_encode(nB=int(BYI1P,I4P),n=cocp,code=coc64) ; deallocate(cocp) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(coc64)//end_rec ; deallocate(coc64) + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%indent - 2 + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec endselect return !--------------------------------------------------------------------------------------------------------------------------------- @@ -1328,50 +2369,55 @@ contains !> ... @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) + function VTK_DAT_XML(var_location,var_block_action,cf) 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), intent(IN), optional:: cf !< Current file index (for concurrent files IO). integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + integer(I4P):: rf !< Real file index. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - if (present(cf)) f = cf - select case(vtk(f)%f) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) case(ascii) select case(trim(Upper_Case(var_location))) case('CELL') select case(trim(Upper_Case(var_block_action))) case('OPEN') - write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' ; vtk(f)%indent = vtk(f)%indent + 2 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%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)//'' + vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' endselect case('NODE') select case(trim(Upper_Case(var_block_action))) case('OPEN') - write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' ; vtk(f)%indent = vtk(f)%indent + 2 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%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)//'' + vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' endselect endselect - case(binary) + case(raw,binary,bin_app) select case(trim(Upper_Case(var_location))) case('CELL') select case(trim(Upper_Case(var_block_action))) case('OPEN') - write(unit=vtk(f)%u,iostat=E_IO)repeat(' ',vtk(f)%indent)//''//end_rec ; vtk(f)%indent = vtk(f)%indent + 2 + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%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 + vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec endselect case('NODE') select case(trim(Upper_Case(var_block_action))) case('OPEN') - write(unit=vtk(f)%u,iostat=E_IO)repeat(' ',vtk(f)%indent)//''//end_rec ; vtk(f)%indent = vtk(f)%indent + 2 + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec ; vtk(rf)%indent = vtk(rf)%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 + vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec endselect endselect endselect @@ -1382,676 +2428,1998 @@ contains !> @ingroup Lib_VTK_IOPrivateProcedure !> @{ - !> Function for saving field of scalar variable (R8P). + !> Function for saving field of scalar variable (R8P, 1D array). !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_SCAL_R8(cf,NC_NN,varname,var) result(E_IO) + function VTK_VAR_XML_SCAL_1DA_R8(NC_NN,varname,var,cf) 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. + integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. + character(*), intent(IN):: varname !< Variable name. + real(R8P), intent(IN):: var(1:) !< Variable to be saved [1:NC_NN]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + character(len=maxlen):: s_buffer !< Buffer string. + integer(I1P), allocatable:: varp(:) !< Packed data. + character(1), allocatable:: var64(:) !< Variable encoded in base64. + integer(I4P):: rf !< Real file index. + integer(I4P):: n1 !< Counter. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - if (present(cf)) f = cf - select case(vtk(f)%f) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) case(ascii) - s_buffer = repeat(' ',vtk(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)//'' + write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) + write(vtk(rf)%u,'('//trim(str(.true.,NC_NN+1))//'A)',iostat=E_IO)repeat(' ',vtk(rf)%indent),(' '//str(n=var(n1)),n1=1,NC_NN) + write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = NC_NN*BYR8P) + write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R8',NC_NN + write(vtk(rf)%ua,iostat=E_IO)var case(binary) - s_buffer = repeat(' ',vtk(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) + s_buffer=repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call pack_data(a1=[int(NC_NN*BYR8P,I4P)],a2=var,packed=varp) + call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec endselect return !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_SCAL_R8 + endfunction VTK_VAR_XML_SCAL_1DA_R8 - !> Function for saving field of scalar variable (R4P). + !> Function for saving field of scalar variable (R8P, 3D array). !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_SCAL_R4(cf,NC_NN,varname,var) result(E_IO) + function VTK_VAR_XML_SCAL_3DA_R8(NC_NN,varname,var,cf) 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. + integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. + character(*), intent(IN):: varname !< Variable name. + real(R8P), intent(IN):: var(1:,1:,1:) !< Variable to be saved [1:Nx,1:Ny,1:Nz]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + character(len=maxlen):: s_buffer !< Buffer string. + integer(I1P), allocatable:: varp(:) !< Packed data. + character(1), allocatable:: var64(:) !< Variable encoded in base64. + integer(I4P):: rf !< Real file index. + integer(I4P):: nx,ny,nz !< Counters. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - if (present(cf)) f = cf - select case(vtk(f)%f) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) case(ascii) - s_buffer = repeat(' ',vtk(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)//'' + write(vtk(rf)%u,'(A)', iostat=E_IO)trim(s_buffer) + write(vtk(rf)%u,'('//trim(str(.true.,NC_NN+1))//'A)',iostat=E_IO)repeat(' ',vtk(rf)%indent),& + (((' '//str(n=var(nx,ny,nz)),nx=1,size(var,dim=1)),ny=1,size(var,dim=2)),nz=1,size(var,dim=3)) + write(vtk(rf)%u,'(A)', iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = NC_NN*BYR8P) + write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R8',NC_NN + write(vtk(rf)%ua,iostat=E_IO)var case(binary) - s_buffer = repeat(' ',vtk(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) + s_buffer=repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call pack_data(a1=[int(NC_NN*BYR8P,I4P)],a2=reshape(var,[NC_NN]),packed=varp) + call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec endselect return !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_SCAL_R4 + endfunction VTK_VAR_XML_SCAL_3DA_R8 - !> Function for saving field of scalar variable (I8P). + !> Function for saving field of scalar variable (R4P, 1D array). !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_SCAL_I8(cf,NC_NN,varname,var) result(E_IO) + function VTK_VAR_XML_SCAL_1DA_R4(NC_NN,varname,var,cf) 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. + integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. + character(*), intent(IN):: varname !< Variable name. + real(R4P), intent(IN):: var(1:) !< Variable to be saved [1:NC_NN]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + character(len=maxlen):: s_buffer !< Buffer string. + integer(I1P), allocatable:: varp(:) !< Packed data. + character(1), allocatable:: var64(:) !< Variable encoded in base64. + integer(I4P):: rf !< Real file index. + integer(I4P):: n1 !< Counter. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - if (present(cf)) f = cf - select case(vtk(f)%f) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) case(ascii) - s_buffer = repeat(' ',vtk(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)'' + write(vtk(rf)%u,'(A)', iostat=E_IO)trim(s_buffer) + write(vtk(rf)%u,'('//trim(str(.true.,NC_NN+1))//'A)',iostat=E_IO)repeat(' ',vtk(rf)%indent),(' '//str(n=var(n1)),n1=1,NC_NN) + write(vtk(rf)%u,'(A)', iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = NC_NN*BYR4P) + write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R4',NC_NN + write(vtk(rf)%ua,iostat=E_IO)var case(binary) - s_buffer = repeat(' ',vtk(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) + s_buffer=repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call pack_data(a1=[int(NC_NN*BYR4P,I4P)],a2=var,packed=varp) + call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec endselect return !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_SCAL_I8 + endfunction VTK_VAR_XML_SCAL_1DA_R4 - !> Function for saving field of scalar variable (I4P). + !> Function for saving field of scalar variable (R4P, 3D array). !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_SCAL_I4(cf,NC_NN,varname,var) result(E_IO) + function VTK_VAR_XML_SCAL_3DA_R4(NC_NN,varname,var,cf) 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. + integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. + character(*), intent(IN):: varname !< Variable name. + real(R4P), intent(IN):: var(1:,1:,1:) !< Variable to be saved [1:Nx,1:Ny,1:Nz]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + character(len=maxlen):: s_buffer !< Buffer string. + integer(I1P), allocatable:: varp(:) !< Packed data. + character(1), allocatable:: var64(:) !< Variable encoded in base64. + integer(I4P):: rf !< Real file index. + integer(I4P):: nx,ny,nz !< Counters. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - if (present(cf)) f = cf - select case(vtk(f)%f) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) case(ascii) - s_buffer = repeat(' ',vtk(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)//'' + write(vtk(rf)%u,'(A)', iostat=E_IO)trim(s_buffer) + write(vtk(rf)%u,'('//trim(str(.true.,NC_NN+1))//'A)',iostat=E_IO)repeat(' ',vtk(rf)%indent),& + (((' '//str(n=var(nx,ny,nz)),nx=1,size(var,dim=1)),ny=1,size(var,dim=2)),nz=1,size(var,dim=3)) + write(vtk(rf)%u,'(A)', iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = NC_NN*BYR4P) + write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R4',NC_NN + write(vtk(rf)%ua,iostat=E_IO)var case(binary) - s_buffer = repeat(' ',vtk(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) + s_buffer=repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call pack_data(a1=[int(NC_NN*BYR4P,I4P)],a2=reshape(var,[NC_NN]),packed=varp) + call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec endselect return !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_SCAL_I4 + endfunction VTK_VAR_XML_SCAL_3DA_R4 - !> Function for saving field of scalar variable (I2P). + !> Function for saving field of scalar variable (I8P, 1D array). !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_SCAL_I2(cf,NC_NN,varname,var) result(E_IO) + function VTK_VAR_XML_SCAL_1DA_I8(NC_NN,varname,var,cf) 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. + integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. + character(*), intent(IN):: varname !< Variable name. + integer(I8P), intent(IN):: var(1:) !< Variable to be saved [1:NC_NN]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + character(len=maxlen):: s_buffer !< Buffer string. + integer(I1P), allocatable:: varp(:) !< Packed data. + character(1), allocatable:: var64(:) !< Variable encoded in base64. + integer(I4P):: rf !< Real file index. + integer(I4P):: n1 !< Counter. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - if (present(cf)) f = cf - select case(vtk(f)%f) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) case(ascii) - s_buffer = repeat(' ',vtk(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)//'' + write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) + write(vtk(rf)%u,'('//trim(str(.true.,NC_NN+1))//'A)',iostat=E_IO)repeat(' ',vtk(rf)%indent),(' '//str(n=var(n1)),n1=1,NC_NN) + write(vtk(rf)%u,'(A)',iostat=E_IO)'' + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = int(NC_NN*BYI8P,I4P)) + write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I8',NC_NN + write(vtk(rf)%ua,iostat=E_IO)var case(binary) - s_buffer = repeat(' ',vtk(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) + s_buffer=repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call pack_data(a1=[int(NC_NN*BYI8P,I4P)],a2=var,packed=varp) + call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec endselect return !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_SCAL_I2 + endfunction VTK_VAR_XML_SCAL_1DA_I8 - !> Function for saving field of scalar variable (I1P). + !> Function for saving field of scalar variable (I8P, 3D array). !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_SCAL_I1(cf,NC_NN,varname,var) result(E_IO) + function VTK_VAR_XML_SCAL_3DA_I8(NC_NN,varname,var,cf) 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(I8P), intent(IN):: var(1:,1:,1:) !< Variable to be saved [1:Nx,1:Ny,1:Nz]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. character(len=maxlen):: s_buffer !< Buffer string. - integer(I4P):: n1 !< Counter. + integer(I1P), allocatable:: varp(:) !< Packed data. + character(1), allocatable:: var64(:) !< Variable encoded in base64. + integer(I4P):: rf !< Real file index. + integer(I4P):: nx,ny,nz !< Counters. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - if (present(cf)) f = cf - select case(vtk(f)%f) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) case(ascii) - s_buffer = repeat(' ',vtk(f)%indent)//'' + write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) + write(vtk(rf)%u,'('//trim(str(.true.,NC_NN+1))//'A)',iostat=E_IO)repeat(' ',vtk(rf)%indent),& + (((' '//str(n=var(nx,ny,nz)),nx=1,size(var,dim=1)),ny=1,size(var,dim=2)),nz=1,size(var,dim=3)) + write(vtk(rf)%u,'(A)',iostat=E_IO)'' + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = int(NC_NN*BYI8P,I4P)) + write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I8',NC_NN + write(vtk(rf)%ua,iostat=E_IO)var + case(binary) + s_buffer=repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call pack_data(a1=[int(NC_NN*BYI8P,I4P)],a2=reshape(var,[NC_NN]),packed=varp) + call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_VAR_XML_SCAL_3DA_I8 + + !> Function for saving field of scalar variable (I4P, 1D array). + !> @return E_IO: integer(I4P) error flag + function VTK_VAR_XML_SCAL_1DA_I4(NC_NN,varname,var,cf) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. + character(*), intent(IN):: varname !< Variable name. + integer(I4P), intent(IN):: var(1:) !< Variable to be saved [1:NC_NN]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + character(len=maxlen):: s_buffer !< Buffer string. + integer(I1P), allocatable:: varp(:) !< Packed data. + character(1), allocatable:: var64(:) !< Variable encoded in base64. + integer(I4P):: rf !< Real file index. + integer(I4P):: n1 !< Counter. + integer(I8P):: Nvarp !< Dimension of varp, packed data. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) + case(ascii) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) + write(vtk(rf)%u,'('//trim(str(.true.,NC_NN+1))//'A)',iostat=E_IO)repeat(' ',vtk(rf)%indent),(' '//str(n=var(n1)),n1=1,NC_NN) + write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = NC_NN*BYI4P) + write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I4',NC_NN + write(vtk(rf)%ua,iostat=E_IO)var + case(binary) + s_buffer=repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + Nvarp=size(transfer([int(NC_NN*BYI4P,I4P),var],varp)) ; if (allocated(varp)) deallocate(varp) ; allocate(varp(1:Nvarp)) + varp = transfer([int(NC_NN*BYI4P,I4P),var],varp) + call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_VAR_XML_SCAL_1DA_I4 + + !> Function for saving field of scalar variable (I4P, 3D array). + !> @return E_IO: integer(I4P) error flag + function VTK_VAR_XML_SCAL_3DA_I4(NC_NN,varname,var,cf) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. + character(*), intent(IN):: varname !< Variable name. + integer(I4P), intent(IN):: var(1:,1:,1:) !< Variable to be saved [1:Nx,1:Ny,1:Nz]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + character(len=maxlen):: s_buffer !< Buffer string. + integer(I1P), allocatable:: varp(:) !< Packed data. + character(1), allocatable:: var64(:) !< Variable encoded in base64. + integer(I4P):: rf !< Real file index. + integer(I4P):: nx,ny,nz !< Counters. + integer(I8P):: Nvarp !< Dimension of varp, packed data. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) + case(ascii) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) + write(vtk(rf)%u,'('//trim(str(.true.,NC_NN+1))//'A)',iostat=E_IO)repeat(' ',vtk(rf)%indent),& + (((' '//str(n=var(nx,ny,nz)),nx=1,size(var,dim=1)),ny=1,size(var,dim=2)),nz=1,size(var,dim=3)) + write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = NC_NN*BYI4P) + write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I4',NC_NN + write(vtk(rf)%ua,iostat=E_IO)var + case(binary) + s_buffer=repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + Nvarp=size(transfer([int(NC_NN*BYI4P,I4P),reshape(var,[NC_NN])],varp)) + if (allocated(varp)) deallocate(varp); allocate(varp(1:Nvarp)) + varp = transfer([int(NC_NN*BYI4P,I4P),reshape(var,[NC_NN])],varp) + call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_VAR_XML_SCAL_3DA_I4 + + !> Function for saving field of scalar variable (I2P, 1D array). + !> @return E_IO: integer(I4P) error flag + function VTK_VAR_XML_SCAL_1DA_I2(NC_NN,varname,var,cf) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. + character(*), intent(IN):: varname !< Variable name. + integer(I2P), intent(IN):: var(1:) !< Variable to be saved [1:NC_NN]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + character(len=maxlen):: s_buffer !< Buffer string. + integer(I1P), allocatable:: varp(:) !< Packed data. + character(1), allocatable:: var64(:) !< Variable encoded in base64. + integer(I4P):: rf !< Real file index. + integer(I4P):: n1 !< Counter. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) + case(ascii) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) + write(vtk(rf)%u,'('//trim(str(.true.,NC_NN+1))//'A)',iostat=E_IO)repeat(' ',vtk(rf)%indent),(' '//str(n=var(n1)),n1=1,NC_NN) + write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = NC_NN*BYI2P) + write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I2',NC_NN + write(vtk(rf)%ua,iostat=E_IO)var + case(binary) + s_buffer=repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call pack_data(a1=[int(NC_NN*BYI2P,I4P)],a2=var,packed=varp) + call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_VAR_XML_SCAL_1DA_I2 + + !> Function for saving field of scalar variable (I2P, 3D array). + !> @return E_IO: integer(I4P) error flag + function VTK_VAR_XML_SCAL_3DA_I2(NC_NN,varname,var,cf) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. + character(*), intent(IN):: varname !< Variable name. + integer(I2P), intent(IN):: var(1:,1:,1:) !< Variable to be saved [1:Nx,1:Ny,1:Nz]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + character(len=maxlen):: s_buffer !< Buffer string. + integer(I1P), allocatable:: varp(:) !< Packed data. + character(1), allocatable:: var64(:) !< Variable encoded in base64. + integer(I4P):: rf !< Real file index. + integer(I4P):: nx,ny,nz !< Counters. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) + case(ascii) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) + write(vtk(rf)%u,'('//trim(str(.true.,NC_NN+1))//'A)',iostat=E_IO)repeat(' ',vtk(rf)%indent),& + (((' '//str(n=var(nx,ny,nz)),nx=1,size(var,dim=1)),ny=1,size(var,dim=2)),nz=1,size(var,dim=3)) + write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = NC_NN*BYI2P) + write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I2',NC_NN + write(vtk(rf)%ua,iostat=E_IO)var + case(binary) + s_buffer=repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call pack_data(a1=[int(NC_NN*BYI2P,I4P)],a2=reshape(var,[NC_NN]),packed=varp) + call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_VAR_XML_SCAL_3DA_I2 + + !> Function for saving field of scalar variable (I1P, 1D array). + !> @return E_IO: integer(I4P) error flag + function VTK_VAR_XML_SCAL_1DA_I1(NC_NN,varname,var,cf) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. + character(*), intent(IN):: varname !< Variable name. + integer(I1P), intent(IN):: var(1:) !< Variable to be saved [1:NC_NN]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + character(len=maxlen):: s_buffer !< Buffer string. + integer(I1P), allocatable:: varp(:) !< Packed data. + character(1), allocatable:: var64(:) !< Variable encoded in base64. + integer(I4P):: rf !< Real file index. + integer(I4P):: n1 !< Counter. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) + case(ascii) + s_buffer=repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) + write(vtk(rf)%u,'('//trim(str(.true.,NC_NN+1))//'A)',iostat=E_IO)repeat(' ',vtk(rf)%indent),(' '//str(n=var(n1)),n1=1,NC_NN) + write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,bin_app) + s_buffer=repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = NC_NN*BYI1P) + write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I1',NC_NN + write(vtk(rf)%ua,iostat=E_IO)var + case(binary) + s_buffer=repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call pack_data(a1=[int(NC_NN*BYI1P,I4P)],a2=var,packed=varp) + call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_VAR_XML_SCAL_1DA_I1 + + !> Function for saving field of scalar variable (I1P, 3D array). + !> @return E_IO: integer(I4P) error flag + function VTK_VAR_XML_SCAL_3DA_I1(NC_NN,varname,var,cf) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. + character(*), intent(IN):: varname !< Variable name. + integer(I1P), intent(IN):: var(1:,1:,1:) !< Variable to be saved [1:Nx,1:ny,1:Nz]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + character(len=maxlen):: s_buffer !< Buffer string. + integer(I1P), allocatable:: varp(:) !< Packed data. + character(1), allocatable:: var64(:) !< Variable encoded in base64. + integer(I4P):: rf !< Real file index. + integer(I4P):: nx,ny,nz !< Counters. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) + case(ascii) + s_buffer=repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) + write(vtk(rf)%u,'('//trim(str(.true.,NC_NN+1))//'A)',iostat=E_IO)repeat(' ',vtk(rf)%indent),& + (((' '//str(n=var(nx,ny,nz)),nx=1,size(var,dim=1)),ny=1,size(var,dim=2)),nz=1,size(var,dim=3)) + write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,bin_app) + s_buffer=repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = NC_NN*BYI1P) + write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I1',NC_NN + write(vtk(rf)%ua,iostat=E_IO)var + case(binary) + s_buffer=repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call pack_data(a1=[int(NC_NN*BYI1P,I4P)],a2=reshape(var,[NC_NN]),packed=varp) + call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_VAR_XML_SCAL_3DA_I1 + + !> Function for saving field of vectorial variable (R8P, 1D arrays). + !> @return E_IO: integer(I4P) error flag + function VTK_VAR_XML_VECT_1DA_R8(NC_NN,varname,varX,varY,varZ,cf) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. + character(*), intent(IN):: varname !< Variable name. + real(R8P), intent(IN):: varX(1:) !< X component [1:NC_NN]. + real(R8P), intent(IN):: varY(1:) !< Y component [1:NC_NN]. + real(R8P), intent(IN):: varZ(1:) !< Z component [1:NC_NN]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + character(len=maxlen):: s_buffer !< Buffer string. + real(R8P), allocatable:: var(:) !< X, Y, Z component. + integer(I1P), allocatable:: varp(:) !< Packed data. + character(1), allocatable:: var64(:) !< Variable encoded in base64. + integer(I4P):: rf !< Real file index. + integer(I4P):: n1 !< Counter. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) + case(ascii) + s_buffer = repeat(' ',vtk(rf)%indent)//'' - write(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)//'' + write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) + do n1=1,NC_NN + write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//str(n=varX(n1))//' '//str(n=varY(n1))//' '//str(n=varZ(n1)) + enddo + write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = 3*NC_NN*BYR8P) + write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R8',3*NC_NN + write(vtk(rf)%ua,iostat=E_IO)(varX(n1),varY(n1),varZ(n1),n1=1,NC_NN) case(binary) - s_buffer = repeat(' ',vtk(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) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + allocate(var(1:3*NC_NN)) + do n1=1,NC_NN + var(1+(n1-1)*3:1+(n1-1)*3+2)=[varX(n1),varY(n1),varZ(n1)] + enddo + call pack_data(a1=[int(3*NC_NN*BYR8P,I4P)],a2=var,packed=varp) ; deallocate(var) + call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec endselect return !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_VECT_R8 + endfunction VTK_VAR_XML_VECT_1DA_R8 - !> Function for saving field of vectorial variable (R4P). + !> Function for saving field of vectorial variable (R8P, 3D arrays). !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_VECT_R4(cf,NC_NN,varname,varX,varY,varZ) result(E_IO) + function VTK_VAR_XML_VECT_3DA_R8(NC_NN,varname,varX,varY,varZ,cf) 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. + integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. + character(*), intent(IN):: varname !< Variable name. + real(R8P), intent(IN):: varX(1:,1:,1:) !< X component [1:Nx,1:Ny,1:Nz]. + real(R8P), intent(IN):: varY(1:,1:,1:) !< Y component [1:Nx,1:Ny,1:Nz]. + real(R8P), intent(IN):: varZ(1:,1:,1:) !< Z component [1:Nx,1:Ny,1:Nz]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + character(len=maxlen):: s_buffer !< Buffer string. + real(R8P), allocatable:: var(:) !< X, Y, Z component. + integer(I1P), allocatable:: varp(:) !< Packed data. + character(1), allocatable:: var64(:) !< Variable encoded in base64. + integer(I4P):: rf !< Real file index. + integer(I4P):: nx,ny,nz,n1 !< Counters. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - if (present(cf)) f = cf - select case(vtk(f)%f) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) case(ascii) - s_buffer = repeat(' ',vtk(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)//'' + write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) + do nz=1,size(varX,dim=3) ; do ny=1,size(varX,dim=2) ; do nx=1,size(varX,dim=1) + write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//& + str(n=varX(nx,ny,nz))//' '//str(n=varY(nx,ny,nz))//' '//str(n=varZ(nx,ny,nz)) + enddo ; enddo ; enddo + write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = 3*NC_NN*BYR8P) + write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R8',3*NC_NN + write(vtk(rf)%ua,iostat=E_IO)(((varX(nx,ny,nz),varY(nx,ny,nz),varZ(nx,ny,nz),& + nx=1,size(varX,dim=1)),ny=1,size(varX,dim=2)),nz=1,size(varX,dim=3)) case(binary) - s_buffer = repeat(' ',vtk(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) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + allocate(var(1:3*NC_NN)) + n1 = 0_I4P + do nz=1,size(varX,dim=3) ; do ny=1,size(varX,dim=2) ; do nx=1,size(varX,dim=1) + n1 = n1 + 1_I4P ; var(1+(n1-1)*3:1+(n1-1)*3+2)=[varX(nx,ny,nz),varY(nx,ny,nz),varZ(nx,ny,nz)] + enddo ; enddo ; enddo + call pack_data(a1=[int(3*NC_NN*BYR8P,I4P)],a2=var,packed=varp) ; deallocate(var) + call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec endselect return !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_VECT_R4 + endfunction VTK_VAR_XML_VECT_3DA_R8 - !> Function for saving field of vectorial variable (I8P). + !> Function for saving field of vectorial variable (R4P, 1D arrays). !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_VECT_I8(cf,NC_NN,varname,varX,varY,varZ) result(E_IO) + function VTK_VAR_XML_VECT_1DA_R4(NC_NN,varname,varX,varY,varZ,cf) 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. + integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. + character(*), intent(IN):: varname !< Variable name. + real(R4P), intent(IN):: varX(1:) !< X component [1:NC_NN]. + real(R4P), intent(IN):: varY(1:) !< Y component [1:NC_NN]. + real(R4P), intent(IN):: varZ(1:) !< Z component [1:NC_NN]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + character(len=maxlen):: s_buffer !< Buffer string. + real(R4P), allocatable:: var(:) !< X, Y, Z component. + integer(I1P), allocatable:: varp(:) !< Packed data. + character(1), allocatable:: var64(:) !< Variable encoded in base64. + integer(I4P):: rf !< Real file index. + integer(I4P):: n1 !< Counter. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - if (present(cf)) f = cf - select case(vtk(f)%f) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) case(ascii) - s_buffer = repeat(' ',vtk(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)//'' + write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) + do n1=1,NC_NN + write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//str(n=varX(n1))//' '//str(n=varY(n1))//' '//str(n=varZ(n1)) + enddo + write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = 3*NC_NN*BYR4P) + write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R4',3*NC_NN + write(vtk(rf)%ua,iostat=E_IO)(varX(n1),varY(n1),varZ(n1),n1=1,NC_NN) case(binary) - s_buffer = repeat(' ',vtk(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) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + allocate(var(1:3*NC_NN)) + do n1=1,NC_NN + var(1+(n1-1)*3:1+(n1-1)*3+2)=[varX(n1),varY(n1),varZ(n1)] + enddo + call pack_data(a1=[int(3*NC_NN*BYR4P,I4P)],a2=var,packed=varp) ; deallocate(var) + call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec endselect return !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_VECT_I8 + endfunction VTK_VAR_XML_VECT_1DA_R4 - !> Function for saving field of vectorial variable (I4P). + !> Function for saving field of vectorial variable (R4P, 3D arrays). !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_VECT_I4(cf,NC_NN,varname,varX,varY,varZ) result(E_IO) + function VTK_VAR_XML_VECT_3DA_R4(NC_NN,varname,varX,varY,varZ,cf) 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. + integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. + character(*), intent(IN):: varname !< Variable name. + real(R4P), intent(IN):: varX(1:,1:,1:) !< X component [1:Nx,1:Ny,1:Nz]. + real(R4P), intent(IN):: varY(1:,1:,1:) !< Y component [1:Nx,1:Ny,1:Nz]. + real(R4P), intent(IN):: varZ(1:,1:,1:) !< Z component [1:Nx,1:Ny,1:Nz]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + character(len=maxlen):: s_buffer !< Buffer string. + real(R4P), allocatable:: var(:) !< X, Y, Z component. + integer(I1P), allocatable:: varp(:) !< Packed data. + character(1), allocatable:: var64(:) !< Variable encoded in base64. + integer(I4P):: rf !< Real file index. + integer(I4P):: nx,ny,nz,n1 !< Counters. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - if (present(cf)) f = cf - select case(vtk(f)%f) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) case(ascii) - s_buffer = repeat(' ',vtk(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)//'' + write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) + do nz=1,size(varX,dim=3) ; do ny=1,size(varX,dim=2) ; do nx=1,size(varX,dim=1) + write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//& + str(n=varX(nx,ny,nz))//' '//str(n=varY(nx,ny,nz))//' '//str(n=varZ(nx,ny,nz)) + enddo ; enddo ; enddo + write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = 3*NC_NN*BYR4P) + write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R4',3*NC_NN + write(vtk(rf)%ua,iostat=E_IO)(((varX(nx,ny,nz),varY(nx,ny,nz),varZ(nx,ny,nz),& + nx=1,size(varX,dim=1)),ny=1,size(varX,dim=2)),nz=1,size(varX,dim=3)) case(binary) - s_buffer = repeat(' ',vtk(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) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + allocate(var(1:3*NC_NN)) + n1 = 0_I4P + do nz=1,size(varX,dim=3) ; do ny=1,size(varX,dim=2) ; do nx=1,size(varX,dim=1) + n1 = n1 + 1_I4P ; var(1+(n1-1)*3:1+(n1-1)*3+2)=[varX(nx,ny,nz),varY(nx,ny,nz),varZ(nx,ny,nz)] + enddo ; enddo ; enddo + call pack_data(a1=[int(3*NC_NN*BYR4P,I4P)],a2=var,packed=varp) ; deallocate(var) + call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec endselect return !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_VECT_I4 + endfunction VTK_VAR_XML_VECT_3DA_R4 - !> Function for saving field of vectorial variable (I2P). + !> Function for saving field of vectorial variable (I8P, 1D arrays). !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_VECT_I2(cf,NC_NN,varname,varX,varY,varZ) result(E_IO) + function VTK_VAR_XML_VECT_1DA_I8(NC_NN,varname,varX,varY,varZ,cf) 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. + integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. + character(*), intent(IN):: varname !< Variable name. + integer(I8P), intent(IN):: varX(1:) !< X component [1:NC_NN]. + integer(I8P), intent(IN):: varY(1:) !< Y component [1:NC_NN]. + integer(I8P), intent(IN):: varZ(1:) !< Z component [1:NC_NN]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + character(len=maxlen):: s_buffer !< Buffer string. + integer(I8P), allocatable:: var(:) !< X, Y, Z component. + integer(I1P), allocatable:: varp(:) !< Packed data. + character(1), allocatable:: var64(:) !< Variable encoded in base64. + integer(I4P):: rf !< Real file index. + integer(I4P):: n1 !< Counter. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - if (present(cf)) f = cf - select case(vtk(f)%f) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) case(ascii) - s_buffer = repeat(' ',vtk(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)//'' + write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) + do n1=1,NC_NN + write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//str(n=varX(n1))//' '//str(n=varY(n1))//' '//str(n=varZ(n1)) + enddo + write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = int(3*NC_NN*BYI8P,I4P)) + write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I8',3*NC_NN + write(vtk(rf)%ua,iostat=E_IO)(varX(n1),varY(n1),varZ(n1),n1=1,NC_NN) case(binary) - s_buffer = repeat(' ',vtk(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) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + allocate(var(1:3*NC_NN)) + do n1=1,NC_NN + var(1+(n1-1)*3:1+(n1-1)*3+2)=[varX(n1),varY(n1),varZ(n1)] + enddo + call pack_data(a1=[int(3*NC_NN*BYI8P,I4P)],a2=var,packed=varp) ; deallocate(var) + call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec endselect return !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_VECT_I2 + endfunction VTK_VAR_XML_VECT_1DA_I8 - !> Function for saving field of vectorial variable (I1P). + !> Function for saving field of vectorial variable (I8P, 3D arrays). !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_VECT_I1(cf,NC_NN,varname,varX,varY,varZ) result(E_IO) + function VTK_VAR_XML_VECT_3DA_I8(NC_NN,varname,varX,varY,varZ,cf) 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. + integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. + character(*), intent(IN):: varname !< Variable name. + integer(I8P), intent(IN):: varX(1:,1:,1:) !< X component [1:Nx,1:Ny,1:Nz]. + integer(I8P), intent(IN):: varY(1:,1:,1:) !< Y component [1:Nx,1:Ny,1:Nz]. + integer(I8P), intent(IN):: varZ(1:,1:,1:) !< Z component [1:Nx,1:Ny,1:Nz]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + character(len=maxlen):: s_buffer !< Buffer string. + integer(I8P), allocatable:: var(:) !< X, Y, Z component. + integer(I1P), allocatable:: varp(:) !< Packed data. + character(1), allocatable:: var64(:) !< Variable encoded in base64. + integer(I4P):: rf !< Real file index. + integer(I4P):: nx,ny,nz,n1 !< Counters. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - if (present(cf)) f = cf - select case(vtk(f)%f) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) case(ascii) - s_buffer=repeat(' ',vtk(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)//'' + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) + do nz=1,size(varX,dim=3) ; do ny=1,size(varX,dim=2) ; do nx=1,size(varX,dim=1) + write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//& + str(n=varX(nx,ny,nz))//' '//str(n=varY(nx,ny,nz))//' '//str(n=varZ(nx,ny,nz)) + enddo ; enddo ; enddo + write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = int(3*NC_NN*BYI8P,I4P)) + write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I8',3*NC_NN + write(vtk(rf)%ua,iostat=E_IO)(((varX(nx,ny,nz),varY(nx,ny,nz),varZ(nx,ny,nz),& + nx=1,size(varX,dim=1)),ny=1,size(varX,dim=2)),nz=1,size(varX,dim=3)) case(binary) - s_buffer=repeat(' ',vtk(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) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + allocate(var(1:3*NC_NN)) + n1 = 0_I4P + do nz=1,size(varX,dim=3) ; do ny=1,size(varX,dim=2) ; do nx=1,size(varX,dim=1) + n1 = n1 + 1_I4P ; var(1+(n1-1)*3:1+(n1-1)*3+2)=[varX(nx,ny,nz),varY(nx,ny,nz),varZ(nx,ny,nz)] + enddo ; enddo ; enddo + call pack_data(a1=[int(3*NC_NN*BYI8P,I4P)],a2=var,packed=varp) ; deallocate(var) + call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec endselect return !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_VECT_I1 + endfunction VTK_VAR_XML_VECT_3DA_I8 - !> Function for saving field of list variable (R8P). + !> Function for saving field of vectorial variable (I4P, 1D arrays). !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_LIST_R8(cf,NC_NN,N_COL,varname,var) result(E_IO) + function VTK_VAR_XML_VECT_1DA_I4(NC_NN,varname,varX,varY,varZ,cf) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. + character(*), intent(IN):: varname !< Variable name. + integer(I4P), intent(IN):: varX(1:) !< X component [1:NC_NN]. + integer(I4P), intent(IN):: varY(1:) !< Y component [1:NC_NN]. + integer(I4P), intent(IN):: varZ(1:) !< Z component [1:NC_NN]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + character(len=maxlen):: s_buffer !< Buffer string. + integer(I4P), allocatable:: var(:) !< X, Y, Z component. + integer(I1P), allocatable:: varp(:) !< Packed data. + character(1), allocatable:: var64(:) !< Variable encoded in base64. + integer(I4P):: rf !< Real file index. + integer(I4P):: n1 !< Counter. + integer(I8P):: Nvarp !< Dimension of varp, packed data. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) + case(ascii) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) + do n1=1,NC_NN + write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//str(n=varX(n1))//' '//str(n=varY(n1))//' '//str(n=varZ(n1)) + enddo + write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = 3*NC_NN*BYI4P) + write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I4',3*NC_NN + write(vtk(rf)%ua,iostat=E_IO)(varX(n1),varY(n1),varZ(n1),n1=1,NC_NN) + case(binary) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + allocate(var(1:3*NC_NN)) + do n1=1,NC_NN + var(1+(n1-1)*3:1+(n1-1)*3+2)=[varX(n1),varY(n1),varZ(n1)] + enddo + Nvarp=size(transfer([int(3*NC_NN*BYI4P,I4P),var],varp)) ; if (allocated(varp)) deallocate(varp); allocate(varp(1:Nvarp)) + varp = transfer([int(3*NC_NN*BYI4P,I4P),var],varp) ; deallocate(var) + call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_VAR_XML_VECT_1DA_I4 + + !> Function for saving field of vectorial variable (I4P, 3D arrays). + !> @return E_IO: integer(I4P) error flag + function VTK_VAR_XML_VECT_3DA_I4(NC_NN,varname,varX,varY,varZ,cf) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. + character(*), intent(IN):: varname !< Variable name. + integer(I4P), intent(IN):: varX(1:,1:,1:) !< X component [1:Nx,1:Ny,1:Nz]. + integer(I4P), intent(IN):: varY(1:,1:,1:) !< Y component [1:Nx,1:Ny,1:Nz]. + integer(I4P), intent(IN):: varZ(1:,1:,1:) !< Z component [1:Nx,1:Ny,1:Nz]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + character(len=maxlen):: s_buffer !< Buffer string. + integer(I4P), allocatable:: var(:) !< X, Y, Z component. + integer(I1P), allocatable:: varp(:) !< Packed data. + character(1), allocatable:: var64(:) !< Variable encoded in base64. + integer(I4P):: rf !< Real file index. + integer(I4P):: nx,ny,nz,n1 !< Counters. + integer(I8P):: Nvarp !< Dimension of varp, packed data. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) + case(ascii) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) + do nz=1,size(varX,dim=3) ; do ny=1,size(varX,dim=2) ; do nx=1,size(varX,dim=1) + write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//& + str(n=varX(nx,ny,nz))//' '//str(n=varY(nx,ny,nz))//' '//str(n=varZ(nx,ny,nz)) + enddo ; enddo ; enddo + write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = 3*NC_NN*BYI4P) + write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I4',3*NC_NN + write(vtk(rf)%ua,iostat=E_IO)(((varX(nx,ny,nz),varY(nx,ny,nz),varZ(nx,ny,nz),& + nx=1,size(varX,dim=1)),ny=1,size(varX,dim=2)),nz=1,size(varX,dim=3)) + case(binary) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + allocate(var(1:3*NC_NN)) + n1 = 0_I4P + do nz=1,size(varX,dim=3) ; do ny=1,size(varX,dim=2) ; do nx=1,size(varX,dim=1) + n1 = n1 + 1_I4P ; var(1+(n1-1)*3:1+(n1-1)*3+2)=[varX(nx,ny,nz),varY(nx,ny,nz),varZ(nx,ny,nz)] + enddo ; enddo ; enddo + Nvarp=size(transfer([int(3*NC_NN*BYI4P,I4P),var],varp)) ; if (allocated(varp)) deallocate(varp); allocate(varp(1:Nvarp)) + varp = transfer([int(3*NC_NN*BYI4P,I4P),var],varp) ; deallocate(var) + call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_VAR_XML_VECT_3DA_I4 + + !> Function for saving field of vectorial variable (I2P, 1D arrays). + !> @return E_IO: integer(I4P) error flag + function VTK_VAR_XML_VECT_1DA_I2(NC_NN,varname,varX,varY,varZ,cf) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. + character(*), intent(IN):: varname !< Variable name. + integer(I2P), intent(IN):: varX(1:) !< X component [1:NC_NN]. + integer(I2P), intent(IN):: varY(1:) !< Y component [1:NC_NN]. + integer(I2P), intent(IN):: varZ(1:) !< Z component [1:NC_NN]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + character(len=maxlen):: s_buffer !< Buffer string. + integer(I2P), allocatable:: var(:) !< X, Y, Z component. + integer(I1P), allocatable:: varp(:) !< Packed data. + character(1), allocatable:: var64(:) !< Variable encoded in base64. + integer(I4P):: rf !< Real file index. + integer(I4P):: n1 !< Counter. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) + case(ascii) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) + do n1=1,NC_NN + write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//str(n=varX(n1))//' '//str(n=varY(n1))//' '//str(n=varZ(n1)) + enddo + write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = 3*NC_NN*BYI2P) + write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I2',3*NC_NN + write(vtk(rf)%ua,iostat=E_IO)(varX(n1),varY(n1),varZ(n1),n1=1,NC_NN) + case(binary) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + allocate(var(1:3*NC_NN)) + do n1=1,NC_NN + var(1+(n1-1)*3:1+(n1-1)*3+2)=[varX(n1),varY(n1),varZ(n1)] + enddo + call pack_data(a1=[int(3*NC_NN*BYI2P,I4P)],a2=var,packed=varp) ; deallocate(var) + call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_VAR_XML_VECT_1DA_I2 + + !> Function for saving field of vectorial variable (I2P, 3D arrays). + !> @return E_IO: integer(I4P) error flag + function VTK_VAR_XML_VECT_3DA_I2(NC_NN,varname,varX,varY,varZ,cf) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. + character(*), intent(IN):: varname !< Variable name. + integer(I2P), intent(IN):: varX(1:,1:,1:) !< X component [1:Nx,1:Ny,1:Nz]. + integer(I2P), intent(IN):: varY(1:,1:,1:) !< Y component [1:Nx,1:Ny,1:Nz]. + integer(I2P), intent(IN):: varZ(1:,1:,1:) !< Z component [1:Nx,1:Ny,1:Nz]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + character(len=maxlen):: s_buffer !< Buffer string. + integer(I2P), allocatable:: var(:) !< X, Y, Z component. + integer(I1P), allocatable:: varp(:) !< Packed data. + character(1), allocatable:: var64(:) !< Variable encoded in base64. + integer(I4P):: rf !< Real file index. + integer(I4P):: nx,ny,nz,n1 !< Counters. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) + case(ascii) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) + do nz=1,size(varX,dim=3) ; do ny=1,size(varX,dim=2) ; do nx=1,size(varX,dim=1) + write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//& + str(n=varX(nx,ny,nz))//' '//str(n=varY(nx,ny,nz))//' '//str(n=varZ(nx,ny,nz)) + enddo ; enddo ; enddo + write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = 3*NC_NN*BYI2P) + write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I2',3*NC_NN + write(vtk(rf)%ua,iostat=E_IO)(((varX(nx,ny,nz),varY(nx,ny,nz),varZ(nx,ny,nz),& + nx=1,size(varX,dim=1)),ny=1,size(varX,dim=2)),nz=1,size(varX,dim=3)) + case(binary) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + allocate(var(1:3*NC_NN)) + n1 = 0_I4P + do nz=1,size(varX,dim=3) ; do ny=1,size(varX,dim=2) ; do nx=1,size(varX,dim=1) + n1 = n1 + 1_I4P ; var(1+(n1-1)*3:1+(n1-1)*3+2)=[varX(nx,ny,nz),varY(nx,ny,nz),varZ(nx,ny,nz)] + enddo ; enddo ; enddo + call pack_data(a1=[int(3*NC_NN*BYI2P,I4P)],a2=var,packed=varp) ; deallocate(var) + call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_VAR_XML_VECT_3DA_I2 + + !> Function for saving field of vectorial variable (I1P, 1D arrays). + !> @return E_IO: integer(I4P) error flag + function VTK_VAR_XML_VECT_1DA_I1(NC_NN,varname,varX,varY,varZ,cf) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. + character(*), intent(IN):: varname !< Variable name. + integer(I1P), intent(IN):: varX(1:) !< X component [1:NC_NN]. + integer(I1P), intent(IN):: varY(1:) !< Y component [1:NC_NN]. + integer(I1P), intent(IN):: varZ(1:) !< Z component [1:NC_NN]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + character(len=maxlen):: s_buffer !< Buffer string. + integer(I1P), allocatable:: var(:) !< X, Y, Z component. + integer(I1P), allocatable:: varp(:) !< Packed data. + character(1), allocatable:: var64(:) !< Variable encoded in base64. + integer(I4P):: rf !< Real file index. + integer(I4P):: n1 !< Counter. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) + case(ascii) + s_buffer=repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) + do n1=1,NC_NN + write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//str(n=varX(n1))//' '//str(n=varY(n1))//' '//str(n=varZ(n1)) + enddo + write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,bin_app) + s_buffer=repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + vtk(rf)%N_Byte = 3*NC_NN*BYI1P + call vtk(rf)%byte_update(N_Byte = 3*NC_NN*BYI1P) + write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I1',3*NC_NN + write(vtk(rf)%ua,iostat=E_IO)(varX(n1),varY(n1),varZ(n1),n1=1,NC_NN) + case(binary) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + allocate(var(1:3*NC_NN)) + do n1=1,NC_NN + var(1+(n1-1)*3:1+(n1-1)*3+2)=[varX(n1),varY(n1),varZ(n1)] + enddo + call pack_data(a1=[int(3*NC_NN*BYI1P,I4P)],a2=var,packed=varp) ; deallocate(var) + call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_VAR_XML_VECT_1DA_I1 + + !> Function for saving field of vectorial variable (I1P, 3D arrays). + !> @return E_IO: integer(I4P) error flag + function VTK_VAR_XML_VECT_3DA_I1(NC_NN,varname,varX,varY,varZ,cf) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. + character(*), intent(IN):: varname !< Variable name. + integer(I1P), intent(IN):: varX(1:,1:,1:) !< X component [1:Nx,1:Ny,1:Nz]. + integer(I1P), intent(IN):: varY(1:,1:,1:) !< Y component [1:Nx,1:Ny,1:Nz]. + integer(I1P), intent(IN):: varZ(1:,1:,1:) !< Z component [1:Nx,1:Ny,1:Nz]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + character(len=maxlen):: s_buffer !< Buffer string. + integer(I1P), allocatable:: var(:) !< X, Y, Z component. + integer(I1P), allocatable:: varp(:) !< Packed data. + character(1), allocatable:: var64(:) !< Variable encoded in base64. + integer(I4P):: rf !< Real file index. + integer(I4P):: nx,ny,nz,n1 !< Counters. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) + case(ascii) + s_buffer=repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) + do nz=1,size(varX,dim=3) ; do ny=1,size(varX,dim=2) ; do nx=1,size(varX,dim=1) + write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//& + str(n=varX(nx,ny,nz))//' '//str(n=varY(nx,ny,nz))//' '//str(n=varZ(nx,ny,nz)) + enddo ; enddo ; enddo + write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,bin_app) + s_buffer=repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + vtk(rf)%N_Byte = 3*NC_NN*BYI1P + call vtk(rf)%byte_update(N_Byte = 3*NC_NN*BYI1P) + write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I1',3*NC_NN + write(vtk(rf)%ua,iostat=E_IO)(((varX(nx,ny,nz),varY(nx,ny,nz),varZ(nx,ny,nz),& + nx=1,size(varX,dim=1)),ny=1,size(varX,dim=2)),nz=1,size(varX,dim=3)) + case(binary) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + allocate(var(1:3*NC_NN)) + n1 = 0_I4P + do nz=1,size(varX,dim=3) ; do ny=1,size(varX,dim=2) ; do nx=1,size(varX,dim=1) + n1 = n1 + 1_I4P ; var(1+(n1-1)*3:1+(n1-1)*3+2)=[varX(nx,ny,nz),varY(nx,ny,nz),varZ(nx,ny,nz)] + enddo ; enddo ; enddo + call pack_data(a1=[int(3*NC_NN*BYI1P,I4P)],a2=var,packed=varp) ; deallocate(var) + call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_VAR_XML_VECT_3DA_I1 + + !> Function for saving field of list variable (R8P, 1D array). + !> @return E_IO: integer(I4P) error flag + function VTK_VAR_XML_LIST_1DA_R8(NC_NN,N_COL,varname,var,cf) result(E_IO) !--------------------------------------------------------------------------------------------------------------------------------- implicit none - integer(I4P), intent(IN), 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. + real(R8P), intent(IN):: var(1:,1:) !< Components [1:N_COL,1:NC_NN]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. character(len=maxlen):: s_buffer !< Buffer string. + integer(I1P), allocatable:: varp(:) !< Packed data. + character(1), allocatable:: var64(:) !< Variable encoded in base64. + integer(I4P):: rf !< Real file index. integer(I4P):: n1,n2 !< Counters. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - if (present(cf)) f = cf - select case(vtk(f)%f) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) case(ascii) - s_buffer = repeat(' ',vtk(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) + write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) + do n2=1,NC_NN + write(vtk(rf)%u,'('//trim(str(.true.,N_COL+1))//'A)',iostat=E_IO)repeat(' ',vtk(rf)%indent),& + (' '//str(n=var(n1,n2)),n1=1,N_COL) enddo - write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = N_COL*NC_NN*BYR8P) + write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R8',N_COL*NC_NN + write(vtk(rf)%ua,iostat=E_IO)var case(binary) - s_buffer = repeat(' ',vtk(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 + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call pack_data(a1=[int(N_COL*NC_NN*BYR8P,I4P)],a2=reshape(var,[N_COL*NC_NN]),packed=varp) + call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec endselect return !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_LIST_R8 + endfunction VTK_VAR_XML_LIST_1DA_R8 - !> Function for saving field of list variable (R4P). + !> Function for saving field of list variable (R8P, 3D array). !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_LIST_R4(cf,NC_NN,N_COL,varname,var) result(E_IO) + function VTK_VAR_XML_LIST_3DA_R8(NC_NN,N_COL,varname,var,cf) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. + integer(I4P), intent(IN):: N_COL !< Number of columns. + character(*), intent(IN):: varname !< Variable name. + real(R8P), intent(IN):: var(1:,1:,1:,1:) !< Components [1:N_COL,1:Nx,1:Ny,1:Nz]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + character(len=maxlen):: s_buffer !< Buffer string. + integer(I1P), allocatable:: varp(:) !< Packed data. + character(1), allocatable:: var64(:) !< Variable encoded in base64. + integer(I4P):: rf !< Real file index. + integer(I4P):: nx,ny,nz,n1 !< Counters. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) + case(ascii) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) + do nz=1,size(var,dim=4) ; do ny=1,size(var,dim=3) ; do nx=1,size(var,dim=2) + write(vtk(rf)%u,'('//trim(str(.true.,N_COL+1))//'A)',iostat=E_IO)repeat(' ',vtk(rf)%indent),& + (' '//str(n=var(n1,nx,ny,nz)),n1=1,N_COL) + enddo ; enddo ; enddo + write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = N_COL*NC_NN*BYR8P) + write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R8',N_COL*NC_NN + write(vtk(rf)%ua,iostat=E_IO)var + case(binary) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call pack_data(a1=[int(N_COL*NC_NN*BYR8P,I4P)],a2=reshape(var,[N_COL*NC_NN]),packed=varp) + call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_VAR_XML_LIST_3DA_R8 + + !> Function for saving field of list variable (R4P, 1D array). + !> @return E_IO: integer(I4P) error flag + function VTK_VAR_XML_LIST_1DA_R4(NC_NN,N_COL,varname,var,cf) result(E_IO) !--------------------------------------------------------------------------------------------------------------------------------- implicit none - integer(I4P), intent(IN), 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. + real(R4P), intent(IN):: var(1:,1:) !< Components [1:N_COL,1:NC_NN]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. character(len=maxlen):: s_buffer !< Buffer string. + integer(I1P), allocatable:: varp(:) !< Packed data. + character(1), allocatable:: var64(:) !< Variable encoded in base64. + integer(I4P):: rf !< Real file index. integer(I4P):: n1,n2 !< Counters. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - if (present(cf)) f = cf - select case(vtk(f)%f) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) case(ascii) - s_buffer = repeat(' ',vtk(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) + write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) + do n2=1,NC_NN + write(vtk(rf)%u,'('//trim(str(.true.,N_COL+1))//'A)',iostat=E_IO)repeat(' ',vtk(rf)%indent),& + (' '//str(n=var(n1,n2)),n1=1,N_COL) enddo - write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = N_COL*NC_NN*BYR4P) + write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R4',N_COL*NC_NN + write(vtk(rf)%ua,iostat=E_IO)var case(binary) - s_buffer = repeat(' ',vtk(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 + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call pack_data(a1=[int(N_COL*NC_NN*BYR4P,I4P)],a2=reshape(var,[N_COL*NC_NN]),packed=varp) + call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec endselect return !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_LIST_R4 + endfunction VTK_VAR_XML_LIST_1DA_R4 - !> Function for saving field of list variable (I8P). + !> Function for saving field of list variable (R4P, 3D array). !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_LIST_I8(cf,NC_NN,N_COL,varname,var) result(E_IO) + function VTK_VAR_XML_LIST_3DA_R4(NC_NN,N_COL,varname,var,cf) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. + integer(I4P), intent(IN):: N_COL !< Number of columns. + character(*), intent(IN):: varname !< Variable name. + real(R4P), intent(IN):: var(1:,1:,1:,1:) !< Components [1:N_COL,1:Nx,1:Ny,1:Nz]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + character(len=maxlen):: s_buffer !< Buffer string. + integer(I1P), allocatable:: varp(:) !< Packed data. + character(1), allocatable:: var64(:) !< Variable encoded in base64. + integer(I4P):: rf !< Real file index. + integer(I4P):: nx,ny,nz,n1 !< Counters. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) + case(ascii) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) + do nz=1,size(var,dim=4) ; do ny=1,size(var,dim=3) ; do nx=1,size(var,dim=2) + write(vtk(rf)%u,'('//trim(str(.true.,N_COL+1))//'A)',iostat=E_IO)repeat(' ',vtk(rf)%indent),& + (' '//str(n=var(n1,nx,ny,nz)),n1=1,N_COL) + enddo ; enddo ; enddo + write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = N_COL*NC_NN*BYR4P) + write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'R4',N_COL*NC_NN + write(vtk(rf)%ua,iostat=E_IO)var + case(binary) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call pack_data(a1=[int(N_COL*NC_NN*BYR4P,I4P)],a2=reshape(var,[N_COL*NC_NN]),packed=varp) + call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_VAR_XML_LIST_3DA_R4 + + !> Function for saving field of list variable (I8P, 1D array). + !> @return E_IO: integer(I4P) error flag + function VTK_VAR_XML_LIST_1DA_I8(NC_NN,N_COL,varname,var,cf) result(E_IO) !--------------------------------------------------------------------------------------------------------------------------------- implicit none - integer(I4P), intent(IN), 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(I8P), intent(IN):: var(1:,1:) !< Components [1:N_COL,1:NC_NN]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. character(len=maxlen):: s_buffer !< Buffer string. + integer(I1P), allocatable:: varp(:) !< Packed data. + character(1), allocatable:: var64(:) !< Variable encoded in base64. + integer(I4P):: rf !< Real file index. integer(I4P):: n1,n2 !< Counters. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - if (present(cf)) f = cf - select case(vtk(f)%f) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) case(ascii) - s_buffer = repeat(' ',vtk(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) + write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) + do n2=1,NC_NN + write(vtk(rf)%u,'('//trim(str(.true.,N_COL+1))//'A)',iostat=E_IO)repeat(' ',vtk(rf)%indent),& + (' '//str(n=var(n1,n2)),n1=1,N_COL) enddo - write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = int(N_COL*NC_NN*BYI8P,I4P)) + write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I8',N_COL*NC_NN + write(vtk(rf)%ua,iostat=E_IO)var case(binary) - s_buffer = repeat(' ',vtk(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 + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call pack_data(a1=[int(N_COL*NC_NN*BYI8P,I4P)],a2=reshape(var,[N_COL*NC_NN]),packed=varp) + call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec endselect return !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_LIST_I8 + endfunction VTK_VAR_XML_LIST_1DA_I8 - !> Function for saving field of list variable (I4P). + !> Function for saving field of list variable (I8P, 3D array). !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_LIST_I4(cf,NC_NN,N_COL,varname,var) result(E_IO) + function VTK_VAR_XML_LIST_3DA_I8(NC_NN,N_COL,varname,var,cf) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. + integer(I4P), intent(IN):: N_COL !< Number of columns. + character(*), intent(IN):: varname !< Variable name. + integer(I8P), intent(IN):: var(1:,1:,1:,1:) !< Components [1:N_COL,1:Nx,1:Ny,1:Nz]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + character(len=maxlen):: s_buffer !< Buffer string. + integer(I1P), allocatable:: varp(:) !< Packed data. + character(1), allocatable:: var64(:) !< Variable encoded in base64. + integer(I4P):: rf !< Real file index. + integer(I4P):: nx,ny,nz,n1 !< Counters. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) + case(ascii) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) + do nz=1,size(var,dim=4) ; do ny=1,size(var,dim=3) ; do nx=1,size(var,dim=2) + write(vtk(rf)%u,'('//trim(str(.true.,N_COL+1))//'A)',iostat=E_IO)repeat(' ',vtk(rf)%indent),& + (' '//str(n=var(n1,nx,ny,nz)),n1=1,N_COL) + enddo ; enddo ; enddo + write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = int(N_COL*NC_NN*BYI8P,I4P)) + write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I8',N_COL*NC_NN + write(vtk(rf)%ua,iostat=E_IO)var + case(binary) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call pack_data(a1=[int(N_COL*NC_NN*BYI8P,I4P)],a2=reshape(var,[N_COL*NC_NN]),packed=varp) + call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_VAR_XML_LIST_3DA_I8 + + !> Function for saving field of list variable (I4P, 1D array). + !> @return E_IO: integer(I4P) error flag + function VTK_VAR_XML_LIST_1DA_I4(NC_NN,N_COL,varname,var,cf) result(E_IO) !--------------------------------------------------------------------------------------------------------------------------------- implicit none - integer(I4P), intent(IN), 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), intent(IN):: var(1:,1:) !< Components [1:N_COL,1:NC_NN]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. character(len=maxlen):: s_buffer !< Buffer string. + integer(I1P), allocatable:: varp(:) !< Packed data. + character(1), allocatable:: var64(:) !< Variable encoded in base64. + integer(I4P):: rf !< Real file index. + integer(I4P):: n1,n2 !< Counters. + integer(I8P):: Nvarp !< Dimension of varp, packed data. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) + case(ascii) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) + do n2=1,NC_NN + write(vtk(rf)%u,'('//trim(str(.true.,N_COL+1))//'A)',iostat=E_IO)repeat(' ',vtk(rf)%indent),& + (' '//str(n=var(n1,n2)),n1=1,N_COL) + enddo + write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = N_COL*NC_NN*BYI4P) + write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I4',N_COL*NC_NN + write(vtk(rf)%ua,iostat=E_IO)var + case(binary) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + Nvarp=size(transfer([int(N_COL*NC_NN*BYI4P,I4P),reshape(var,[N_COL*NC_NN])],varp)) + if (allocated(varp)) deallocate(varp); allocate(varp(1:Nvarp)) + varp = transfer([int(N_COL*NC_NN*BYI4P,I4P),reshape(var,[N_COL*NC_NN])],varp) + call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_VAR_XML_LIST_1DA_I4 + + !> Function for saving field of list variable (I4P, 3D array). + !> @return E_IO: integer(I4P) error flag + function VTK_VAR_XML_LIST_3DA_I4(NC_NN,N_COL,varname,var,cf) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. + integer(I4P), intent(IN):: N_COL !< Number of columns. + character(*), intent(IN):: varname !< Variable name. + integer(I4P), intent(IN):: var(1:,1:,1:,1:) !< Components [1:N_COL,1:Nx,1:Ny,1:Nz]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + character(len=maxlen):: s_buffer !< Buffer string. + integer(I1P), allocatable:: varp(:) !< Packed data. + character(1), allocatable:: var64(:) !< Variable encoded in base64. + integer(I4P):: rf !< Real file index. + integer(I4P):: nx,ny,nz,n1 !< Counters. + integer(I8P):: Nvarp !< Dimension of varp, packed data. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) + case(ascii) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) + do nz=1,size(var,dim=4) ; do ny=1,size(var,dim=3) ; do nx=1,size(var,dim=2) + write(vtk(rf)%u,'('//trim(str(.true.,N_COL+1))//'A)',iostat=E_IO)repeat(' ',vtk(rf)%indent),& + (' '//str(n=var(n1,nx,ny,nz)),n1=1,N_COL) + enddo ; enddo ; enddo + write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = N_COL*NC_NN*BYI4P) + write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I4',N_COL*NC_NN + write(vtk(rf)%ua,iostat=E_IO)var + case(binary) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + Nvarp=size(transfer([int(N_COL*NC_NN*BYI4P,I4P),reshape(var,[N_COL*NC_NN])],varp)) + if (allocated(varp)) deallocate(varp); allocate(varp(1:Nvarp)) + varp = transfer([int(N_COL*NC_NN*BYI4P,I4P),reshape(var,[N_COL*NC_NN])],varp) + call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_VAR_XML_LIST_3DA_I4 + + !> Function for saving field of list variable (I2P, 1D array). + !> @return E_IO: integer(I4P) error flag + function VTK_VAR_XML_LIST_1DA_I2(NC_NN,N_COL,varname,var,cf) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. + integer(I4P), intent(IN):: N_COL !< Number of columns. + character(*), intent(IN):: varname !< Variable name. + integer(I2P), intent(IN):: var(1:,1:) !< Components [1:N_COL,1:NC_NN]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + character(len=maxlen):: s_buffer !< Buffer string. + integer(I1P), allocatable:: varp(:) !< Packed data. + character(1), allocatable:: var64(:) !< Variable encoded in base64. + integer(I4P):: rf !< Real file index. integer(I4P):: n1,n2 !< Counters. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - if (present(cf)) f = cf - select case(vtk(f)%f) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) case(ascii) - s_buffer = repeat(' ',vtk(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) + write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) + do n2=1,NC_NN + write(vtk(rf)%u,'('//trim(str(.true.,N_COL+1))//'A)',iostat=E_IO)repeat(' ',vtk(rf)%indent),& + (' '//str(n=var(n1,n2)),n1=1,N_COL) enddo - write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = N_COL*NC_NN*BYI2P) + write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I2',N_COL*NC_NN + write(vtk(rf)%ua,iostat=E_IO)var case(binary) - s_buffer = repeat(' ',vtk(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 + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call pack_data(a1=[int(N_COL*NC_NN*BYI2P,I4P)],a2=reshape(var,[N_COL*NC_NN]),packed=varp) + call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec endselect return !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_LIST_I4 + endfunction VTK_VAR_XML_LIST_1DA_I2 - !> Function for saving field of list variable (I2P). + !> Function for saving field of list variable (I2P, 3D array). !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_LIST_I2(cf,NC_NN,N_COL,varname,var) result(E_IO) + function VTK_VAR_XML_LIST_3DA_I2(NC_NN,N_COL,varname,var,cf) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. + integer(I4P), intent(IN):: N_COL !< Number of columns. + character(*), intent(IN):: varname !< Variable name. + integer(I2P), intent(IN):: var(1:,1:,1:,1:) !< Components [1:N_COL,1:Nx,1:Ny,1:Nz]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + character(len=maxlen):: s_buffer !< Buffer string. + integer(I1P), allocatable:: varp(:) !< Packed data. + character(1), allocatable:: var64(:) !< Variable encoded in base64. + integer(I4P):: rf !< Real file index. + integer(I4P):: nx,ny,nz,n1 !< Counters. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) + case(ascii) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) + do nz=1,size(var,dim=4) ; do ny=1,size(var,dim=3) ; do nx=1,size(var,dim=2) + write(vtk(rf)%u,'('//trim(str(.true.,N_COL+1))//'A)',iostat=E_IO)repeat(' ',vtk(rf)%indent),& + (' '//str(n=var(n1,nx,ny,nz)),n1=1,N_COL) + enddo ; enddo ; enddo + write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = N_COL*NC_NN*BYI2P) + write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I2',N_COL*NC_NN + write(vtk(rf)%ua,iostat=E_IO)var + case(binary) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call pack_data(a1=[int(N_COL*NC_NN*BYI2P,I4P)],a2=reshape(var,[N_COL*NC_NN]),packed=varp) + call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_VAR_XML_LIST_3DA_I2 + + !> Function for saving field of list variable (I1P, 1D array). + !> @return E_IO: integer(I4P) error flag + function VTK_VAR_XML_LIST_1DA_I1(NC_NN,N_COL,varname,var,cf) result(E_IO) !--------------------------------------------------------------------------------------------------------------------------------- implicit none - integer(I4P), intent(IN), 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(I1P), intent(IN):: var(1:,1:) !< Components [1:N_COL,1:NC_NN]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. character(len=maxlen):: s_buffer !< Buffer string. + integer(I1P), allocatable:: varp(:) !< Packed data. + character(1), allocatable:: var64(:) !< Variable encoded in base64. + integer(I4P):: rf !< Real file index. integer(I4P):: n1,n2 !< Counters. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - if (present(cf)) f = cf - select case(vtk(f)%f) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) case(ascii) - s_buffer = repeat(' ',vtk(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) + write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) + do n2=1,NC_NN + write(vtk(rf)%u,'('//trim(str(.true.,N_COL+1))//'A)',iostat=E_IO)repeat(' ',vtk(rf)%indent),& + (' '//str(n=var(n1,n2)),n1=1,N_COL) enddo - write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' + write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = N_COL*NC_NN*BYI1P) + write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I1',N_COL*NC_NN + write(vtk(rf)%ua,iostat=E_IO)var case(binary) - s_buffer = repeat(' ',vtk(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 + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call pack_data(a1=[int(N_COL*NC_NN*BYI1P,I4P)],a2=reshape(var,[N_COL*NC_NN]),packed=varp) + call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec endselect return !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_LIST_I2 + endfunction VTK_VAR_XML_LIST_1DA_I1 - !> Function for saving field of list variable (I1P). + !> Function for saving field of list variable (I1P, 3D array). !> @return E_IO: integer(I4P) error flag - function VTK_VAR_XML_LIST_I1(cf,NC_NN,N_COL,varname,var) result(E_IO) + function VTK_VAR_XML_LIST_3DA_I1(NC_NN,N_COL,varname,var,cf) 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. + integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes. + integer(I4P), intent(IN):: N_COL !< Number of columns. + character(*), intent(IN):: varname !< Variable name. + integer(I1P), intent(IN):: var(1:,1:,1:,1:) !< Components [1:N_COL,1:Nx,1:Ny,1:Nz]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + character(len=maxlen):: s_buffer !< Buffer string. + integer(I1P), allocatable:: varp(:) !< Packed data. + character(1), allocatable:: var64(:) !< Variable encoded in base64. + integer(I4P):: rf !< Real file index. + integer(I4P):: nx,ny,nz,n1 !< Counters. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - if (present(cf)) f = cf - select case(vtk(f)%f) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) case(ascii) - s_buffer = repeat(' ',vtk(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)//'' + write(vtk(rf)%u,'(A)',iostat=E_IO)trim(s_buffer) + do nz=1,size(var,dim=4) ; do ny=1,size(var,dim=3) ; do nx=1,size(var,dim=2) + write(vtk(rf)%u,'('//trim(str(.true.,N_COL+1))//'A)',iostat=E_IO)repeat(' ',vtk(rf)%indent),& + (' '//str(n=var(n1,nx,ny,nz)),n1=1,N_COL) + enddo ; enddo ; enddo + write(vtk(rf)%u,'(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + case(raw,bin_app) + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call vtk(rf)%byte_update(N_Byte = N_COL*NC_NN*BYI1P) + write(vtk(rf)%ua,iostat=E_IO)vtk(rf)%N_Byte,'I1',N_COL*NC_NN + write(vtk(rf)%ua,iostat=E_IO)var case(binary) - s_buffer = repeat(' ',vtk(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 + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + call pack_data(a1=[int(N_COL*NC_NN*BYI1P,I4P)],a2=reshape(var,[N_COL*NC_NN]),packed=varp) + call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent+2)//tochar(var64)//end_rec ; deallocate(var64) + write(vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec endselect return !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_VAR_XML_LIST_I1 + endfunction VTK_VAR_XML_LIST_3DA_I1 !> @} !> @brief Function for finalizing the VTK-XML file. @@ -2073,6 +4441,10 @@ contains integer(I4P), allocatable:: v_I4(:) !< I4 vector for IO in AppendData. integer(I2P), allocatable:: v_I2(:) !< I2 vector for IO in AppendData. integer(I1P), allocatable:: v_I1(:) !< I1 vector for IO in AppendData. + integer(I1P), allocatable:: varp(:) !< Packed data. + character(1), allocatable:: var64(:) !< Variable encoded in base64. + integer(I4P):: rf !< Real file index. + integer(I8P):: Nvarp !< Dimension of varp, packed data. #ifdef HUGE integer(I8P):: N_v !< Vector dimension. integer(I8P):: n1 !< Counter. @@ -2083,68 +4455,118 @@ contains !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - if (present(cf)) f = cf - select case(vtk(f)%f) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%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) + vtk(rf)%indent = vtk(rf)%indent - 2 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)'' + case(raw,bin_app) + vtk(rf)%indent = vtk(rf)%indent - 2 + write(unit =vtk(rf)%u, iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + if (vtk(rf)%f==raw) then + write(unit =vtk(rf)%u, iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + else + write(unit =vtk(rf)%u, iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + endif + write(unit =vtk(rf)%u, iostat=E_IO)'_' + endfile(unit=vtk(rf)%ua,iostat=E_IO) + rewind(unit =vtk(rf)%ua,iostat=E_IO) do - read(unit=vtk(f)%ua,iostat=E_IO,end=100)vtk(f)%N_Byte,var_type,N_v + read(unit=vtk(rf)%ua,iostat=E_IO,end=100)vtk(rf)%N_Byte,var_type,N_v select case(var_type) case('R8') allocate(v_R8(1:N_v)) - read(unit =vtk(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) + read(unit =vtk(rf)%ua,iostat=E_IO)(v_R8(n1),n1=1,N_v) + if (vtk(rf)%f==raw) then + write(unit=vtk(rf)%u,iostat=E_IO)int(vtk(rf)%N_Byte,I4P),(v_R8(n1),n1=1,N_v) + else + call pack_data(a1=[int(vtk(rf)%N_Byte,I4P)],a2=v_R8,packed=varp) + call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) + write(unit=vtk(rf)%u,iostat=E_IO)tochar(var64) ; deallocate(var64) + endif deallocate(v_R8) case('R4') allocate(v_R4(1:N_v)) - read(unit =vtk(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) + read(unit =vtk(rf)%ua,iostat=E_IO)(v_R4(n1),n1=1,N_v) + if (vtk(rf)%f==raw) then + write(unit=vtk(rf)%u,iostat=E_IO)int(vtk(rf)%N_Byte,I4P),(v_R4(n1),n1=1,N_v) + else + call pack_data(a1=[int(vtk(rf)%N_Byte,I4P)],a2=v_R4,packed=varp) + call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) + write(unit=vtk(rf)%u,iostat=E_IO)tochar(var64) ; deallocate(var64) + endif deallocate(v_R4) case('I8') allocate(v_I8(1:N_v)) - read(unit =vtk(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) + read(unit =vtk(rf)%ua,iostat=E_IO)(v_I8(n1),n1=1,N_v) + if (vtk(rf)%f==raw) then + write(unit=vtk(rf)%u,iostat=E_IO)int(vtk(rf)%N_Byte,I4P),(v_I8(n1),n1=1,N_v) + else + call pack_data(a1=[int(vtk(rf)%N_Byte,I4P)],a2=v_I8,packed=varp) + call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) + write(unit=vtk(rf)%u,iostat=E_IO)tochar(var64) ; deallocate(var64) + endif deallocate(v_I8) case('I4') allocate(v_I4(1:N_v)) - read(unit =vtk(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) + read(unit =vtk(rf)%ua,iostat=E_IO)(v_I4(n1),n1=1,N_v) + if (vtk(rf)%f==raw) then + write(unit=vtk(rf)%u,iostat=E_IO)int(vtk(rf)%N_Byte,I4P),(v_I4(n1),n1=1,N_v) + else + Nvarp=size(transfer([int(vtk(rf)%N_Byte,I4P),v_I4],varp)) ; if (allocated(varp)) deallocate(varp); allocate(varp(1:Nvarp)) + varp = transfer([int(vtk(rf)%N_Byte,I4P),v_I4],varp) + call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) + write(unit=vtk(rf)%u,iostat=E_IO)tochar(var64) ; deallocate(var64) + endif deallocate(v_I4) case('I2') allocate(v_I2(1:N_v)) - read(unit =vtk(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) + read(unit =vtk(rf)%ua,iostat=E_IO)(v_I2(n1),n1=1,N_v) + if (vtk(rf)%f==raw) then + write(unit=vtk(rf)%u,iostat=E_IO)int(vtk(rf)%N_Byte,I4P),(v_I2(n1),n1=1,N_v) + else + call pack_data(a1=[int(vtk(rf)%N_Byte,I4P)],a2=v_I2,packed=varp) + call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) + write(unit=vtk(rf)%u,iostat=E_IO)tochar(var64) ; deallocate(var64) + endif deallocate(v_I2) case('I1') allocate(v_I1(1:N_v)) - read(unit =vtk(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) + read(unit =vtk(rf)%ua,iostat=E_IO)(v_I1(n1),n1=1,N_v) + if (vtk(rf)%f==raw) then + write(unit=vtk(rf)%u,iostat=E_IO)int(vtk(rf)%N_Byte,I4P),(v_I1(n1),n1=1,N_v) + else + call pack_data(a1=[int(vtk(rf)%N_Byte,I4P)],a2=v_I1,packed=varp) + call b64_encode(nB=int(BYI1P,I4P),n=varp,code=var64) ; deallocate(varp) + write(unit=vtk(rf)%u,iostat=E_IO)tochar(var64) ; deallocate(var64) + endif deallocate(v_I1) case default E_IO = 1 write (stderr,'(A)')' bad var_type = '//var_type - write (stderr,'(A)')' N_Byte = '//trim(str(n=vtk(f)%N_Byte))//' N_v = '//trim(str(n=N_v)) + write (stderr,'(A)')' N_Byte = '//trim(str(n=vtk(rf)%N_Byte))//' N_v = '//trim(str(n=N_v)) return endselect enddo 100 continue - write(unit=vtk(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) + write(unit=vtk(rf)%u,iostat=E_IO)end_rec + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + write(unit=vtk(rf)%u,iostat=E_IO)''//end_rec + close(unit=vtk(rf)%ua,iostat=E_IO) + case(binary) + vtk(rf)%indent = vtk(rf)%indent - 2 + write(unit=vtk(rf)%u,iostat=E_IO)repeat(' ',vtk(rf)%indent)//''//end_rec + write(unit=vtk(rf)%u,iostat=E_IO)''//end_rec endselect - close(unit=vtk(f)%u,iostat=E_IO) - call vtk_update(act='remove') - if (present(cf)) cf = f + close(unit=vtk(rf)%u,iostat=E_IO) + call vtk_update(act='remove',cf=rf,Nvtk=Nvtk,vtk=vtk) + f = rf + if (present(cf)) cf = rf return !--------------------------------------------------------------------------------------------------------------------------------- endfunction VTK_END_XML @@ -2161,6 +4583,7 @@ contains !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- + E_IO = -1_I4P if (.not.ir_initialized) call IR_Init if (endian==endianL) then s_buffer='' @@ -2187,6 +4610,7 @@ contains !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- + E_IO = -1_I4P select case(trim(Upper_Case(block_action))) case('OPEN') vtm%blk = vtm%blk + 1 @@ -2211,6 +4635,7 @@ contains !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- + E_IO = -1_I4P do f=1,size(flist) write(unit=vtm%u,fmt='(A)',iostat=E_IO)repeat(' ',vtm%indent)//'' @@ -2230,6 +4655,7 @@ contains !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- + E_IO = -1_I4P vtm%indent = vtm%indent - 2 write(unit=vtm%u,fmt='(A)',iostat=E_IO)repeat(' ',vtm%indent)//'' write(unit=vtm%u,fmt='(A)',iostat=E_IO)'' @@ -2241,9 +4667,12 @@ contains !> @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) + function PVTK_INI_XML(filename,mesh_topology,tp,cf,nx1,nx2,ny1,ny2,nz1,nz2) result(E_IO) !--------------------------------------------------------------------------------------------------------------------------------- implicit none + character(*), intent(IN):: filename !< File name. + character(*), intent(IN):: mesh_topology !< Mesh topology. + character(*), intent(IN):: tp !< Type of geometry representation (Float32, Float64, ecc). integer(I4P), intent(OUT), optional:: cf !< Current file index (for concurrent files IO). integer(I4P), intent(IN), optional:: nx1 !< Initial node of x axis. integer(I4P), intent(IN), optional:: nx2 !< Final node of x axis. @@ -2251,55 +4680,56 @@ contains 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. + integer(I4P):: rf !< Real file index. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- + E_IO = -1_I4P 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)'' + call vtk_update(act='add',cf=rf,Nvtk=Nvtk,vtk=vtk) + f = rf + if (present(cf)) cf = rf + vtk(rf)%topology = trim(mesh_topology) + open(unit=Get_Unit(vtk(rf)%u),file=trim(filename),& + form='FORMATTED',access='SEQUENTIAL',action='WRITE',status='REPLACE',iostat=E_IO) + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)'' if (endian==endianL) then - s_buffer = '' + s_buffer = '' else - s_buffer = '' + 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)) + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(rf)%indent = 2 + select case(trim(vtk(rf)%topology)) case('PRectilinearGrid') - s_buffer = repeat(' ',vtk(f)%indent)//'<'//trim(vtk(f)%topology)//' WholeExtent="'//& - trim(str(n=nx1))//' '//trim(str(n=nx2))//' '// & - trim(str(n=ny1))//' '//trim(str(n=ny2))//' '// & + s_buffer = repeat(' ',vtk(rf)%indent)//'<'//trim(vtk(rf)%topology)//' WholeExtent="'//& + trim(str(n=nx1))//' '//trim(str(n=nx2))//' '// & + trim(str(n=ny1))//' '//trim(str(n=ny2))//' '// & trim(str(n=nz1))//' '//trim(str(n=nz2))//'" GhostLevel="#">' - write(unit=vtk(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)//'' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(rf)%indent = vtk(rf)%indent + 2 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent + 2 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' case('PStructuredGrid') - s_buffer = repeat(' ',vtk(f)%indent)//'<'//trim(vtk(f)%topology)//' WholeExtent="'//& - trim(str(n=nx1))//' '//trim(str(n=nx2))//' '// & - trim(str(n=ny1))//' '//trim(str(n=ny2))//' '// & + s_buffer = repeat(' ',vtk(rf)%indent)//'<'//trim(vtk(rf)%topology)//' WholeExtent="'//& + trim(str(n=nx1))//' '//trim(str(n=nx2))//' '// & + trim(str(n=ny1))//' '//trim(str(n=ny2))//' '// & trim(str(n=nz1))//' '//trim(str(n=nz2))//'" GhostLevel="#">' - write(unit=vtk(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)//'' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(rf)%indent = vtk(rf)%indent + 2 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent + 2 + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' case('PUnstructuredGrid') - s_buffer = repeat(' ',vtk(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)//'' + s_buffer = repeat(' ',vtk(rf)%indent)//'<'//trim(vtk(rf)%topology)//' GhostLevel="0">' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) ; vtk(rf)%indent = vtk(rf)%indent + 2 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%indent + 2 + s_buffer = repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' endselect return !--------------------------------------------------------------------------------------------------------------------------------- @@ -2308,9 +4738,10 @@ contains !> 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) + function PVTK_GEO_XML(source,cf,nx1,nx2,ny1,ny2,nz1,nz2) result(E_IO) !--------------------------------------------------------------------------------------------------------------------------------- implicit none + character(*), intent(IN):: source !< Source file name containing the piece data. integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). integer(I4P), intent(IN), optional:: nx1 !< Initial node of x axis. integer(I4P), intent(IN), optional:: nx2 !< Final node of x axis. @@ -2318,22 +4749,26 @@ contains 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. + integer(I4P):: rf !< Real file index. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - if (present(cf)) f = cf - select case (vtk(f)%topology) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case (vtk(rf)%topology) case('PRectilinearGrid','PStructuredGrid') - s_buffer = repeat(' ',vtk(f)%indent)//'' - write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + write(unit=vtk(rf)%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)//'' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' endselect return !--------------------------------------------------------------------------------------------------------------------------------- @@ -2342,31 +4777,36 @@ contains !> 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) + function PVTK_DAT_XML(var_location,var_block_action,cf) 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), intent(IN), optional:: cf !< Current file index (for concurrent files IO). integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + integer(I4P):: rf !< Real file index. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - if (present(cf)) f = cf + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif select case(trim(Upper_Case(var_location))) case('CELL') select case(trim(Upper_Case(var_block_action))) case('OPEN') - write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' ; vtk(f)%indent = vtk(f)%indent + 2 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%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)//'' + vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' endselect case('NODE') select case(trim(Upper_Case(var_block_action))) case('OPEN') - write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(f)%indent)//'' ; vtk(f)%indent = vtk(f)%indent + 2 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' ; vtk(rf)%indent = vtk(rf)%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)//'' + vtk(rf)%indent = vtk(rf)%indent - 2 ; write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' endselect endselect return @@ -2376,26 +4816,31 @@ contains !> 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) + function PVTK_VAR_XML(varname,tp,cf,Nc) 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), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P), intent(IN), optional:: Nc !< Number of components of variable. integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. character(len=maxlen):: s_buffer !< Buffer string. + integer(I4P):: rf !< Real file index. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - if (present(cf)) f = cf + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif if (present(Nc)) then - s_buffer = repeat(' ',vtk(f)%indent)//'' else - s_buffer = repeat(' ',vtk(f)%indent)//'' + s_buffer = repeat(' ',vtk(rf)%indent)//'' endif - write(unit=vtk(f)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(s_buffer) return !--------------------------------------------------------------------------------------------------------------------------------- endfunction PVTK_VAR_XML @@ -2408,16 +4853,22 @@ contains implicit none integer(I4P), intent(INOUT), optional:: cf !< Current file index (for concurrent files IO). integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + integer(I4P):: rf !< Real file index. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - 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 + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + vtk(rf)%indent = vtk(rf)%indent - 2 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)repeat(' ',vtk(rf)%indent)//'' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)'' + close(unit=vtk(rf)%u,iostat=E_IO) + call vtk_update(act='remove',cf=rf,Nvtk=Nvtk,vtk=vtk) + f = rf + if (present(cf)) cf = rf return !--------------------------------------------------------------------------------------------------------------------------------- endfunction PVTK_END_XML @@ -2430,40 +4881,44 @@ contains !> ... @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) + function VTK_INI(output_format,filename,title,mesh_topology,cf) 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):: output_format !< Output format: ASCII or RAW. character(*), intent(IN):: filename !< Name of file. character(*), intent(IN):: title !< Title. character(*), intent(IN):: mesh_topology !< Mesh topology. + integer(I4P), intent(OUT), optional:: cf !< Current file index (for concurrent files IO). integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + integer(I4P):: rf !< Real file index. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- + E_IO = -1_I4P if (.not.ir_initialized) call IR_Init - call vtk_update(act='add') - if (present(cf)) cf = f - vtk(f)%topology = trim(mesh_topology) + call vtk_update(act='add',cf=rf,Nvtk=Nvtk,vtk=vtk) + f = rf + if (present(cf)) cf = rf + vtk(rf)%topology = trim(mesh_topology) select case(trim(Upper_Case(output_format))) case('ASCII') - vtk(f)%f = ascii - open(unit=Get_Unit(vtk(f)%u),file=trim(filename),form='FORMATTED',& + vtk(rf)%f = ascii + open(unit=Get_Unit(vtk(rf)%u),file=trim(filename),form='FORMATTED',& access='SEQUENTIAL',action='WRITE',status='REPLACE',iostat=E_IO) ! writing header of file - write(unit=vtk(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) + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)'# vtk DataFile Version 3.0' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(title) + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)trim(Upper_Case(output_format)) + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)'DATASET '//trim(vtk(rf)%topology) + case('RAW') + vtk(rf)%f = raw + open(unit=Get_Unit(vtk(rf)%u),file=trim(filename),& + form='UNFORMATTED',access='STREAM',action='WRITE',status='REPLACE',iostat=E_IO) ! writing header of file - write(unit=vtk(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 + write(unit=vtk(rf)%u,iostat=E_IO)'# vtk DataFile Version 3.0'//end_rec + write(unit=vtk(rf)%u,iostat=E_IO)trim(title)//end_rec + write(unit=vtk(rf)%u,iostat=E_IO)trim(Upper_Case(output_format))//end_rec + write(unit=vtk(rf)%u,iostat=E_IO)'DATASET '//trim(vtk(rf)%topology)//end_rec endselect return !--------------------------------------------------------------------------------------------------------------------------------- @@ -2473,35 +4928,38 @@ contains !> @{ !> 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) + function VTK_GEO_STRP_R8(Nx,Ny,Nz,X0,Y0,Z0,Dx,Dy,Dz,cf) result(E_IO) !--------------------------------------------------------------------------------------------------------------------------------- implicit none - integer(I4P), intent(IN):: Nx !< Number of nodes in x direction. - integer(I4P), intent(IN):: Ny !< Number of nodes in y direction. - integer(I4P), intent(IN):: Nz !< Number of nodes in z direction. - real(R8P), intent(IN):: X0 !< X coordinate of origin. - real(R8P), intent(IN):: Y0 !< Y coordinate of origin. - real(R8P), intent(IN):: Z0 !< Z coordinate of origin. - real(R8P), intent(IN):: Dx !< Space step in x direction. - real(R8P), intent(IN):: Dy !< Space step in y direction. - real(R8P), intent(IN):: Dz !< Space step in z direction. - integer(I4P):: 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), intent(IN):: Nx !< Number of nodes in x direction. + integer(I4P), intent(IN):: Ny !< Number of nodes in y direction. + integer(I4P), intent(IN):: Nz !< Number of nodes in z direction. + real(R8P), intent(IN):: X0 !< X coordinate of origin. + real(R8P), intent(IN):: Y0 !< Y coordinate of origin. + real(R8P), intent(IN):: Z0 !< Z coordinate of origin. + real(R8P), intent(IN):: Dx !< Space step in x direction. + real(R8P), intent(IN):: Dy !< Space step in y direction. + real(R8P), intent(IN):: Dz !< Space step in z direction. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + integer(I4P):: rf !< Real file index. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - select case(vtk(f)%f) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) case(ascii) - write(unit=vtk(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 + write(vtk(rf)%u,'(A)',iostat=E_IO)'DIMENSIONS '//trim(str(.true.,Nx))//' '//trim(str(.true.,Ny))//' '//trim(str(.true.,Nz)) + write(vtk(rf)%u,'(A)',iostat=E_IO)'ORIGIN '//trim(str(n=X0))//' '//trim(str(n=Y0))//' '//trim(str(n=Z0)) + write(vtk(rf)%u,'(A)',iostat=E_IO)'SPACING '//trim(str(n=Dx))//' '//trim(str(n=Dy))//' '//trim(str(n=Dz)) + case(raw) + write(vtk(rf)%u,iostat=E_IO)'DIMENSIONS '//trim(str(.true.,Nx))//' '//trim(str(.true.,Ny))//' '//trim(str(.true.,Nz))//end_rec + write(vtk(rf)%u,iostat=E_IO)'ORIGIN '//trim(str(n=X0))//' '//trim(str(n=Y0))//' '//trim(str(n=Z0))//end_rec + write(vtk(rf)%u,iostat=E_IO)'SPACING '//trim(str(n=Dx))//' '//trim(str(n=Dy))//' '//trim(str(n=Dz))//end_rec endselect return !--------------------------------------------------------------------------------------------------------------------------------- @@ -2509,151 +4967,428 @@ contains !> 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) + function VTK_GEO_STRP_R4(Nx,Ny,Nz,X0,Y0,Z0,Dx,Dy,Dz,cf) result(E_IO) !--------------------------------------------------------------------------------------------------------------------------------- implicit none - integer(I4P), intent(IN):: Nx !< Number of nodes in x direction. - integer(I4P), intent(IN):: Ny !< Number of nodes in y direction. - integer(I4P), intent(IN):: Nz !< Number of nodes in z direction. - real(R4P), intent(IN):: X0 !< X coordinate of origin. - real(R4P), intent(IN):: Y0 !< Y coordinate of origin. - real(R4P), intent(IN):: Z0 !< Z coordinate of origin. - real(R4P), intent(IN):: Dx !< Space step in x direction. - real(R4P), intent(IN):: Dy !< Space step in y direction. - real(R4P), intent(IN):: Dz !< Space step in z direction. - integer(I4P):: 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), intent(IN):: Nx !< Number of nodes in x direction. + integer(I4P), intent(IN):: Ny !< Number of nodes in y direction. + integer(I4P), intent(IN):: Nz !< Number of nodes in z direction. + real(R4P), intent(IN):: X0 !< X coordinate of origin. + real(R4P), intent(IN):: Y0 !< Y coordinate of origin. + real(R4P), intent(IN):: Z0 !< Z coordinate of origin. + real(R4P), intent(IN):: Dx !< Space step in x direction. + real(R4P), intent(IN):: Dy !< Space step in y direction. + real(R4P), intent(IN):: Dz !< Space step in z direction. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + integer(I4P):: rf !< Real file index. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - select case(vtk(f)%f) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) case(ascii) - write(unit=vtk(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 + write(vtk(rf)%u,'(A)',iostat=E_IO)'DIMENSIONS '//trim(str(.true.,Nx))//' '//trim(str(.true.,Ny))//' '//trim(str(.true.,Nz)) + write(vtk(rf)%u,'(A)',iostat=E_IO)'ORIGIN '//trim(str(n=X0))//' '//trim(str(n=Y0))//' '//trim(str(n=Z0)) + write(vtk(rf)%u,'(A)',iostat=E_IO)'SPACING '//trim(str(n=Dx))//' '//trim(str(n=Dy))//' '//trim(str(n=Dz)) + case(raw) + write(vtk(rf)%u,iostat=E_IO)'DIMENSIONS '//trim(str(.true.,Nx))//' '//trim(str(.true.,Ny))//' '//trim(str(.true.,Nz))//end_rec + write(vtk(rf)%u,iostat=E_IO)'ORIGIN '//trim(str(n=X0))//' '//trim(str(n=Y0))//' '//trim(str(n=Z0))//end_rec + write(vtk(rf)%u,iostat=E_IO)'SPACING '//trim(str(n=Dx))//' '//trim(str(n=Dy))//' '//trim(str(n=Dz))//end_rec endselect return !--------------------------------------------------------------------------------------------------------------------------------- endfunction VTK_GEO_STRP_R4 - !> Function for saving mesh with \b STRUCTURED_GRID topology (R8P). + !> Function for saving mesh with \b STRUCTURED_GRID topology (R8P, 1D arrays). !> @return E_IO: integer(I4P) error flag - function VTK_GEO_STRG_R8(Nx,Ny,Nz,NN,X,Y,Z) result(E_IO) + function VTK_GEO_STRG_1DA_R8(Nx,Ny,Nz,NN,X,Y,Z,cf) result(E_IO) !--------------------------------------------------------------------------------------------------------------------------------- implicit none - integer(I4P), intent(IN):: Nx !< Number of nodes in x direction. - integer(I4P), intent(IN):: Ny !< Number of nodes in y direction. - integer(I4P), intent(IN):: Nz !< Number of nodes in z direction. - integer(I4P), intent(IN):: NN !< Number of all nodes. - real(R8P), intent(IN):: X(1: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. + integer(I4P), intent(IN):: Nx !< Number of nodes in x direction. + integer(I4P), intent(IN):: Ny !< Number of nodes in y direction. + integer(I4P), intent(IN):: Nz !< Number of nodes in z direction. + integer(I4P), intent(IN):: NN !< Number of all nodes. + real(R8P), intent(IN):: X(1:) !< X coordinates [1:NN]. + real(R8P), intent(IN):: Y(1:) !< Y coordinates [1:NN]. + real(R8P), intent(IN):: Z(1:) !< Z coordinates [1:NN]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + integer(I4P):: rf !< Real file index. + integer(I4P):: n1 !< Counter. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - select case(vtk(f)%f) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) case(ascii) - write(unit=vtk(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 + write(vtk(rf)%u,'(A)',iostat=E_IO)'DIMENSIONS '//trim(str(.true.,Nx))//' '//trim(str(.true.,Ny))//' '//trim(str(.true.,Nz)) + write(vtk(rf)%u,'(A)',iostat=E_IO)'POINTS '//trim(str(.true.,NN))//' double' + do n1=1,NN + write(vtk(rf)%u,'(A)',iostat=E_IO)str(n=X(n1))//' '//str(n=Y(n1))//' '//str(n=Z(n1)) + enddo + case(raw) + write(vtk(rf)%u,iostat=E_IO)'DIMENSIONS '//trim(str(.true.,Nx))//' '//trim(str(.true.,Ny))//' '//trim(str(.true.,Nz))//end_rec + write(vtk(rf)%u,iostat=E_IO)'POINTS '//trim(str(.true.,NN))//' double'//end_rec + write(vtk(rf)%u,iostat=E_IO)(X(n1),Y(n1),Z(n1),n1=1,NN) + write(vtk(rf)%u,iostat=E_IO)end_rec endselect return !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_GEO_STRG_R8 + endfunction VTK_GEO_STRG_1DA_R8 - !> Function for saving mesh with \b STRUCTURED_GRID topology (R4P). + !> Function for saving mesh with \b STRUCTURED_GRID topology (R8P, 1D arrays, packed API). !> @return E_IO: integer(I4P) error flag - function VTK_GEO_STRG_R4(Nx,Ny,Nz,NN,X,Y,Z) result(E_IO) + function VTK_GEO_STRG_1DAP_R8(Nx,Ny,Nz,NN,XYZ,cf) result(E_IO) !--------------------------------------------------------------------------------------------------------------------------------- implicit none - integer(I4P), intent(IN):: Nx !< Number of nodes in x direction. - integer(I4P), intent(IN):: Ny !< Number of nodes in y direction. - integer(I4P), intent(IN):: Nz !< Number of nodes in z direction. - integer(I4P), intent(IN):: NN !< Number of all nodes. - real(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. + integer(I4P), intent(IN):: Nx !< Number of nodes in x direction. + integer(I4P), intent(IN):: Ny !< Number of nodes in y direction. + integer(I4P), intent(IN):: Nz !< Number of nodes in z direction. + integer(I4P), intent(IN):: NN !< Number of all nodes. + real(R8P), intent(IN):: XYZ(1:,1:) !< X, Y and Z coordinates [1:3,1:NN]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + integer(I4P):: rf !< Real file index. + integer(I4P):: n1 !< Counter. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - select case(vtk(f)%f) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) case(ascii) - write(unit=vtk(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 + write(vtk(rf)%u,'(A)',iostat=E_IO)'DIMENSIONS '//trim(str(.true.,Nx))//' '//trim(str(.true.,Ny))//' '//trim(str(.true.,Nz)) + write(vtk(rf)%u,'(A)',iostat=E_IO)'POINTS '//trim(str(.true.,NN))//' double' + do n1=1,NN + write(vtk(rf)%u,'(A)',iostat=E_IO)str(n=XYZ(1,n1))//' '//str(n=XYZ(2,n1))//' '//str(n=XYZ(3,n1)) + enddo + case(raw) + write(vtk(rf)%u,iostat=E_IO)'DIMENSIONS '//trim(str(.true.,Nx))//' '//trim(str(.true.,Ny))//' '//trim(str(.true.,Nz))//end_rec + write(vtk(rf)%u,iostat=E_IO)'POINTS '//trim(str(.true.,NN))//' double'//end_rec + write(vtk(rf)%u,iostat=E_IO)XYZ + write(vtk(rf)%u,iostat=E_IO)end_rec endselect return !--------------------------------------------------------------------------------------------------------------------------------- - endfunction VTK_GEO_STRG_R4 + endfunction VTK_GEO_STRG_1DAP_R8 + + !> Function for saving mesh with \b STRUCTURED_GRID topology (R8P, 3D arrays). + !> @return E_IO: integer(I4P) error flag + function VTK_GEO_STRG_3DA_R8(Nx,Ny,Nz,NN,X,Y,Z,cf) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: Nx !< Number of nodes in x direction. + integer(I4P), intent(IN):: Ny !< Number of nodes in y direction. + integer(I4P), intent(IN):: Nz !< Number of nodes in z direction. + integer(I4P), intent(IN):: NN !< Number of all nodes. + real(R8P), intent(IN):: X(1:,1:,1:) !< X coordinates [1:Nx,1:Ny,1:Nz]. + real(R8P), intent(IN):: Y(1:,1:,1:) !< Y coordinates [1:Nx,1:Ny,1:Nz]. + real(R8P), intent(IN):: Z(1:,1:,1:) !< Z coordinates [1:Nx,1:Ny,1:Nz]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + integer(I4P):: rf !< Real file index. + integer(I4P):: n1,n2,n3 !< Counters. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) + case(ascii) + write(vtk(rf)%u,'(A)',iostat=E_IO)'DIMENSIONS '//trim(str(.true.,Nx))//' '//trim(str(.true.,Ny))//' '//trim(str(.true.,Nz)) + write(vtk(rf)%u,'(A)',iostat=E_IO)'POINTS '//trim(str(.true.,NN))//' double' + do n3=1,Nz + do n2=1,Ny + do n1=1,Nx + write(vtk(rf)%u,'(A)',iostat=E_IO)str(n=X(n1,n2,n3))//' '//str(n=Y(n1,n2,n3))//' '//str(n=Z(n1,n2,n3)) + enddo + enddo + enddo + case(raw) + write(vtk(rf)%u,iostat=E_IO)'DIMENSIONS '//trim(str(.true.,Nx))//' '//trim(str(.true.,Ny))//' '//trim(str(.true.,Nz))//end_rec + write(vtk(rf)%u,iostat=E_IO)'POINTS '//trim(str(.true.,NN))//' double'//end_rec + write(vtk(rf)%u,iostat=E_IO)(((X(n1,n2,n3),Y(n1,n2,n3),Z(n1,n2,n3),n1=1,Nx),n2=1,Ny),n3=1,Nz) + write(vtk(rf)%u,iostat=E_IO)end_rec + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_GEO_STRG_3DA_R8 + + !> Function for saving mesh with \b STRUCTURED_GRID topology (R8P, 3D arrays, packed API). + !> @return E_IO: integer(I4P) error flag + function VTK_GEO_STRG_3DAP_R8(Nx,Ny,Nz,NN,XYZ,cf) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: Nx !< Number of nodes in x direction. + integer(I4P), intent(IN):: Ny !< Number of nodes in y direction. + integer(I4P), intent(IN):: Nz !< Number of nodes in z direction. + integer(I4P), intent(IN):: NN !< Number of all nodes. + real(R8P), intent(IN):: XYZ(1:,1:,1:,1:) !< X, Y and Z coordinates [1:3,1:Nx,1:Ny,1:Nz]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + integer(I4P):: rf !< Real file index. + integer(I4P):: n1,n2,n3 !< Counters. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) + case(ascii) + write(vtk(rf)%u,'(A)',iostat=E_IO)'DIMENSIONS '//trim(str(.true.,Nx))//' '//trim(str(.true.,Ny))//' '//trim(str(.true.,Nz)) + write(vtk(rf)%u,'(A)',iostat=E_IO)'POINTS '//trim(str(.true.,NN))//' double' + do n3=1,Nz + do n2=1,Ny + do n1=1,Nx + write(vtk(rf)%u,'(A)',iostat=E_IO)str(n=XYZ(1,n1,n2,n3))//' '//str(n=XYZ(2,n1,n2,n3))//' '//str(n=XYZ(3,n1,n2,n3)) + enddo + enddo + enddo + case(raw) + write(vtk(rf)%u,iostat=E_IO)'DIMENSIONS '//trim(str(.true.,Nx))//' '//trim(str(.true.,Ny))//' '//trim(str(.true.,Nz))//end_rec + write(vtk(rf)%u,iostat=E_IO)'POINTS '//trim(str(.true.,NN))//' double'//end_rec + write(vtk(rf)%u,iostat=E_IO)XYZ + write(vtk(rf)%u,iostat=E_IO)end_rec + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_GEO_STRG_3DAP_R8 + + !> Function for saving mesh with \b STRUCTURED_GRID topology (R4P, 1D arrays). + !> @return E_IO: integer(I4P) error flag + function VTK_GEO_STRG_1DA_R4(Nx,Ny,Nz,NN,X,Y,Z,cf) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: Nx !< Number of nodes in x direction. + integer(I4P), intent(IN):: Ny !< Number of nodes in y direction. + integer(I4P), intent(IN):: Nz !< Number of nodes in z direction. + integer(I4P), intent(IN):: NN !< Number of all nodes. + real(R4P), intent(IN):: X(1:) !< X coordinates [1:NN]. + real(R4P), intent(IN):: Y(1:) !< Y coordinates [1:NN]. + real(R4P), intent(IN):: Z(1:) !< Z coordinates [1:NN]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + integer(I4P):: rf !< Real file index. + integer(I4P):: n1 !< Counter. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) + case(ascii) + write(vtk(rf)%u,'(A)',iostat=E_IO)'DIMENSIONS '//trim(str(.true.,Nx))//' '//trim(str(.true.,Ny))//' '//trim(str(.true.,Nz)) + write(vtk(rf)%u,'(A)',iostat=E_IO)'POINTS '//trim(str(.true.,NN))//' float' + do n1=1,NN + write(vtk(rf)%u,'(A)',iostat=E_IO)str(n=X(n1))//' '//str(n=Y(n1))//' '//str(n=Z(n1)) + enddo + case(raw) + write(vtk(rf)%u,iostat=E_IO)'DIMENSIONS '//trim(str(.true.,Nx))//' '//trim(str(.true.,Ny))//' '//trim(str(.true.,Nz))//end_rec + write(vtk(rf)%u,iostat=E_IO)'POINTS '//trim(str(.true.,NN))//' float'//end_rec + write(vtk(rf)%u,iostat=E_IO)(X(n1),Y(n1),Z(n1),n1=1,NN) + write(vtk(rf)%u,iostat=E_IO)end_rec + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_GEO_STRG_1DA_R4 + + !> Function for saving mesh with \b STRUCTURED_GRID topology (R4P, 1D arrays, packed API). + !> @return E_IO: integer(I4P) error flag + function VTK_GEO_STRG_1DAP_R4(Nx,Ny,Nz,NN,XYZ,cf) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: Nx !< Number of nodes in x direction. + integer(I4P), intent(IN):: Ny !< Number of nodes in y direction. + integer(I4P), intent(IN):: Nz !< Number of nodes in z direction. + integer(I4P), intent(IN):: NN !< Number of all nodes. + real(R4P), intent(IN):: XYZ(1:,1:) !< X, Y and Z coordinates [1:3,1:NN]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + integer(I4P):: rf !< Real file index. + integer(I4P):: n1 !< Counter. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) + case(ascii) + write(vtk(rf)%u,'(A)',iostat=E_IO)'DIMENSIONS '//trim(str(.true.,Nx))//' '//trim(str(.true.,Ny))//' '//trim(str(.true.,Nz)) + write(vtk(rf)%u,'(A)',iostat=E_IO)'POINTS '//trim(str(.true.,NN))//' float' + do n1=1,NN + write(vtk(rf)%u,'(A)',iostat=E_IO)str(n=XYZ(1,n1))//' '//str(n=XYZ(2,n1))//' '//str(n=XYZ(3,n1)) + enddo + case(raw) + write(vtk(rf)%u,iostat=E_IO)'DIMENSIONS '//trim(str(.true.,Nx))//' '//trim(str(.true.,Ny))//' '//trim(str(.true.,Nz))//end_rec + write(vtk(rf)%u,iostat=E_IO)'POINTS '//trim(str(.true.,NN))//' float'//end_rec + write(vtk(rf)%u,iostat=E_IO)XYZ + write(vtk(rf)%u,iostat=E_IO)end_rec + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_GEO_STRG_1DAP_R4 + + !> Function for saving mesh with \b STRUCTURED_GRID topology (R4P, 3D arrays). + !> @return E_IO: integer(I4P) error flag + function VTK_GEO_STRG_3DA_R4(Nx,Ny,Nz,NN,X,Y,Z,cf) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: Nx !< Number of nodes in x direction. + integer(I4P), intent(IN):: Ny !< Number of nodes in y direction. + integer(I4P), intent(IN):: Nz !< Number of nodes in z direction. + integer(I4P), intent(IN):: NN !< Number of all nodes. + real(R4P), intent(IN):: X(1:,1:,1:) !< X coordinates [1:Nx,1:Ny,1:Nz]. + real(R4P), intent(IN):: Y(1:,1:,1:) !< Y coordinates [1:Nx,1:Ny,1:Nz]. + real(R4P), intent(IN):: Z(1:,1:,1:) !< Z coordinates [1:Nx,1:Ny,1:Nz]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + integer(I4P):: rf !< Real file index. + integer(I4P):: n1,n2,n3 !< Counters. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) + case(ascii) + write(vtk(rf)%u,'(A)',iostat=E_IO)'DIMENSIONS '//trim(str(.true.,Nx))//' '//trim(str(.true.,Ny))//' '//trim(str(.true.,Nz)) + write(vtk(rf)%u,'(A)',iostat=E_IO)'POINTS '//trim(str(.true.,NN))//' float' + do n3=1,Nz + do n2=1,Ny + do n1=1,Nx + write(vtk(rf)%u,'(A)',iostat=E_IO)str(n=X(n1,n2,n3))//' '//str(n=Y(n1,n2,n3))//' '//str(n=Z(n1,n2,n3)) + enddo + enddo + enddo + case(raw) + write(vtk(rf)%u,iostat=E_IO)'DIMENSIONS '//trim(str(.true.,Nx))//' '//trim(str(.true.,Ny))//' '//trim(str(.true.,Nz))//end_rec + write(vtk(rf)%u,iostat=E_IO)'POINTS '//trim(str(.true.,NN))//' float'//end_rec + write(vtk(rf)%u,iostat=E_IO)(((X(n1,n2,n3),Y(n1,n2,n3),Z(n1,n2,n3),n1=1,Nx),n2=1,Ny),n3=1,Nz) + write(vtk(rf)%u,iostat=E_IO)end_rec + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_GEO_STRG_3DA_R4 + + !> Function for saving mesh with \b STRUCTURED_GRID topology (R4P, 3D arrays, packed API). + !> @return E_IO: integer(I4P) error flag + function VTK_GEO_STRG_3DAP_R4(Nx,Ny,Nz,NN,XYZ,cf) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: Nx !< Number of nodes in x direction. + integer(I4P), intent(IN):: Ny !< Number of nodes in y direction. + integer(I4P), intent(IN):: Nz !< Number of nodes in z direction. + integer(I4P), intent(IN):: NN !< Number of all nodes. + real(R4P), intent(IN):: XYZ(1:,1:,1:,1:) !< X, Y and Z coordinates [1:3,1:Nx,1:Ny,1:Nz]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + integer(I4P):: rf !< Real file index. + integer(I4P):: n1,n2,n3 !< Counters. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) + case(ascii) + write(vtk(rf)%u,'(A)',iostat=E_IO)'DIMENSIONS '//trim(str(.true.,Nx))//' '//trim(str(.true.,Ny))//' '//trim(str(.true.,Nz)) + write(vtk(rf)%u,'(A)',iostat=E_IO)'POINTS '//trim(str(.true.,NN))//' float' + do n3=1,Nz + do n2=1,Ny + do n1=1,Nx + write(vtk(rf)%u,'(A)',iostat=E_IO)str(n=XYZ(1,n1,n2,n3))//' '//str(n=XYZ(2,n1,n2,n3))//' '//str(n=XYZ(3,n1,n2,n3)) + enddo + enddo + enddo + case(raw) + write(vtk(rf)%u,iostat=E_IO)'DIMENSIONS '//trim(str(.true.,Nx))//' '//trim(str(.true.,Ny))//' '//trim(str(.true.,Nz))//end_rec + write(vtk(rf)%u,iostat=E_IO)'POINTS '//trim(str(.true.,NN))//' float'//end_rec + write(vtk(rf)%u,iostat=E_IO)XYZ + write(vtk(rf)%u,iostat=E_IO)end_rec + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_GEO_STRG_3DAP_R4 !> Function for saving mesh with \b RECTILINEAR_GRID topology (R8P). !> @return E_IO: integer(I4P) error flag - function VTK_GEO_RECT_R8(Nx,Ny,Nz,X,Y,Z) result(E_IO) + function VTK_GEO_RECT_R8(Nx,Ny,Nz,X,Y,Z,cf) result(E_IO) !--------------------------------------------------------------------------------------------------------------------------------- implicit none - integer(I4P), intent(IN):: Nx !< Number of nodes in x direction. - integer(I4P), intent(IN):: Ny !< Number of nodes in y direction. - integer(I4P), intent(IN):: Nz !< Number of nodes in z direction. - real(R8P), intent(IN):: X(1:Nx) !< X coordinates. - real(R8P), intent(IN):: Y(1:Ny) !< Y coordinates. - real(R8P), intent(IN):: Z(1:Nz) !< Z coordinates. - integer(I4P):: 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. + integer(I4P), intent(IN):: Nx !< Number of nodes in x direction. + integer(I4P), intent(IN):: Ny !< Number of nodes in y direction. + integer(I4P), intent(IN):: Nz !< Number of nodes in z direction. + real(R8P), intent(IN):: X(1:Nx) !< X coordinates. + real(R8P), intent(IN):: Y(1:Ny) !< Y coordinates. + real(R8P), intent(IN):: Z(1:Nz) !< Z coordinates. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + integer(I4P):: rf !< Real file index. + integer(I4P):: n1 !< Counter. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - select case(vtk(f)%f) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) case(ascii) - write(unit=vtk(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 + write(vtk(rf)%u,'(A)',iostat=E_IO)'DIMENSIONS '//trim(str(.true.,Nx))//' '//trim(str(.true.,Ny))//' '//trim(str(.true.,Nz)) + write(vtk(rf)%u,'(A)',iostat=E_IO)'X_COORDINATES '//trim(str(.true.,Nx))//' double' + do n1=1,Nx + write(vtk(rf)%u,'(A)',iostat=E_IO)str(n=X(n1)) + enddo + write(vtk(rf)%u,'(A)',iostat=E_IO)'Y_COORDINATES '//trim(str(.true.,Ny))//' double' + do n1=1,Ny + write(vtk(rf)%u,'(A)',iostat=E_IO)str(n=Y(n1)) + enddo + write(vtk(rf)%u,'(A)',iostat=E_IO)'Z_COORDINATES '//trim(str(.true.,Nz))//' double' + do n1=1,Nz + write(vtk(rf)%u,'(A)',iostat=E_IO)str(n=Z(n1)) + enddo + case(raw) + write(vtk(rf)%u,iostat=E_IO)'DIMENSIONS '//trim(str(.true.,Nx))//' '//trim(str(.true.,Ny))//' '//trim(str(.true.,Nz))//end_rec + write(vtk(rf)%u,iostat=E_IO)'X_COORDINATES '//trim(str(.true.,Nx))//' double'//end_rec + write(vtk(rf)%u,iostat=E_IO)X + write(vtk(rf)%u,iostat=E_IO)end_rec + write(vtk(rf)%u,iostat=E_IO)'Y_COORDINATES '//trim(str(.true.,Ny))//' double'//end_rec + write(vtk(rf)%u,iostat=E_IO)Y + write(vtk(rf)%u,iostat=E_IO)end_rec + write(vtk(rf)%u,iostat=E_IO)'Z_COORDINATES '//trim(str(.true.,Nz))//' double'//end_rec + write(vtk(rf)%u,iostat=E_IO)Z + write(vtk(rf)%u,iostat=E_IO)end_rec endselect return !--------------------------------------------------------------------------------------------------------------------------------- @@ -2661,45 +5396,53 @@ contains !> 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) + function VTK_GEO_RECT_R4(Nx,Ny,Nz,X,Y,Z,cf) result(E_IO) !--------------------------------------------------------------------------------------------------------------------------------- implicit none - integer(I4P), intent(IN):: Nx !< Number of nodes in x direction. - integer(I4P), intent(IN):: Ny !< Number of nodes in y direction. - integer(I4P), intent(IN):: Nz !< Number of nodes in z direction. - real(R4P), intent(IN):: X(1:Nx) !< X coordinates. - real(R4P), intent(IN):: Y(1:Ny) !< Y coordinates. - real(R4P), intent(IN):: Z(1:Nz) !< Z coordinates. - integer(I4P):: 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. + integer(I4P), intent(IN):: Nx !< Number of nodes in x direction. + integer(I4P), intent(IN):: Ny !< Number of nodes in y direction. + integer(I4P), intent(IN):: Nz !< Number of nodes in z direction. + real(R4P), intent(IN):: X(1:Nx) !< X coordinates. + real(R4P), intent(IN):: Y(1:Ny) !< Y coordinates. + real(R4P), intent(IN):: Z(1:Nz) !< Z coordinates. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + integer(I4P):: rf !< Real file index. + integer(I4P):: n1 !< Counter. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - select case(vtk(f)%f) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) case(ascii) - write(unit=vtk(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 + write(vtk(rf)%u,'(A)',iostat=E_IO)'DIMENSIONS '//trim(str(.true.,Nx))//' '//trim(str(.true.,Ny))//' '//trim(str(.true.,Nz)) + write(vtk(rf)%u,'(A)',iostat=E_IO)'X_COORDINATES '//trim(str(.true.,Nx))//' float' + do n1=1,Nx + write(vtk(rf)%u,'(A)',iostat=E_IO)str(n=X(n1)) + enddo + write(vtk(rf)%u,'(A)',iostat=E_IO)'Y_COORDINATES '//trim(str(.true.,Ny))//' float' + do n1=1,Ny + write(vtk(rf)%u,'(A)',iostat=E_IO)str(n=Y(n1)) + enddo + write(vtk(rf)%u,'(A)',iostat=E_IO)'Z_COORDINATES '//trim(str(.true.,Nz))//' float' + do n1=1,Nz + write(vtk(rf)%u,'(A)',iostat=E_IO)str(n=Z(n1)) + enddo + case(raw) + write(vtk(rf)%u,iostat=E_IO)'DIMENSIONS '//trim(str(.true.,Nx))//' '//trim(str(.true.,Ny))//' '//trim(str(.true.,Nz))//end_rec + write(vtk(rf)%u,iostat=E_IO)'X_COORDINATES '//trim(str(.true.,Nx))//' float'//end_rec + write(vtk(rf)%u,iostat=E_IO)X + write(vtk(rf)%u,iostat=E_IO)end_rec + write(vtk(rf)%u,iostat=E_IO)'Y_COORDINATES '//trim(str(.true.,Ny))//' float'//end_rec + write(vtk(rf)%u,iostat=E_IO)Y + write(vtk(rf)%u,iostat=E_IO)end_rec + write(vtk(rf)%u,iostat=E_IO)'Z_COORDINATES '//trim(str(.true.,Nz))//' float'//end_rec + write(vtk(rf)%u,iostat=E_IO)Z + write(vtk(rf)%u,iostat=E_IO)end_rec endselect return !--------------------------------------------------------------------------------------------------------------------------------- @@ -2707,61 +5450,143 @@ contains !> 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) + function VTK_GEO_UNST_R8(NN,X,Y,Z,cf) result(E_IO) !--------------------------------------------------------------------------------------------------------------------------------- implicit none - integer(I4P), intent(IN):: NN !< Number of nodes. - real(R8P), intent(IN):: X(1: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. + integer(I4P), intent(IN):: NN !< Number of nodes. + real(R8P), intent(IN):: X(1:) !< X coordinates of all nodes [1:NN]. + real(R8P), intent(IN):: Y(1:) !< Y coordinates of all nodes [1:NN]. + real(R8P), intent(IN):: Z(1:) !< Z coordinates of all nodes [1:NN]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + integer(I4P):: rf !< Real file index. + integer(I4P):: n1 !< Counter. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - select case(vtk(f)%f) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) case(ascii) - write(unit=vtk(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 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)'POINTS '//str(.true.,NN)//' double' + do n1=1,NN + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)str(n=X(n1))//' '//str(n=Y(n1))//' '//str(n=Z(n1)) + enddo + case(raw) + write(unit=vtk(rf)%u,iostat=E_IO)'POINTS '//str(.true.,NN)//' double'//end_rec + write(unit=vtk(rf)%u,iostat=E_IO)(X(n1),Y(n1),Z(n1),n1=1,NN) + write(unit=vtk(rf)%u,iostat=E_IO)end_rec endselect return !--------------------------------------------------------------------------------------------------------------------------------- endfunction VTK_GEO_UNST_R8 - !> Function for saving mesh with \b UNSTRUCTURED_GRID topology (R4P). + !> Function for saving mesh with \b UNSTRUCTURED_GRID topology (R8P, packed API). !> @return E_IO: integer(I4P) error flag - function VTK_GEO_UNST_R4(NN,X,Y,Z) result(E_IO) + function VTK_GEO_UNST_P_R8(NN,XYZ,cf) 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. + integer(I4P), intent(IN):: NN !< Number of nodes. + real(R8P), intent(IN):: XYZ(1:,1:) !< X, Y and Z coordinates of all nodes [1:3,1:NN]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + integer(I4P):: rf !< Real file index. + integer(I4P):: n1 !< Counter. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - select case(vtk(f)%f) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) case(ascii) - write(unit=vtk(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 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)'POINTS '//str(.true.,NN)//' double' + do n1=1,NN + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)str(n=XYZ(1,n1))//' '//str(n=XYZ(2,n1))//' '//str(n=XYZ(3,n1)) + enddo + case(raw) + write(unit=vtk(rf)%u,iostat=E_IO)'POINTS '//str(.true.,NN)//' double'//end_rec + write(unit=vtk(rf)%u,iostat=E_IO)XYZ + write(unit=vtk(rf)%u,iostat=E_IO)end_rec + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_GEO_UNST_P_R8 + + !> Function for saving mesh with \b UNSTRUCTURED_GRID topology (R4P). + !> @return E_IO: integer(I4P) error flag + function VTK_GEO_UNST_R4(NN,X,Y,Z,cf) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: NN !< number of nodes. + real(R4P), intent(IN):: X(1:) !< X coordinates of all nodes [1:NN]. + real(R4P), intent(IN):: Y(1:) !< Y coordinates of all nodes [1:NN]. + real(R4P), intent(IN):: Z(1:) !< Z coordinates of all nodes [1:NN]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + integer(I4P):: rf !< Real file index. + integer(I4P):: n1 !< counter. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) + case(ascii) + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)'POINTS '//str(.true.,NN)//' float' + do n1=1,NN + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)str(n=X(n1))//' '//str(n=Y(n1))//' '//str(n=Z(n1)) + enddo + case(raw) + write(unit=vtk(rf)%u,iostat=E_IO)'POINTS '//str(.true.,NN)//' float'//end_rec + write(unit=vtk(rf)%u,iostat=E_IO)(X(n1),Y(n1),Z(n1),n1=1,NN) + write(unit=vtk(rf)%u,iostat=E_IO)end_rec endselect return !--------------------------------------------------------------------------------------------------------------------------------- endfunction VTK_GEO_UNST_R4 + + !> Function for saving mesh with \b UNSTRUCTURED_GRID topology (R4P, packed API). + !> @return E_IO: integer(I4P) error flag + function VTK_GEO_UNST_P_R4(NN,XYZ,cf) result(E_IO) + !--------------------------------------------------------------------------------------------------------------------------------- + implicit none + integer(I4P), intent(IN):: NN !< number of nodes. + real(R4P), intent(IN):: XYZ(1:,1:) !< X, Y and Z coordinates of all nodes [1:3,1:NN]. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + integer(I4P):: rf !< Real file index. + integer(I4P):: n1 !< counter. + !--------------------------------------------------------------------------------------------------------------------------------- + + !--------------------------------------------------------------------------------------------------------------------------------- + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) + case(ascii) + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)'POINTS '//str(.true.,NN)//' float' + do n1=1,NN + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)str(n=XYZ(1,n1))//' '//str(n=XYZ(2,n1))//' '//str(n=XYZ(3,n1)) + enddo + case(raw) + write(unit=vtk(rf)%u,iostat=E_IO)'POINTS '//str(.true.,NN)//' float'//end_rec + write(unit=vtk(rf)%u,iostat=E_IO)XYZ + write(unit=vtk(rf)%u,iostat=E_IO)end_rec + endselect + return + !--------------------------------------------------------------------------------------------------------------------------------- + endfunction VTK_GEO_UNST_P_R4 !> @} !> Function that \b must be used when unstructured grid is used, it saves the connectivity of the unstructured gird. @@ -2803,34 +5628,41 @@ contains !> 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) + function VTK_CON(NC,connect,cell_type,cf) result(E_IO) !--------------------------------------------------------------------------------------------------------------------------------- implicit none - integer(I4P), intent(IN):: NC !< Number of cells. - integer(I4P), intent(IN):: connect(:) !< Mesh connectivity. - integer(I4P), intent(IN):: cell_type(1:NC) !< VTK cell type. - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - character(len=maxlen):: s_buffer !< Buffer string. - integer(I4P):: ncon !< Dimension of connectivity vector. + integer(I4P), intent(IN):: NC !< Number of cells. + integer(I4P), intent(IN):: connect(:) !< Mesh connectivity. + integer(I4P), intent(IN):: cell_type(1:NC) !< VTK cell type. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + character(len=maxlen):: s_buffer !< Buffer string. + integer(I4P):: ncon !< Dimension of connectivity vector. + integer(I4P):: rf !< Real file index. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif ncon = size(connect,1) - select case(vtk(f)%f) + select case(vtk(rf)%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 + write(unit=vtk(rf)%u,fmt='(A,2'//FI4P//')',iostat=E_IO)'CELLS ',NC,ncon + write(unit=vtk(rf)%u,fmt=FI4P, iostat=E_IO)connect + write(unit=vtk(rf)%u,fmt='(A,'//FI4P//')', iostat=E_IO)'CELL_TYPES ',NC + write(unit=vtk(rf)%u,fmt=FI4P, iostat=E_IO)cell_type + case(raw) + write(s_buffer, fmt='(A,2'//FI4P//')',iostat=E_IO)'CELLS ',NC,ncon + write(unit=vtk(rf)%u, iostat=E_IO)trim(s_buffer)//end_rec + write(unit=vtk(rf)%u, iostat=E_IO)connect + write(unit=vtk(rf)%u, iostat=E_IO)end_rec + write(s_buffer, fmt='(A,'//FI4P//')', iostat=E_IO)'CELL_TYPES ',NC + write(unit=vtk(rf)%u, iostat=E_IO)trim(s_buffer)//end_rec + write(unit=vtk(rf)%u, iostat=E_IO)cell_type + write(unit=vtk(rf)%u, iostat=E_IO)end_rec endselect return !--------------------------------------------------------------------------------------------------------------------------------- @@ -2851,32 +5683,39 @@ contains !> ... @endcode !> @return E_IO: integer(I4P) error flag !> @ingroup Lib_VTK_IOPublicProcedure - function VTK_DAT(NC_NN,var_location) result(E_IO) + function VTK_DAT(NC_NN,var_location,cf) result(E_IO) !--------------------------------------------------------------------------------------------------------------------------------- implicit none - integer(I4P), intent(IN):: NC_NN !< Number of cells or nodes of field. - character(*), intent(IN):: var_location !< Location of saving variables: cell for cell-centered, node for node-centered. - integer(I4P):: 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), intent(IN):: NC_NN !< Number of cells or nodes of field. + character(*), intent(IN):: var_location !< Location of saving variables: cell for cell-centered, node for node-centered. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + character(len=maxlen):: s_buffer !< Buffer string. + integer(I4P):: rf !< Real file index. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - select case(vtk(f)%f) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) case(ascii) select case(trim(Upper_Case(var_location))) case('CELL') - write(unit=vtk(f)%u,fmt='(A,'//FI4P//')',iostat=E_IO)'CELL_DATA ',NC_NN + write(unit=vtk(rf)%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 + write(unit=vtk(rf)%u,fmt='(A,'//FI4P//')',iostat=E_IO)'POINT_DATA ',NC_NN endselect - case(binary) + case(raw) select case(trim(Upper_Case(var_location))) case('CELL') write(s_buffer,fmt='(A,'//FI4P//')',iostat=E_IO)'CELL_DATA ',NC_NN - write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec case('NODE') write(s_buffer,fmt='(A,'//FI4P//')',iostat=E_IO)'POINT_DATA ',NC_NN - write(unit=vtk(f)%u,iostat=E_IO)trim(s_buffer)//end_rec + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec endselect endselect return @@ -2887,26 +5726,33 @@ contains !> @{ !> 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) + function VTK_VAR_SCAL_R8(NC_NN,varname,var,cf) result(E_IO) !--------------------------------------------------------------------------------------------------------------------------------- implicit none - integer(I4P), intent(IN):: NC_NN !< Number of nodes or cells. - character(*), intent(IN):: varname !< Variable name. - real(R8P), intent(IN):: var(1:NC_NN) !< Variable to be saved. - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + integer(I4P), intent(IN):: NC_NN !< Number of nodes or cells. + character(*), intent(IN):: varname !< Variable name. + real(R8P), intent(IN):: var(1:NC_NN) !< Variable to be saved. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + integer(I4P):: rf !< Real file index. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - select case(vtk(f)%f) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) case(ascii) - write(unit=vtk(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 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)'SCALARS '//trim(varname)//' double 1' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)'LOOKUP_TABLE default' + write(unit=vtk(rf)%u,fmt=FR8P, iostat=E_IO)var + case(raw) + write(unit=vtk(rf)%u,iostat=E_IO)'SCALARS '//trim(varname)//' double 1'//end_rec + write(unit=vtk(rf)%u,iostat=E_IO)'LOOKUP_TABLE default'//end_rec + write(unit=vtk(rf)%u,iostat=E_IO)var + write(unit=vtk(rf)%u,iostat=E_IO)end_rec endselect return !--------------------------------------------------------------------------------------------------------------------------------- @@ -2914,26 +5760,33 @@ contains !> 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) + function VTK_VAR_SCAL_R4(NC_NN,varname,var,cf) result(E_IO) !--------------------------------------------------------------------------------------------------------------------------------- implicit none - integer(I4P), intent(IN):: NC_NN !< Number of nodes or cells. - character(*), intent(IN):: varname !< Variable name. - real(R4P), intent(IN):: var(1:NC_NN) !< Variable to be saved. - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + integer(I4P), intent(IN):: NC_NN !< Number of nodes or cells. + character(*), intent(IN):: varname !< Variable name. + real(R4P), intent(IN):: var(1:NC_NN) !< Variable to be saved. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + integer(I4P):: rf !< Real file index. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - select case(vtk(f)%f) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) case(ascii) - write(unit=vtk(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 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)'SCALARS '//trim(varname)//' float 1' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)'LOOKUP_TABLE default' + write(unit=vtk(rf)%u,fmt=FR4P, iostat=E_IO)var + case(raw) + write(unit=vtk(rf)%u,iostat=E_IO)'SCALARS '//trim(varname)//' float 1'//end_rec + write(unit=vtk(rf)%u,iostat=E_IO)'LOOKUP_TABLE default'//end_rec + write(unit=vtk(rf)%u,iostat=E_IO)var + write(unit=vtk(rf)%u,iostat=E_IO)end_rec endselect return !--------------------------------------------------------------------------------------------------------------------------------- @@ -2941,26 +5794,33 @@ contains !> 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) + function VTK_VAR_SCAL_I4(NC_NN,varname,var,cf) result(E_IO) !--------------------------------------------------------------------------------------------------------------------------------- implicit none - integer(I4P), intent(IN):: NC_NN !< Number of nodes or cells. - character(*), intent(IN):: varname !< Variable name. - integer(I4P), intent(IN):: var(1:NC_NN) !< Variable to be saved. - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + integer(I4P), intent(IN):: NC_NN !< Number of nodes or cells. + character(*), intent(IN):: varname !< Variable name. + integer(I4P), intent(IN):: var(1:NC_NN) !< Variable to be saved. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + integer(I4P):: rf !< Real file index. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - select case(vtk(f)%f) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) case(ascii) - write(unit=vtk(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 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)'SCALARS '//trim(varname)//' int 1' + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)'LOOKUP_TABLE default' + write(unit=vtk(rf)%u,fmt=FI4P, iostat=E_IO)var + case(raw) + write(unit=vtk(rf)%u,iostat=E_IO)'SCALARS '//trim(varname)//' int 1'//end_rec + write(unit=vtk(rf)%u,iostat=E_IO)'LOOKUP_TABLE default'//end_rec + write(unit=vtk(rf)%u,iostat=E_IO)var + write(unit=vtk(rf)%u,iostat=E_IO)end_rec endselect return !--------------------------------------------------------------------------------------------------------------------------------- @@ -2968,38 +5828,45 @@ contains !> 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) + function VTK_VAR_VECT_R8(vec_type,NC_NN,varname,varX,varY,varZ,cf) result(E_IO) !--------------------------------------------------------------------------------------------------------------------------------- implicit none - character(*), intent(IN):: vec_type !< Vector type: vect = generic vector , norm = normal vector. - integer(I4P), intent(IN):: NC_NN !< Number of nodes or cells. - character(*), intent(IN):: varname !< Variable name. - real(R8P), intent(IN):: varX(1:NC_NN) !< X component of vector. - real(R8P), intent(IN):: varY(1:NC_NN) !< Y component of vector. - real(R8P), intent(IN):: varZ(1:NC_NN) !< Z component of vector. - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - integer(I8P):: n1 !< Counter. + character(*), intent(IN):: vec_type !< Vector type: vect = generic vector , norm = normal vector. + integer(I4P), intent(IN):: NC_NN !< Number of nodes or cells. + character(*), intent(IN):: varname !< Variable name. + real(R8P), intent(IN):: varX(1:NC_NN) !< X component of vector. + real(R8P), intent(IN):: varY(1:NC_NN) !< Y component of vector. + real(R8P), intent(IN):: varZ(1:NC_NN) !< Z component of vector. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + integer(I4P):: rf !< Real file index. + integer(I8P):: n1 !< Counter. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - select case(vtk(f)%f) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) case(ascii) select case(Upper_Case(trim(vec_type))) case('VECT') - write(unit=vtk(f)%u,fmt='(A)', iostat=E_IO)'VECTORS '//trim(varname)//' double' + write(unit=vtk(rf)%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' + write(unit=vtk(rf)%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) + write(unit=vtk(rf)%u,fmt='(3'//FR8P//')',iostat=E_IO)(varX(n1),varY(n1),varZ(n1),n1=1,NC_NN) + case(raw) select case(Upper_Case(trim(vec_type))) case('VECT') - write(unit=vtk(f)%u,iostat=E_IO)'VECTORS '//trim(varname)//' double'//end_rec + write(unit=vtk(rf)%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 + write(unit=vtk(rf)%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 + write(unit=vtk(rf)%u,iostat=E_IO)(varX(n1),varY(n1),varZ(n1),n1=1,NC_NN) + write(unit=vtk(rf)%u,iostat=E_IO)end_rec endselect return !--------------------------------------------------------------------------------------------------------------------------------- @@ -3007,38 +5874,45 @@ contains !> 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) + function VTK_VAR_VECT_R4(vec_type,NC_NN,varname,varX,varY,varZ,cf) result(E_IO) !--------------------------------------------------------------------------------------------------------------------------------- implicit none - character(*), intent(IN):: vec_type !< Vector type: vect = generic vector , norm = normal vector. - integer(I4P), intent(IN):: NC_NN !< Number of nodes or cells. - character(*), intent(IN):: varname !< Variable name. - real(R4P), intent(IN):: varX(1:NC_NN) !< X component of vector. - real(R4P), intent(IN):: varY(1:NC_NN) !< Y component of vector. - real(R4P), intent(IN):: varZ(1:NC_NN) !< Z component of vector. - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - integer(I8P):: n1 !< Counter. + character(*), intent(IN):: vec_type !< Vector type: vect = generic vector , norm = normal vector. + integer(I4P), intent(IN):: NC_NN !< Number of nodes or cells. + character(*), intent(IN):: varname !< Variable name. + real(R4P), intent(IN):: varX(1:NC_NN) !< X component of vector. + real(R4P), intent(IN):: varY(1:NC_NN) !< Y component of vector. + real(R4P), intent(IN):: varZ(1:NC_NN) !< Z component of vector. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + integer(I4P):: rf !< Real file index. + integer(I8P):: n1 !< Counter. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - select case(vtk(f)%f) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) case(ascii) select case(Upper_Case(trim(vec_type))) case('vect') - write(unit=vtk(f)%u,fmt='(A)', iostat=E_IO)'VECTORS '//trim(varname)//' float' + write(unit=vtk(rf)%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' + write(unit=vtk(rf)%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) + write(unit=vtk(rf)%u,fmt='(3'//FR4P//')',iostat=E_IO)(varX(n1),varY(n1),varZ(n1),n1=1,NC_NN) + case(raw) select case(Upper_Case(trim(vec_type))) case('vect') - write(unit=vtk(f)%u,iostat=E_IO)'VECTORS '//trim(varname)//' float'//end_rec + write(unit=vtk(rf)%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 + write(unit=vtk(rf)%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 + write(unit=vtk(rf)%u,iostat=E_IO)(varX(n1),varY(n1),varZ(n1),n1=1,NC_NN) + write(unit=vtk(rf)%u,iostat=E_IO)end_rec endselect return !--------------------------------------------------------------------------------------------------------------------------------- @@ -3046,27 +5920,34 @@ contains !> 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) + function VTK_VAR_VECT_I4(NC_NN,varname,varX,varY,varZ,cf) result(E_IO) !--------------------------------------------------------------------------------------------------------------------------------- implicit none - integer(I4P), intent(IN):: NC_NN !< Number of nodes or cells. - character(*), intent(IN):: varname !< Variable name. - integer(I4P), intent(IN):: varX(1:NC_NN) !< X component of vector. - integer(I4P), intent(IN):: varY(1:NC_NN) !< Y component of vector. - integer(I4P), intent(IN):: varZ(1:NC_NN) !< Z component of vector. - integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. - integer(I8P):: n1 !< Counter. + integer(I4P), intent(IN):: NC_NN !< Number of nodes or cells. + character(*), intent(IN):: varname !< Variable name. + integer(I4P), intent(IN):: varX(1:NC_NN) !< X component of vector. + integer(I4P), intent(IN):: varY(1:NC_NN) !< Y component of vector. + integer(I4P), intent(IN):: varZ(1:NC_NN) !< Z component of vector. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + integer(I4P):: rf !< Real file index. + integer(I8P):: n1 !< Counter. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - select case(vtk(f)%f) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) case(ascii) - write(unit=vtk(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 + write(unit=vtk(rf)%u,fmt='(A)',iostat=E_IO)'VECTORS '//trim(varname)//' int' + write(unit=vtk(rf)%u,fmt='(3'//FI4P//')',iostat=E_IO)(varX(n1),varY(n1),varZ(n1),n1=1,NC_NN) + case(raw) + write(unit=vtk(rf)%u,iostat=E_IO)'VECTORS '//trim(varname)//' int'//end_rec + write(unit=vtk(rf)%u,iostat=E_IO)(varX(n1),varY(n1),varZ(n1),n1=1,NC_NN) + write(unit=vtk(rf)%u,iostat=E_IO)end_rec endselect return !--------------------------------------------------------------------------------------------------------------------------------- @@ -3074,30 +5955,37 @@ contains !> 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) + function VTK_VAR_TEXT_R8(NC_NN,dimm,varname,textCoo,cf) result(E_IO) !--------------------------------------------------------------------------------------------------------------------------------- implicit none - integer(I4P), intent(IN):: NC_NN !< Number of nodes or cells. - integer(I4P), intent(IN):: dimm !< Texture dimensions. - character(*), intent(IN):: varname !< Variable name. - real(R8P), intent(IN):: textCoo(1:NC_NN,1:dimm) !< Texture. - integer(I4P):: 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. + integer(I4P), intent(IN):: NC_NN !< Number of nodes or cells. + integer(I4P), intent(IN):: dimm !< Texture dimensions. + character(*), intent(IN):: varname !< Variable name. + real(R8P), intent(IN):: textCoo(1:NC_NN,1:dimm) !< Texture. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + character(len=maxlen):: s_buffer !< Buffer string. + integer(I4P):: rf !< Real file index. + integer(I8P):: n1,n2 !< Counters. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - select case(vtk(f)%f) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) case(ascii) - write(unit=vtk(f)%u,fmt='(A,1X,'//FI4P//',1X,A)',iostat=E_IO)'TEXTURE_COORDINATES '//trim(varname),dimm,' double' + write(unit=vtk(rf)%u,fmt='(A,1X,'//FI4P//',1X,A)',iostat=E_IO)'TEXTURE_COORDINATES '//trim(varname),dimm,' double' write(s_buffer,fmt='(I1)',iostat=E_IO)dimm s_buffer='('//trim(s_buffer)//FR4P//')' - write(unit=vtk(f)%u,fmt=trim(s_buffer),iostat=E_IO)((textCoo(n1,n2),n2=1,dimm),n1=1,NC_NN) - case(binary) + write(unit=vtk(rf)%u,fmt=trim(s_buffer),iostat=E_IO)((textCoo(n1,n2),n2=1,dimm),n1=1,NC_NN) + case(raw) write(s_buffer,fmt='(A,1X,'//FI4P//',1X,A)',iostat=E_IO)'TEXTURE_COORDINATES '//trim(varname),dimm,' double' - write(unit=vtk(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 + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + write(unit=vtk(rf)%u,iostat=E_IO)((textCoo(n1,n2),n2=1,dimm),n1=1,NC_NN) + write(unit=vtk(rf)%u,iostat=E_IO)end_rec endselect return !--------------------------------------------------------------------------------------------------------------------------------- @@ -3105,34 +5993,41 @@ contains !> 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 VTK_VAR_TEXT_R4(NC_NN,dimm,varname,textCoo,cf) result(E_IO) !--------------------------------------------------------------------------------------------------------------------------------- !! Function for saving texture variable (R4P). !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- implicit none - integer(I4P), intent(IN):: NC_NN !< Number of nodes or cells. - integer(I4P), intent(IN):: dimm !< Texture dimensions. - character(*), intent(IN):: varname !< Variable name. - real(R4P), intent(IN):: textCoo(1:NC_NN,1:dimm) !< Texture. - integer(I4P):: 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. + integer(I4P), intent(IN):: NC_NN !< Number of nodes or cells. + integer(I4P), intent(IN):: dimm !< Texture dimensions. + character(*), intent(IN):: varname !< Variable name. + real(R4P), intent(IN):: textCoo(1:NC_NN,1:dimm) !< Texture. + integer(I4P), intent(IN), optional:: cf !< Current file index (for concurrent files IO). + integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + character(len=maxlen):: s_buffer !< Buffer string. + integer(I4P):: rf !< Real file index. + integer(I8P):: n1,n2 !< Counters. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - select case(vtk(f)%f) + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + select case(vtk(rf)%f) case(ascii) - write(unit=vtk(f)%u,fmt='(A,1X,'//FI4P//',1X,A)',iostat=E_IO)'TEXTURE_COORDINATES '//trim(varname),dimm,' float' + write(unit=vtk(rf)%u,fmt='(A,1X,'//FI4P//',1X,A)',iostat=E_IO)'TEXTURE_COORDINATES '//trim(varname),dimm,' float' write(s_buffer,fmt='(I1)',iostat=E_IO)dimm s_buffer='('//trim(s_buffer)//FR4P//')' - write(unit=vtk(f)%u,fmt=trim(s_buffer),iostat=E_IO)((textCoo(n1,n2),n2=1,dimm),n1=1,NC_NN) - case(binary) + write(unit=vtk(rf)%u,fmt=trim(s_buffer),iostat=E_IO)((textCoo(n1,n2),n2=1,dimm),n1=1,NC_NN) + case(raw) write(s_buffer,fmt='(A,1X,'//FI4P//',1X,A)',iostat=E_IO)'TEXTURE_COORDINATES '//trim(varname),dimm,' float' - write(unit=vtk(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 + write(unit=vtk(rf)%u,iostat=E_IO)trim(s_buffer)//end_rec + write(unit=vtk(rf)%u,iostat=E_IO)((textCoo(n1,n2),n2=1,dimm),n1=1,NC_NN) + write(unit=vtk(rf)%u,iostat=E_IO)end_rec endselect return !--------------------------------------------------------------------------------------------------------------------------------- @@ -3152,13 +6047,19 @@ contains implicit none integer(I4P), intent(INOUT), optional:: cf !< Current file index (for concurrent files IO). integer(I4P):: E_IO !< Input/Output inquiring flag: $0$ if IO is done, $> 0$ if IO is not done. + integer(I4P):: rf !< Real file index. !--------------------------------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------------------------------- - if (present(cf)) f = cf - close(unit=vtk(f)%u,iostat=E_IO) - call vtk_update(act='remove') - if (present(cf)) cf = f + E_IO = -1_I4P + rf = f + if (present(cf)) then + rf = cf ; f = cf + endif + close(unit=vtk(rf)%u,iostat=E_IO) + call vtk_update(act='remove',cf=rf,Nvtk=Nvtk,vtk=vtk) + f = rf + if (present(cf)) cf = rf return !--------------------------------------------------------------------------------------------------------------------------------- endfunction VTK_END