common.fypp

#:mute

#! Project version number
#:set PROJECT_VERSION = "{}.{}.{}".format(PROJECT_VERSION_MAJOR, PROJECT_VERSION_MINOR, PROJECT_VERSION_PATCH)

#! Support for C_BOOL logical
#:if not defined("WITH_CBOOL")
#:set WITH_CBOOL = False
#:endif

#! Support for quadruple precision floating point numbers
#:if not defined("WITH_QP")
#:set WITH_QP = False
#:endif

#! Support for extended double precision floating point numbers
#:if not defined("WITH_XDP")
#:set WITH_XDP = False
#:endif

#! Real kinds to be considered during templating
#:set REAL_KINDS = ["sp", "dp"]
#:if WITH_XDP
#:set REAL_KINDS = REAL_KINDS + ["xdp"]
#:endif
#:if WITH_QP
#:set REAL_KINDS = REAL_KINDS + ["qp"]
#:endif

#! BLAS/LAPACK initials for each real kind
#:set REAL_INIT = ["s", "d"]
#:if WITH_XDP
#:set REAL_INIT = REAL_INIT + ["x"]
#:endif
#:if WITH_QP
#:set REAL_INIT = REAL_INIT + ["q"]
#:endif

#! Real types to be considered during templating
#:set REAL_TYPES = ["real({})".format(k) for k in REAL_KINDS]

#! Collected (kind, type) tuples for real types
#:set REAL_KINDS_TYPES = list(zip(REAL_KINDS, REAL_TYPES, REAL_INIT))

#! Complex kinds to be considered during templating
#:set CMPLX_KINDS = ["sp", "dp"]
#:if WITH_XDP
#:set CMPLX_KINDS = CMPLX_KINDS + ["xdp"]
#:endif
#:if WITH_QP
#:set CMPLX_KINDS = CMPLX_KINDS + ["qp"]
#:endif

#! BLAS/LAPACK initials for each complex kind
#:set CMPLX_INIT = ["c", "z"]
#:if WITH_XDP
#:set CMPLX_INIT = CMPLX_INIT + ["y"]
#:endif
#:if WITH_QP
#:set CMPLX_INIT = CMPLX_INIT + ["w"]
#:endif

#! Complex types to be considered during templating
#:set CMPLX_TYPES = ["complex({})".format(k) for k in CMPLX_KINDS]

#! Collected (kind, type, initial) tuples for complex types
#:set CMPLX_KINDS_TYPES = list(zip(CMPLX_KINDS, CMPLX_TYPES, CMPLX_INIT))

#! Integer kinds to be considered during templating
#:set INT_KINDS = ["int8", "int16", "int32", "int64"]

#! Integer types to be considered during templating
#:set INT_TYPES = ["integer({})".format(k) for k in INT_KINDS]

#! Collected (kind, type) tuples for integer types
#:set INT_KINDS_TYPES = list(zip(INT_KINDS, INT_TYPES))

#! Logical kinds to be considered during templating
#:set LOG_KINDS = ["lk"]
#:if WITH_CBOOL
#:set LOG_KINDS = LOG_KINDS + ["c_bool"]
#:endif

#! Logical types to be considered during templating
#:set LOG_TYPES = ["logical({})".format(k) for k in LOG_KINDS]

#! Collected (kind, type) tuples for logical types
#:set LOG_KINDS_TYPES = list(zip(LOG_KINDS, LOG_TYPES))

#! Derived type string_type
#:set STRING_KINDS = ["string_type"]

#! String types to be considered during templating
#:set STRING_TYPES = ["type({})".format(k) for k in STRING_KINDS]

#! Collected (kind, type) tuples for string derived types
#:set STRING_KINDS_TYPES = list(zip(STRING_KINDS, STRING_TYPES))

#! Derived type bitsets
#:set BITSET_KINDS = ["bitset_64", "bitset_large"]

#! Bitset types to be considered during templating
#:set BITSET_TYPES = ["type({})".format(k) for k in BITSET_KINDS]

#! Whether Fortran 90 compatible code should be generated
#:set VERSION90 = defined('VERSION90')

#! Ranks to be generated when templates are created
#:if not defined('MAXRANK')
  #:if VERSION90
    #:set MAXRANK = 7
  #:else
    #:set MAXRANK = 15
  #:endif
#:endif


#! Generates an array rank suffix.
#!
#! Args:
#!     rank (int): Rank of the variable
#!
#! Returns:
#!     Array rank suffix string (e.g. (:,:) if rank = 2)
#!
#:def ranksuffix(rank)
#{if rank > 0}#(${":" + ",:" * (rank - 1)}$)#{endif}#
#:enddef

#! Generates an empty array rank suffix.
#!
#! Args:
#!     rank (int): Rank of the variable
#!
#! Returns:
#!     Empty array rank suffix string (e.g. (0,0) if rank = 2)
#!
#:def emptyranksuffix(rank)
#{if rank > 0}#(${"0" + ",0" * (rank - 1)}$)#{endif}#
#:enddef

#! Joins stripped lines with given character string
#!
#! Args:
#!   txt (str): Text to process
#!   joinstr (str): String to use as connector
#!   prefix (str): String to add as prefix before the joined text
#!   suffix (str): String to add as suffix after the joined text
#!
#! Returns:
#!   Lines stripped and joined with the given string.
#!
#:def join_lines(txt, joinstr, prefix="", suffix="")
${prefix + joinstr.join([line.strip() for line in txt.split("\n")]) + suffix}$
#:enddef


#! Brace enclosed, comma separated Fortran expressions for a reduced shape.
#!
#! Rank of the original variable will be reduced by one. The routine generates
#! for each dimension a Fortan expression using merge(), which calculates the
#! size of the array for that dimension.
#!
#! Args:
#!   varname (str): Name of the variable to be used as origin
#!   origrank (int): Rank of the original variable
#!   idim (int): Index of the reduced dimension
#!
#! Returns:
#!   Shape expression enclosed in braces, so that it can be used as suffix to
#!   define array shapes in declarations.
#!
#:def reduced_shape(varname, origrank, idim)
  #:assert origrank > 0
  #:if origrank > 1
    #:call join_lines(joinstr=", ", prefix="(", suffix=")")
      #:for i in range(1, origrank)
        merge(size(${varname}$, ${i}$), size(${varname}$, ${i + 1}$), mask=${i}$<${idim}$)
      #:endfor
    #:endcall
  #:endif
#:enddef


#! Generates a routine name from a generic name, rank, type and kind
#!
#! Args:
#!   gname (str): Generic name
#!   rank (integer): Rank if exist
#!   type (str): Type of the input
#!   kind (str): kind of inputs variable
#!   suffix (str): other identifier (could be used for output type/kind)
#!
#! Returns:
#!   A string with a new name
#!
#:def rname(gname, rank, type, kind, suffix='')
  $:"{0}_{1}_{2}{3}_{2}{3}".format(gname, rank, type[0], kind) if suffix == '' else "{0}_{1}_{2}{3}_{4}".format(gname, rank, type[0], kind, suffix)
#:enddef


#! Generates an array rank suffix for subarrays reducing the dimension
#!
#! Args:
#!   rank (int): Rank of the original variable
#!   selectors (array): Dimension and name of the variable(s)
#!
#! Returns:
#!   Array rank suffix string enclosed in braces
#!
#! E.g.,
#!   select_subarray(5 , [(4, 'i'), (5, 'j')])}$
#!   -> (:, :, :, i, j)
#!
#:def select_subarray(rank, selectors)
  #:assert rank > 0
  #:set seldict = dict(selectors)
  #:call join_lines(joinstr=", ", prefix="(", suffix=")")
    #:for i in range(1, rank + 1)
      $:seldict.get(i, ":")
    #:endfor
  #:endcall
#:enddef

#!
#! Generates an array rank suffix for subarrays along a dimension
#!
#! Args:
#!   varname (str): Name of the variable to be used as origin
#!   rank (int): Rank of the original variable
#!   dim (int): Dimension of the variable
#!
#! Returns:
#!   Array rank suffix string enclosed in braces
#!
#! E.g.,
#!  select_subvector('j', 5, 2)
#!   -> (j1, :, j3, j4, j5)
#!
#! Used, e.g., in
#!  stdlib_stats_median.fypp
#!
#:def select_subvector(varname, rank, idim)
  #:assert rank > 0
  #:call join_lines(joinstr=", ", prefix="(", suffix=")")
    #:for i in range(1, idim)
      ${varname}$${i}$
    #:endfor
    :
    #:for i in range(idim + 1, rank + 1)
      ${varname}$${i}$
    #:endfor
  #:endcall
#:enddef

#!
#! Generates an array rank suffix for arrays
#!
#! Args:
#!   varname (str): Name of the variable to be used as origin
#!   rank (int): Rank of the original array variable
#!   idim (int): Dimension of the variable dropped
#!
#! Returns:
#!   Array rank suffix string enclosed in braces
#!
#! E.g.,
#!  reduce_subvector('j', 5, 2)
#!   -> (j1, j3, j4, j5)
#!
#! Used, e.g., in
#!  stdlib_stats_median.fypp
#!
#:def reduce_subvector(varname, rank, idim)
  #:assert rank > 0
  #:if rank > 1
    #:call join_lines(joinstr=", ", prefix="(", suffix=")")
      #:for i in range(1, idim)
        ${varname}$${i}$
      #:endfor
      #:for i in range(idim + 1, rank + 1)
        ${varname}$${i}$
      #:endfor
    #:endcall
  #:endif
#:enddef

#:endmute