From b3faff62f55bd32b2c8e3bf9ab619459e1b6558e Mon Sep 17 00:00:00 2001 From: zoziha13 <1325686572@qq.com> Date: Wed, 16 Jun 2021 13:41:45 +0800 Subject: [PATCH 1/8] add fpm support --- Makefile | 12 + fpm.toml | 18 + src/Makefile.fpm | 27 + src/fpm/f18estop.f90 | 29 + src/fpm/stdlib_ascii.f90 | 514 + src/fpm/stdlib_bitsets.f90 | 2182 ++ src/fpm/stdlib_bitsets_64.f90 | 1245 + src/fpm/stdlib_bitsets_large.f90 | 1479 + src/fpm/stdlib_error.f90 | 84 + src/fpm/stdlib_io.f90 | 991 + src/fpm/stdlib_kinds.f90 | 14 + src/fpm/stdlib_linalg.f90 | 332 + src/fpm/stdlib_linalg_diag.f90 | 592 + src/fpm/stdlib_logger.f90 | 1584 + src/fpm/stdlib_math.f90 | 84 + src/fpm/stdlib_optval.f90 | 182 + src/fpm/stdlib_quadrature.f90 | 163 + src/fpm/stdlib_quadrature_simps.f90 | 749 + src/fpm/stdlib_quadrature_trapz.f90 | 224 + src/fpm/stdlib_sorting.f90 | 727 + src/fpm/stdlib_sorting_ord_sort.f90 | 6347 ++++ src/fpm/stdlib_sorting_sort.f90 | 3188 ++ src/fpm/stdlib_sorting_sort_index.f90 | 3785 +++ src/fpm/stdlib_stats.f90 | 18055 +++++++++++ src/fpm/stdlib_stats_corr.f90 | 1201 + src/fpm/stdlib_stats_cov.f90 | 1140 + src/fpm/stdlib_stats_distribution_PRNG.f90 | 256 + src/fpm/stdlib_stats_mean.f90 | 8502 ++++++ src/fpm/stdlib_stats_moment.f90 | 19653 ++++++++++++ src/fpm/stdlib_stats_moment_all.f90 | 6167 ++++ src/fpm/stdlib_stats_moment_mask.f90 | 24283 +++++++++++++++ src/fpm/stdlib_stats_moment_scalar.f90 | 5596 ++++ src/fpm/stdlib_stats_var.f90 | 29775 +++++++++++++++++++ src/fpm/stdlib_string_type.f90 | 1272 + src/fpm/stdlib_strings.f90 | 370 + src/fpm/stdlib_system.F90 | 49 + 36 files changed, 140871 insertions(+) create mode 100644 Makefile create mode 100644 fpm.toml create mode 100644 src/Makefile.fpm create mode 100644 src/fpm/f18estop.f90 create mode 100644 src/fpm/stdlib_ascii.f90 create mode 100644 src/fpm/stdlib_bitsets.f90 create mode 100644 src/fpm/stdlib_bitsets_64.f90 create mode 100644 src/fpm/stdlib_bitsets_large.f90 create mode 100644 src/fpm/stdlib_error.f90 create mode 100644 src/fpm/stdlib_io.f90 create mode 100644 src/fpm/stdlib_kinds.f90 create mode 100644 src/fpm/stdlib_linalg.f90 create mode 100644 src/fpm/stdlib_linalg_diag.f90 create mode 100644 src/fpm/stdlib_logger.f90 create mode 100644 src/fpm/stdlib_math.f90 create mode 100644 src/fpm/stdlib_optval.f90 create mode 100644 src/fpm/stdlib_quadrature.f90 create mode 100644 src/fpm/stdlib_quadrature_simps.f90 create mode 100644 src/fpm/stdlib_quadrature_trapz.f90 create mode 100644 src/fpm/stdlib_sorting.f90 create mode 100644 src/fpm/stdlib_sorting_ord_sort.f90 create mode 100644 src/fpm/stdlib_sorting_sort.f90 create mode 100644 src/fpm/stdlib_sorting_sort_index.f90 create mode 100644 src/fpm/stdlib_stats.f90 create mode 100644 src/fpm/stdlib_stats_corr.f90 create mode 100644 src/fpm/stdlib_stats_cov.f90 create mode 100644 src/fpm/stdlib_stats_distribution_PRNG.f90 create mode 100644 src/fpm/stdlib_stats_mean.f90 create mode 100644 src/fpm/stdlib_stats_moment.f90 create mode 100644 src/fpm/stdlib_stats_moment_all.f90 create mode 100644 src/fpm/stdlib_stats_moment_mask.f90 create mode 100644 src/fpm/stdlib_stats_moment_scalar.f90 create mode 100644 src/fpm/stdlib_stats_var.f90 create mode 100644 src/fpm/stdlib_string_type.f90 create mode 100644 src/fpm/stdlib_strings.f90 create mode 100644 src/fpm/stdlib_system.F90 diff --git a/Makefile b/Makefile new file mode 100644 index 000000000..dc33c64a1 --- /dev/null +++ b/Makefile @@ -0,0 +1,12 @@ +# Fortran STDLIB Makefile for FPM BUILD +FYPPFLAGS= + +export FYPPFLAGS + +.PHONY: dev clean + +dev: + $(MAKE) -f Makefile.fpm --directory=src + +clean: + $(MAKE) -f Makefile.fpm clean --directory=src \ No newline at end of file diff --git a/fpm.toml b/fpm.toml new file mode 100644 index 000000000..1d747683b --- /dev/null +++ b/fpm.toml @@ -0,0 +1,18 @@ +name = "stdlib" +version = "fpm version 0.0.1" +license = "MIT" +author = "stdlib contributors" +maintainer = "https://github.com/fortran-lang/stdlib" +copyright = "2019-2021 forlab contributors" +description = "Fortran Standard Library" +categories = ["numerical"] +keywords = ["numerical", "stdlib"] + +# cd stdlib && make && fpm build +[library] +source-dir="src/fpm" + +[build] +auto-executables = false +auto-examples = false +auto-tests = false \ No newline at end of file diff --git a/src/Makefile.fpm b/src/Makefile.fpm new file mode 100644 index 000000000..b857b229a --- /dev/null +++ b/src/Makefile.fpm @@ -0,0 +1,27 @@ + +SRCFYPP := $(wildcard *.fypp) # Get all fypp files +SRCFYPP := $(filter-out common.fypp, $(SRCFYPP)) # Filter some individual files + +SRCF90 := $(wildcard *.f90 *.F90) # Get all f90 files +SRCF90 := $(filter-out f08estop.f90, $(SRCF90)) # Filter some individual files + +# FPMSRCDIR: Output source files path +FPMSRCDIR = fpm/ +VPATH = $(FPMSRCDIR) + +SRCGEN := $(SRCFYPP:.fypp=.f90) + +.PHONY: all clean + +all: $(SRCGEN) CPF90 + +clean: + cd $(FPMSRCDIR); $(RM) $(SRCGEN) $(SRCF90) + +# GEN F90 files to `fpm/` from FYPP files +$(SRCGEN): %.f90: %.fypp + fypp $(FYPPFLAGS) $< $(FPMSRCDIR)$@ + +# COPY F90 files to `fpm/` +CPF90: $(SRCF90) + cp -u $^ $(FPMSRCDIR) diff --git a/src/fpm/f18estop.f90 b/src/fpm/f18estop.f90 new file mode 100644 index 000000000..59fd0c97f --- /dev/null +++ b/src/fpm/f18estop.f90 @@ -0,0 +1,29 @@ +submodule (stdlib_error) estop + +implicit none + +contains + +module procedure error_stop +! Aborts the program with nonzero exit code +! +! The "stop " statement generally has return code 0. +! To allow non-zero return code termination with character message, +! error_stop() uses the statement "error stop", which by default +! has exit code 1 and prints the message to stderr. +! An optional integer return code "code" may be specified. +! +! Example +! ------- +! +! call error_stop("Invalid argument") + +if(present(code)) then + write(stderr,*) msg + error stop code +else + error stop msg +endif +end procedure + +end submodule estop diff --git a/src/fpm/stdlib_ascii.f90 b/src/fpm/stdlib_ascii.f90 new file mode 100644 index 000000000..5fb529828 --- /dev/null +++ b/src/fpm/stdlib_ascii.f90 @@ -0,0 +1,514 @@ + +!> The `stdlib_ascii` module provides procedures for handling and manipulating +!> intrinsic character variables and constants. +!> +!> The specification of this module is available [here](../page/specs/stdlib_ascii.html). +module stdlib_ascii + use stdlib_kinds, only : int8, int16, int32, int64, lk, c_bool + + implicit none + private + + ! Character validation functions + public :: is_alpha, is_alphanum + public :: is_digit, is_hex_digit, is_octal_digit + public :: is_control, is_white, is_blank + public :: is_ascii, is_punctuation + public :: is_graphical, is_printable + public :: is_lower, is_upper + + ! Character conversion functions + public :: to_lower, to_upper, to_title, to_sentence, reverse + public :: to_string + + !> Version: experimental + !> + !> Create a character string representing the value of the provided variable. + interface to_string + module procedure :: to_string_integer_int8 + module procedure :: to_string_integer_int16 + module procedure :: to_string_integer_int32 + module procedure :: to_string_integer_int64 + module procedure :: to_string_logical_lk + module procedure :: to_string_logical_c_bool + end interface to_string + + ! All control characters in the ASCII table (see www.asciitable.com). + character(len=1), public, parameter :: NUL = achar(int(z'00')) !! Null + character(len=1), public, parameter :: SOH = achar(int(z'01')) !! Start of heading + character(len=1), public, parameter :: STX = achar(int(z'02')) !! Start of text + character(len=1), public, parameter :: ETX = achar(int(z'03')) !! End of text + character(len=1), public, parameter :: EOT = achar(int(z'04')) !! End of transmission + character(len=1), public, parameter :: ENQ = achar(int(z'05')) !! Enquiry + character(len=1), public, parameter :: ACK = achar(int(z'06')) !! Acknowledge + character(len=1), public, parameter :: BEL = achar(int(z'07')) !! Bell + character(len=1), public, parameter :: BS = achar(int(z'08')) !! Backspace + character(len=1), public, parameter :: TAB = achar(int(z'09')) !! Horizontal tab + character(len=1), public, parameter :: LF = achar(int(z'0A')) !! NL line feed, new line + character(len=1), public, parameter :: VT = achar(int(z'0B')) !! Vertical tab + character(len=1), public, parameter :: FF = achar(int(z'0C')) !! NP form feed, new page + character(len=1), public, parameter :: CR = achar(int(z'0D')) !! Carriage return + character(len=1), public, parameter :: SO = achar(int(z'0E')) !! Shift out + character(len=1), public, parameter :: SI = achar(int(z'0F')) !! Shift in + character(len=1), public, parameter :: DLE = achar(int(z'10')) !! Data link escape + character(len=1), public, parameter :: DC1 = achar(int(z'11')) !! Device control 1 + character(len=1), public, parameter :: DC2 = achar(int(z'12')) !! Device control 2 + character(len=1), public, parameter :: DC3 = achar(int(z'13')) !! Device control 3 + character(len=1), public, parameter :: DC4 = achar(int(z'14')) !! Device control 4 + character(len=1), public, parameter :: NAK = achar(int(z'15')) !! Negative acknowledge + character(len=1), public, parameter :: SYN = achar(int(z'16')) !! Synchronous idle + character(len=1), public, parameter :: ETB = achar(int(z'17')) !! End of transmission block + character(len=1), public, parameter :: CAN = achar(int(z'18')) !! Cancel + character(len=1), public, parameter :: EM = achar(int(z'19')) !! End of medium + character(len=1), public, parameter :: SUB = achar(int(z'1A')) !! Substitute + character(len=1), public, parameter :: ESC = achar(int(z'1B')) !! Escape + character(len=1), public, parameter :: FS = achar(int(z'1C')) !! File separator + character(len=1), public, parameter :: GS = achar(int(z'1D')) !! Group separator + character(len=1), public, parameter :: RS = achar(int(z'1E')) !! Record separator + character(len=1), public, parameter :: US = achar(int(z'1F')) !! Unit separator + character(len=1), public, parameter :: DEL = achar(int(z'7F')) !! Delete + + ! Constant character sequences + character(len=*), public, parameter :: fullhex_digits = "0123456789ABCDEFabcdef" !! 0 .. 9A .. Fa .. f + character(len=*), public, parameter :: hex_digits = fullhex_digits(1:16) !! 0 .. 9A .. F + character(len=*), public, parameter :: lowerhex_digits = "0123456789abcdef" !! 0 .. 9a .. f + character(len=*), public, parameter :: digits = hex_digits(1:10) !! 0 .. 9 + character(len=*), public, parameter :: octal_digits = digits(1:8) !! 0 .. 7 + character(len=*), public, parameter :: letters = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" !! A .. Za .. z + character(len=*), public, parameter :: uppercase = letters(1:26) !! A .. Z + character(len=*), public, parameter :: lowercase = letters(27:) !! a .. z + character(len=*), public, parameter :: whitespace = " "//TAB//VT//CR//LF//FF !! ASCII _whitespace + + + !> Returns a new character sequence which is the lower case + !> version of the input character sequence + !> This method is pure and returns a character sequence + interface to_lower + module procedure :: to_lower + end interface to_lower + + !> Returns a new character sequence which is the upper case + !> version of the input character sequence + !> This method is pure and returns a character sequence + interface to_upper + module procedure :: to_upper + end interface to_upper + + !> Returns a new character sequence which is the title case + !> version of the input character sequence + !> This method is pure and returns a character sequence + interface to_title + module procedure :: to_title + end interface to_title + + !> Returns a new character sequence which is the sentence case + !> version of the input character sequence + !> This method is pure and returns a character sequence + interface to_sentence + module procedure :: to_sentence + end interface to_sentence + + !> Returns a new character sequence which is reverse of + !> the input charater sequence + !> This method is pure and returns a character sequence + interface reverse + module procedure :: reverse + end interface reverse + + +contains + + !> Checks whether `c` is an ASCII letter (A .. Z, a .. z). + pure logical function is_alpha(c) + character(len=1), intent(in) :: c !! The character to test. + is_alpha = (c >= 'A' .and. c <= 'Z') .or. (c >= 'a' .and. c <= 'z') + end function + + !> Checks whether `c` is a letter or a number (0 .. 9, a .. z, A .. Z). + pure logical function is_alphanum(c) + character(len=1), intent(in) :: c !! The character to test. + is_alphanum = (c >= '0' .and. c <= '9') .or. (c >= 'a' .and. c <= 'z') & + .or. (c >= 'A' .and. c <= 'Z') + end function + + !> Checks whether or not `c` is in the ASCII character set - + !> i.e. in the range 0 .. 0x7F. + pure logical function is_ascii(c) + character(len=1), intent(in) :: c !! The character to test. + is_ascii = iachar(c) <= int(z'7F') + end function + + !> Checks whether `c` is a control character. + pure logical function is_control(c) + character(len=1), intent(in) :: c !! The character to test. + integer :: ic + ic = iachar(c) + is_control = ic < int(z'20') .or. ic == int(z'7F') + end function + + !> Checks whether `c` is a digit (0 .. 9). + pure logical function is_digit(c) + character(len=1), intent(in) :: c !! The character to test. + is_digit = ('0' <= c) .and. (c <= '9') + end function + + !> Checks whether `c` is a digit in base 8 (0 .. 7). + pure logical function is_octal_digit(c) + character(len=1), intent(in) :: c !! The character to test. + is_octal_digit = (c >= '0') .and. (c <= '7'); + end function + + !> Checks whether `c` is a digit in base 16 (0 .. 9, A .. F, a .. f). + pure logical function is_hex_digit(c) + character(len=1), intent(in) :: c !! The character to test. + is_hex_digit = (c >= '0' .and. c <= '9') .or. (c >= 'a' .and. c <= 'f') & + .or. (c >= 'A' .and. c <= 'F') + end function + + !> Checks whether or not `c` is a punctuation character. That includes + !> all ASCII characters which are not control characters, letters, + !> digits, or whitespace. + pure logical function is_punctuation(c) + character(len=1), intent(in) :: c !! The character to test. + integer :: ic + ic = iachar(c) ! '~' '!' + is_punctuation = (ic <= int(z'7E')) .and. (ic >= int(z'21')) .and. & + (.not. is_alphanum(c)) + end function + + !> Checks whether or not `c` is a printable character other than the + !> space character. + pure logical function is_graphical(c) + character(len=1), intent(in) :: c !! The character to test. + integer :: ic + ic = iachar(c) + !The character is graphical if it's between '!' and '~' in the ASCII table, + !that is: printable but not a space + is_graphical = (int(z'21') <= ic) .and. (ic <= int(z'7E')) + end function + + !> Checks whether or not `c` is a printable character - including the + !> space character. + pure logical function is_printable(c) + character(len=1), intent(in) :: c !! The character to test. + integer :: ic + ic = iachar(c) + !The character is printable if it's between ' ' and '~' in the ASCII table + is_printable = ic >= iachar(' ') .and. ic <= int(z'7E') + end function + + !> Checks whether `c` is a lowercase ASCII letter (a .. z). + pure logical function is_lower(c) + character(len=1), intent(in) :: c !! The character to test. + integer :: ic + ic = iachar(c) + is_lower = ic >= iachar('a') .and. ic <= iachar('z') + end function + + !> Checks whether `c` is an uppercase ASCII letter (A .. Z). + pure logical function is_upper(c) + character(len=1), intent(in) :: c !! The character to test. + is_upper = (c >= 'A') .and. (c <= 'Z') + end function + + !> Checks whether or not `c` is a whitespace character. That includes the + !> space, tab, vertical tab, form feed, carriage return, and linefeed + !> characters. + pure logical function is_white(c) + character(len=1), intent(in) :: c !! The character to test. + integer :: ic + ic = iachar(c) ! TAB, LF, VT, FF, CR + is_white = (c == ' ') .or. (ic >= int(z'09') .and. ic <= int(z'0D')); + end function + + !> Checks whether or not `c` is a blank character. That includes the + !> only the space and tab characters + pure logical function is_blank(c) + character(len=1), intent(in) :: c !! The character to test. + integer :: ic + ic = iachar(c) ! TAB + is_blank = (c == ' ') .or. (ic == int(z'09')); + end function + + !> Returns the corresponding lowercase letter, if `c` is an uppercase + !> ASCII character, otherwise `c` itself. + pure function char_to_lower(c) result(t) + character(len=1), intent(in) :: c !! A character. + character(len=1) :: t + integer :: k + + k = index( uppercase, c ) + + if ( k > 0 ) then + t = lowercase(k:k) + else + t = c + endif + end function char_to_lower + + !> Returns the corresponding uppercase letter, if `c` is a lowercase + !> ASCII character, otherwise `c` itself. + pure function char_to_upper(c) result(t) + character(len=1), intent(in) :: c !! A character. + character(len=1) :: t + integer :: k + + k = index( lowercase, c ) + + if ( k > 0 ) then + t = uppercase(k:k) + else + t = c + endif + end function char_to_upper + + !> Convert character variable to lower case + !> ([Specification](../page/specs/stdlib_ascii.html#to_lower)) + !> + !> Version: experimental + pure function to_lower(string) result(lower_string) + character(len=*), intent(in) :: string + character(len=len(string)) :: lower_string + integer :: i + + do i = 1, len(string) + lower_string(i:i) = char_to_lower(string(i:i)) + end do + + end function to_lower + + !> Convert character variable to upper case + !> ([Specification](../page/specs/stdlib_ascii.html#to_upper)) + !> + !> Version: experimental + pure function to_upper(string) result(upper_string) + character(len=*), intent(in) :: string + character(len=len(string)) :: upper_string + integer :: i + + do i = 1, len(string) + upper_string(i:i) = char_to_upper(string(i:i)) + end do + + end function to_upper + + !> Converts character sequence to title case + !> ([Specification](../page/specs/stdlib_ascii.html#to_title)) + !> + !> Version: experimental + pure function to_title(string) result(title_string) + character(len=*), intent(in) :: string + character(len=len(string)) :: title_string + integer :: i + logical :: capitalize_switch + + capitalize_switch = .true. + do i = 1, len(string) + if (is_alphanum(string(i:i))) then + if (capitalize_switch) then + title_string(i:i) = char_to_upper(string(i:i)) + capitalize_switch = .false. + else + title_string(i:i) = char_to_lower(string(i:i)) + end if + else + title_string(i:i) = string(i:i) + capitalize_switch = .true. + end if + end do + + end function to_title + + !> Converts character sequence to sentence case + !> ([Specification](../page/specs/stdlib_ascii.html#to_sentence)) + !> + !> Version: experimental + pure function to_sentence(string) result(sentence_string) + character(len=*), intent(in) :: string + character(len=len(string)) :: sentence_string + integer :: i, n + + n = len(string) + do i = 1, len(string) + if (is_alphanum(string(i:i))) then + sentence_string(i:i) = char_to_upper(string(i:i)) + n = i + exit + else + sentence_string(i:i) = string(i:i) + end if + end do + + do i = n + 1, len(string) + sentence_string(i:i) = char_to_lower(string(i:i)) + end do + + end function to_sentence + + !> Reverse the character order in the input character variable + !> ([Specification](../page/specs/stdlib_ascii.html#reverse)) + !> + !> Version: experimental + pure function reverse(string) result(reverse_string) + character(len=*), intent(in) :: string + character(len=len(string)) :: reverse_string + integer :: i, n + + n = len(string) + do i = 1, n + reverse_string(n-i+1:n-i+1) = string(i:i) + end do + + end function reverse + + !> Represent an integer of kind int8 as character sequence + pure function to_string_integer_int8(val) result(string) + integer, parameter :: ik = int8 + integer(ik), intent(in) :: val + character(len=:), allocatable :: string + integer, parameter :: buffer_len = range(val)+2 + character(len=buffer_len) :: buffer + integer :: pos + integer(ik) :: n + character(len=1), parameter :: numbers(0:9) = & + ["0", "1", "2", "3", "4", "5", "6", "7", "8", "9"] + + if (val == 0_ik) then + string = numbers(0) + return + end if + + n = abs(val) + buffer = "" + + pos = buffer_len + 1 + do while (n > 0_ik) + pos = pos - 1 + buffer(pos:pos) = numbers(mod(n, 10_ik)) + n = n/10_ik + end do + if (val < 0_ik) then + pos = pos - 1 + buffer(pos:pos) = '-' + end if + + string = buffer(pos:) + end function to_string_integer_int8 + !> Represent an integer of kind int16 as character sequence + pure function to_string_integer_int16(val) result(string) + integer, parameter :: ik = int16 + integer(ik), intent(in) :: val + character(len=:), allocatable :: string + integer, parameter :: buffer_len = range(val)+2 + character(len=buffer_len) :: buffer + integer :: pos + integer(ik) :: n + character(len=1), parameter :: numbers(0:9) = & + ["0", "1", "2", "3", "4", "5", "6", "7", "8", "9"] + + if (val == 0_ik) then + string = numbers(0) + return + end if + + n = abs(val) + buffer = "" + + pos = buffer_len + 1 + do while (n > 0_ik) + pos = pos - 1 + buffer(pos:pos) = numbers(mod(n, 10_ik)) + n = n/10_ik + end do + if (val < 0_ik) then + pos = pos - 1 + buffer(pos:pos) = '-' + end if + + string = buffer(pos:) + end function to_string_integer_int16 + !> Represent an integer of kind int32 as character sequence + pure function to_string_integer_int32(val) result(string) + integer, parameter :: ik = int32 + integer(ik), intent(in) :: val + character(len=:), allocatable :: string + integer, parameter :: buffer_len = range(val)+2 + character(len=buffer_len) :: buffer + integer :: pos + integer(ik) :: n + character(len=1), parameter :: numbers(0:9) = & + ["0", "1", "2", "3", "4", "5", "6", "7", "8", "9"] + + if (val == 0_ik) then + string = numbers(0) + return + end if + + n = abs(val) + buffer = "" + + pos = buffer_len + 1 + do while (n > 0_ik) + pos = pos - 1 + buffer(pos:pos) = numbers(mod(n, 10_ik)) + n = n/10_ik + end do + if (val < 0_ik) then + pos = pos - 1 + buffer(pos:pos) = '-' + end if + + string = buffer(pos:) + end function to_string_integer_int32 + !> Represent an integer of kind int64 as character sequence + pure function to_string_integer_int64(val) result(string) + integer, parameter :: ik = int64 + integer(ik), intent(in) :: val + character(len=:), allocatable :: string + integer, parameter :: buffer_len = range(val)+2 + character(len=buffer_len) :: buffer + integer :: pos + integer(ik) :: n + character(len=1), parameter :: numbers(0:9) = & + ["0", "1", "2", "3", "4", "5", "6", "7", "8", "9"] + + if (val == 0_ik) then + string = numbers(0) + return + end if + + n = abs(val) + buffer = "" + + pos = buffer_len + 1 + do while (n > 0_ik) + pos = pos - 1 + buffer(pos:pos) = numbers(mod(n, 10_ik)) + n = n/10_ik + end do + if (val < 0_ik) then + pos = pos - 1 + buffer(pos:pos) = '-' + end if + + string = buffer(pos:) + end function to_string_integer_int64 + + !> Represent an logical of kind lk as character sequence + pure function to_string_logical_lk(val) result(string) + integer, parameter :: ik = lk + logical(ik), intent(in) :: val + character(len=1) :: string + + string = merge("T", "F", val) + end function to_string_logical_lk + !> Represent an logical of kind c_bool as character sequence + pure function to_string_logical_c_bool(val) result(string) + integer, parameter :: ik = c_bool + logical(ik), intent(in) :: val + character(len=1) :: string + + string = merge("T", "F", val) + end function to_string_logical_c_bool + +end module stdlib_ascii diff --git a/src/fpm/stdlib_bitsets.f90 b/src/fpm/stdlib_bitsets.f90 new file mode 100644 index 000000000..4595471d1 --- /dev/null +++ b/src/fpm/stdlib_bitsets.f90 @@ -0,0 +1,2182 @@ +module stdlib_bitsets +!! Implements zero based bitsets of size up to `huge(0_int32)`. +!! The current code uses 64 bit integers to store the bits and uses all 64 bits. +!! The code assumes two's complement integers, and treats negative integers as +!! having the sign bit set. +!!([Specification](../page/specs/stdlib_bitsets.html)) + + use :: stdlib_kinds, only: & + bits_kind => int32, & ! If changed change also max_digits, and + block_kind => int64, & ! overflow_bits + int8, & + int16, & + int32, & + int64 + + use, intrinsic :: & + iso_fortran_env, only: & + error_unit + + implicit none + + private + + integer(bits_kind), parameter :: & + block_size = bit_size(0_block_kind) + + public :: max_digits, overflow_bits + integer, parameter :: & + max_digits = 10 ! bits_kind == int32 +! max_digits = 19 ! bits_kind == int64 + + integer(bits_kind), parameter :: & + overflow_bits = 2_bits_kind**30/5 ! bits_kind == int32 +! overflow_bits = 2_bits_kind**62/5 ! bits_kind == int64 + + integer(block_kind), parameter :: all_zeros = 0_block_kind + integer(block_kind), parameter :: all_ones = not(all_zeros) + + character(*), parameter :: module_name = "STDLIB_BITSETS" + integer, parameter :: & + ia0 = iachar('0'), & + ia9 = iachar('9') + + integer, parameter, public :: success = 0 +!! Error flag indicating no errors + integer, parameter, public :: alloc_fault = 1 +!! Error flag indicating a memory allocation failure + integer, parameter, public :: array_size_invalid_error = 2 +!! Error flag indicating an invalid bits value + integer, parameter, public :: char_string_invalid_error = 3 +!! Error flag indicating an invalid character string + integer, parameter, public :: char_string_too_large_error = 4 +!! Error flag indicating a too large character string + integer, parameter, public :: char_string_too_small_error = 5 +!! Error flag indicating a too small character string + integer, parameter, public :: eof_failure = 6 +!! Error flag indicating unexpected End-of-File on a READ + integer, parameter, public :: index_invalid_error = 7 +!! Error flag indicating an invalid index + integer, parameter, public :: integer_overflow_error = 8 +!! Error flag indicating integer overflow + integer, parameter, public :: read_failure = 9 +!! Error flag indicating failure of a READ statement + integer, parameter, public :: write_failure = 10 +!! Error flag indicating a failure on a WRITE statement + + public :: bits_kind +! Public constant + + public :: & + bitset_type, & + bitset_large, & + bitset_64 + +! Public types + + public :: & + assignment(=), & + and, & + and_not, & + bits, & + extract, & + operator(==), & + operator(/=), & + operator(>), & + operator(>=), & + operator(<), & + operator(<=), & + or, & + xor +!! Public procedures + + public :: error_handler + + type, abstract :: bitset_type +!! version: experimental +!! +!! Parent type for bitset_64 and bitset_large ([Specification](../page/specs/stdlib_bitsets.html#the-stdlib_bitsets-derived-types)) + + private + integer(bits_kind) :: num_bits + + contains + + procedure(all_abstract), deferred, pass(self) :: all + procedure(any_abstract), deferred, pass(self) :: any + procedure(bit_count_abstract), deferred, pass(self) :: bit_count + procedure, pass(self) :: bits + procedure(clear_bit_abstract), deferred, pass(self) :: clear_bit + procedure(clear_range_abstract), deferred, pass(self) :: clear_range + generic :: clear => clear_bit, clear_range + procedure(flip_bit_abstract), deferred, pass(self) :: flip_bit + procedure(flip_range_abstract), deferred, pass(self) :: flip_range + generic :: flip => flip_bit, flip_range + procedure(from_string_abstract), deferred, pass(self) :: from_string + procedure(init_zero_abstract), deferred, pass(self) :: init_zero + generic :: init => init_zero + procedure(input_abstract), deferred, pass(self) :: input + procedure(none_abstract), deferred, pass(self) :: none + procedure(not_abstract), deferred, pass(self) :: not + procedure(output_abstract), deferred, pass(self) :: output + procedure(read_bitset_string_abstract), deferred, pass(self) :: & + read_bitset_string + procedure(read_bitset_unit_abstract), deferred, pass(self) :: & + read_bitset_unit + generic :: read_bitset => read_bitset_string, read_bitset_unit + procedure(set_bit_abstract), deferred, pass(self) :: set_bit + procedure(set_range_abstract), deferred, pass(self) :: set_range + generic :: set => set_bit, set_range + procedure(test_abstract), deferred, pass(self) :: test + procedure(to_string_abstract), deferred, pass(self) :: to_string + procedure(value_abstract), deferred, pass(self) :: value + procedure(write_bitset_string_abstract), deferred, pass(self) :: & + write_bitset_string + procedure(write_bitset_unit_abstract), deferred, pass(self) :: & + write_bitset_unit + generic :: write_bitset => write_bitset_string, write_bitset_unit + + end type bitset_type + + + abstract interface + + elemental function all_abstract( self ) result(all) +!! Version: experimental +!! +!! Returns `.true.` if all bits in `self` are 1, `.false.` otherwise. +!! +!!#### Example +!! +!!```fortran +!! program demo_all +!! use stdlib_bitsets +!! character(*), parameter :: & +!! bits_all = '111111111111111111111111111111111' +!! type(bitset_64) :: set0 +!! call set0 % from_string( bits_all ) +!! if ( bits(set0) /= 33 ) then +!! error stop "FROM_STRING failed to interpret " // & +!! 'BITS_ALL's size properly." +!! else if ( .not. set0 % all() ) then +!! error stop "FROM_STRING failed to interpret" // & +!! "BITS_ALL's value properly." +!! else +!! write(*,*) "FROM_STRING transferred BITS_ALL properly" // & +!! " into set0." +!! end if +!! end program demo_all +!!``` + import :: bitset_type + logical :: all + class(bitset_type), intent(in) :: self + end function all_abstract + + elemental function any_abstract(self) result(any) +!! Version: experimental +!! +!! Returns `.true.` if any bit in `self` is 1, `.false.` otherwise. +!! +!!#### Example +!! +!!```fortran +!! program demo_any +!! use stdlib_bitsets +!! character(*), parameter :: & +!! bits_0 = '0000000000000000000' +!! type(bitset_64) :: set0 +!! call set0 % from_string( bits_0 ) +!! if ( .not. set0 % any() ) then +!! write(*,*) "FROM_STRING interpreted " // & +!! "BITS_0's value properly." +!! end if +!! call set0 % set(5) +!! if ( set0 % any() ) then +!! write(*,*) "ANY interpreted SET0's value properly." +!! end if +!! end program demo_any +!!``` + import :: bitset_type + logical :: any + class(bitset_type), intent(in) :: self + end function any_abstract + + elemental function bit_count_abstract(self) result(bit_count) +!! Version: experimental +!! +!! Returns the number of non-zero bits in `self`. +!! +!!#### Example +!! +!!```fortran +!! program demo_bit_count +!! use stdlib_bitsets +!! character(*), parameter :: & +!! bits_0 = '0000000000000000000' +!! type(bitset_64) :: set0 +!! call set0 % from_string( bits_0 ) +!! if ( set0 % bit_count() == 0 ) then +!! write(*,*) "FROM_STRING interpreted " // & +!! "BITS_0's value properly." +!! end if +!! call set0 % set(5) +!! if ( set0 % bit_count() == 1 ) then +!! write(*,*) "BIT_COUNT interpreted SET0's value properly." +!! end if +!! end program demo_bit_count +!!``` + import :: bitset_type, bits_kind + integer(bits_kind) :: bit_count + class(bitset_type), intent(in) :: self + end function bit_count_abstract + + elemental subroutine clear_bit_abstract(self, pos) +!! Version: experimental +!! +!! Sets to zero the `pos` position in `self`. If `pos` is less than zero or +!! greater than `bits(self)-1` it is ignored. +!! +!!#### Example +!! +!!```fortran +!! program demo_clear +!! use stdlib_bitsets +!! type(bitset_large) :: set0 +!! call set0 % init(166) +!! call set0 % not() +!! if ( set0 % all() ) write(*,*) 'SET0 is properly initialized.' +!! call set0 % clear(165) +!! if ( .not. set0 % test(165) ) write(*,*) 'Bit 165 is cleared.' +!! call set0 % clear(0,164) +!! if ( set0 % none() ) write(*,*) 'All bits are cleared.' +!! end program demo_clear +!!``` + import :: bitset_type, bits_kind + class(bitset_type), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + end subroutine clear_bit_abstract + + pure subroutine clear_range_abstract(self, start_pos, stop_pos) +!! Version: experimental +!! +!! Sets to zero all bits from the `start_pos` to `stop_pos` positions in `set`. +!! If `stop_pos < start_pos` then no bits are modified. Positions outside +!! the range 0 to `bits(self)-1` are ignored. + import :: bitset_type, bits_kind + class(bitset_type), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + end subroutine clear_range_abstract + + elemental subroutine flip_bit_abstract(self, pos) +!! Version: experimental +!! +!! Flips the value at the `pos` position in `self`, provided the position is +!! valid. If `pos` is less than 0 or greater than `bits(self)-1`, no value is +!! changed. +!! +!!#### Example +!! +!!```fortran +!! program demo_flip +!! use stdlib_bitsets +!! type(bitset_large) :: set0 +!! call set0 % init(166) +!! if ( set0 % none() ) write(*,*) 'SET0 is properly initialized.' +!! call set0 % flip(165) +!! if ( set0 % test(165) ) write(*,*) 'Bit 165 is flipped.' +!! call set0 % flip(0,164) +!! if ( set0 % all() ) write(*,*) 'All bits are flipped.' +!! end program demo_flip +!!``` + import :: bitset_type, bits_kind + class(bitset_type), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + end subroutine flip_bit_abstract + + pure subroutine flip_range_abstract(self, start_pos, stop_pos) +!! Version: experimental +!! +!! Flips all valid bits from the `start_pos` to the `stop_pos` positions in +!! `self`. If `stop_pos < start_pos` no bits are flipped. Positions less than +!! 0 or greater than `bits(self)-1` are ignored. + import :: bitset_type, bits_kind + class(bitset_type), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + end subroutine flip_range_abstract + + subroutine from_string_abstract(self, string, status) +!! Version: experimental +!! +!! Initializes the bitset `self` treating `string` as a binary literal +!! `status` may have the values: +!! * `success` - if no problems were found, +!! * `alloc_fault` - if allocation of the bitset failed +!! * `char_string_too_large_error` - if `string` was too large, or +!! * `char_string_invalid_error` - if string had an invalid character. +!! +!!#### Example +!! +!!```fortran +!! program demo_from_string +!! use stdlib_bitsets +!! character(*), parameter :: & +!! bits_all = '111111111111111111111111111111111' +!! type(bitset_64) :: set0 +!! call set0 % from_string( bits_all ) +!! if ( bits(set0) /= 33 ) then +!! error stop "FROM_STRING failed to interpret " // & +!! 'BITS_ALL's size properly." +!! else if ( .not. set0 % all() ) then +!! error stop "FROM_STRING failed to interpret" // & +!! "BITS_ALL's value properly." +!! else +!! write(*,*) "FROM_STRING transferred BITS_ALL properly" // & +!! " into set0." +!! end if +!! end program demo_from_string +!!``` + import :: bitset_type + class(bitset_type), intent(out) :: self + character(*), intent(in) :: string + integer, intent(out), optional :: status + end subroutine from_string_abstract + + subroutine init_zero_abstract(self, bits, status) +!! Creates the bitset, `self`, of size `bits`, with all bits initialized to +!! zero. `bits` must be non-negative. If an error occurs and `status` is +!! absent then processing stops with an informative stop code. `status` +!! will have one of the values; +!! * `success` - if no problems were found, +!! * `alloc_fault` - if memory allocation failed +!! * `array_size_invalid_error` - if `bits` is either negative or larger +!! than 64 with `self` of class `bitset_64`, or +!! +!!#### Example +!! +!!```fortran +!! program demo_init +!! use stdlib_bitsets +!! type(bitset_large) :: set0 +!! call set0 % init(166) +!! if ( set0 % bits() == 166 ) & +!! write(*,*) `SET0 has the proper size.' +!! if ( set0 % none() ) write(*,*) 'SET0 is properly initialized.' +!! end program demo_init +!!``` + import :: bitset_type, bits_kind + class(bitset_type), intent(out) :: self + integer(bits_kind), intent(in) :: bits + integer, intent(out), optional :: status + end subroutine init_zero_abstract + + subroutine input_abstract(self, unit, status) +!! Version: experimental +!! +!! Reads the components of the bitset, `self`, from the unformatted I/O +!! unit, `unit`, assuming that the components were written using `output`. +!! If an error occurs and `status` is absent then processing stops with +!! an informative stop code. `status` has one of the values: +!! * `success` - if no problem was found +!! * `alloc_fault` - if it failed allocating memory for `self`, or +!! * `array_size_invalid_error` if the `bits(self)` in `unit` is negative +!! or greater than 64 for a `bitset_64` input. +!! * `read_failure` - if it failed during the reads from `unit` +!! +!!#### Example +!! +!!```fortran +!! program demo_input +!! character(*), parameter :: & +!! bits_0 = '000000000000000000000000000000000', & +!! bits_1 = '000000000000000000000000000000001', & +!! bits_33 = '100000000000000000000000000000000' +!! integer :: unit +!! type(bitset_64) :: set0, set1, set2, set3, set4, set5 +!! call set0 % from_string( bits_0 ) +!! call set1 % from_string( bits_1 ) +!! call set2 % from_string( bits_33 ) +!! open( newunit=unit, file='test.bin', status='replace', & +!! form='unformatted', action='write' ) +!! call set2 % output(unit) +!! call set1 % output(unit) +!! call set0 % output(unit) +!! close( unit ) +!! open( newunit=unit, file='test.bin', status='old', & +!! form='unformatted', action='read' ) +!! call set5 % input(unit) +!! call set4 % input(unit) +!! call set3 % input(unit) +!! close( unit ) +!! if ( set3 /= set0 .or. set4 /= set1 .or. set5 /= set2 ) then +!! error stop 'Transfer to and from units using ' // & +!! ' output and input failed.' +!! else +!! write(*,*) 'Transfer to and from units using ' // & +!! 'output and input succeeded.' +!! end if +!! end program demo_input +!!``` + import :: bitset_type + class(bitset_type), intent(out) :: self + integer, intent(in) :: unit + integer, intent(out), optional :: status + end subroutine input_abstract + + elemental function none_abstract(self) result(none) +!! Version: experimental +!! +!! Returns `.true.` if none of the bits in `self` have the value 1. +!! +!!#### Example +!! +!!```fortran +!! program demo_none +!! use stdlib_bitsets +!! character(*), parameter :: & +!! bits_0 = '0000000000000000000' +!! type(bitset_large) :: set0 +!! call set0 % from_string( bits_0 ) +!! if ( set0 % none() ) then +!! write(*,*) "FROM_STRING interpreted " // & +!! "BITS_0's value properly." +!! end if +!! call set0 % set(5) +!! if ( .not. set0 % none() ) then +!! write(*,*) "NONE interpreted SET0's value properly." +!! end if +!! end program demo_none +!!``` + import :: bitset_type + logical :: none + class(bitset_type), intent(in) :: self + end function none_abstract + + elemental subroutine not_abstract(self) +!! Version: experimental +!! +!! Sets the bits in `self` to their logical complement +!! +!!#### Example +!! +!!```fortran +!! program demo_not +!! use stdlib_bitsets +!! type(bitset_large) :: set0 +!! call set0 % init( 155 ) +!! if ( set0 % none() ) then +!! write(*,*) "FROM_STRING interpreted " // & +!! "BITS_0's value properly." +!! end if +!! call set0 % not() +!! if ( set0 % all() ) then +!! write(*,*) "ALL interpreted SET0's value properly." +!! end if +!! end program demo_not +!!``` + import :: bitset_type + class(bitset_type), intent(inout) :: self + end subroutine not_abstract + + subroutine output_abstract(self, unit, status) +!! Version: experimental +!! +!! Writes the components of the bitset, `self`, to the unformatted I/O +!! unit, `unit`, in a unformatted sequence compatible with `input`. If +!! `status` is absent an error results in an error stop with an +!! informative stop code. If `status` is present it has the default +!! value of `success`, or the value `write_failure` if the write failed. +!! +!!#### Example +!! +!!```fortran +!! program demo_output +!! character(*), parameter :: & +!! bits_0 = '000000000000000000000000000000000', & +!! bits_1 = '000000000000000000000000000000001', & +!! bits_33 = '100000000000000000000000000000000' +!! integer :: unit +!! type(bitset_64) :: set0, set1, set2, set3, set4, set5 +!! call set0 % from_string( bits_0 ) +!! call set1 % from_string( bits_1 ) +!! call set2 % from_string( bits_33 ) +!! open( newunit=unit, file='test.bin', status='replace', & +!! form='unformatted', action='write' ) +!! call set2 % output(unit) +!! call set1 % output(unit) +!! call set0 % output(unit) +!! close( unit ) +!! open( newunit=unit, file='test.bin', status='old', & +!! form='unformatted', action='read' ) +!! call set5 % input(unit) +!! call set4 % input(unit) +!! call set3 % input(unit) +!! close( unit ) +!! if ( set3 /= set0 .or. set4 /= set1 .or. set5 /= set2 ) then +!! error stop 'Transfer to and from units using ' // & +!! ' output and input failed.' +!! else +!! write(*,*) 'Transfer to and from units using ' // & +!! 'output and input succeeded.' +!! end if +!! end program demo_output +!!``` + import :: bitset_type + class(bitset_type), intent(in) :: self + integer, intent(in) :: unit + integer, intent(out), optional :: status + end subroutine output_abstract + + subroutine read_bitset_string_abstract(self, string, status) +!! Version: experimental +!! +!! Uses the bitset literal in the default character `string`, to define +!! the bitset, `self`. The literal may be preceded by an an arbitrary +!! sequence of blank characters. If `status` is absent an error results +!! in an error stop with an informative stop code. If `status` +!! is present it has one of the values +!! * `success` - if no problems occurred, +!! * `alloc_fault` - if allocation of memory for SELF failed, +!! * `array_size_invalid_error - if `bits(self)` in `string` is greater +!! than 64 for a `bitset_64`, +!! * `char_string_invalid_error` - if the bitset literal has an invalid +!! character, +!! * `char_string_too_small_error - if the string ends before all the bits +!! are read. +!! * `integer_overflow_error` - if the bitset literal has a `bits(self)` +!! value too large to be represented, +!! +!!#### Example +!! +!!```fortran +!! program demo_read_bitset +!! character(*), parameter :: & +!! bits_0 = 'S33B000000000000000000000000000000000', & +!! bits_1 = 'S33B000000000000000000000000000000001', & +!! bits_33 = 'S33B100000000000000000000000000000000' +!! character(:), allocatable :: test_0, test_1, test_2 +!! integer :: unit +!! type(bitset_64) :: set0, set1, set2, set3, set4, set5 +!! call set0 % read_bitset( bits_0, status ) +!! call set1 % read_bitset( bits_1, status ) +!! call set2 % read_bitset( bits_2, status ) +!! call set0 % write_bitset( test_0, status ) +!! call set1 % write_bitset( test_1, status ) +!! call set2 % write_bitset( test_2, status ) +!! if ( bits_0 == test_0 .and. bits_1 == test_1 .and. & +!! bits_2 == test_2 ) then +!! write(*,*) 'READ_BITSET to WRITE_BITSET strings worked.' +!! end if +!! open( newunit=unit, file='test.txt', status='replace', & +!! form='formatted', action='write' ) +!! call set2 % write_bitset(unit, advance='no') +!! call set1 % write_bitset(unit, advance='no') +!! call set0 % write_bitset(unit) +!! close( unit ) +!! open( newunit=unit, file='test.txt', status='old', & +!! form='formatted', action='read' ) +!! call set3 % read_bitset(unit, advance='no') +!! call set4 % read_bitset(unit, advance='no') +!! call set5 % read_bitset(unit) +!! if ( set3 == set0 .and. set4 == set1 .and. set5 == set2 ) then +!! write(*,*) WRITE_BITSET to READ_BITSET through unit worked.' +!! end if +!! end program demo_read_bitset +!!``` + import :: bitset_type + class(bitset_type), intent(out) :: self + character(len=*), intent(in) :: string + integer, intent(out), optional :: status + end subroutine read_bitset_string_abstract + + subroutine read_bitset_unit_abstract(self, unit, advance, status) +!! Version: experimental +!! +!! Uses the bitset literal at the current position in the formatted +!! file with I/O unit, `unit`, to define the bitset, `self`. The literal +!! may be preceded by an an arbitrary sequence of blank characters. +!! If `advance` is present it must be either 'YES' or 'NO'. If absent +!! it has the default value of 'YES' to determine whether advancing +!! I/O occurs. If `status` is absent an error results in an error stop +!! with an informative stop code. If `status` is present it has one of +!! the values: +!! * `success` - if no problem occurred, +!! * `alloc_fault` - if allocation of `self` failed, +!! * `array_size_invalid_error` - if `bits(self)` in the bitset literal +!! is greater than 64 for a `bitset_64`, +!! * `char_string_invalid_error` - if the read of the bitset literal found +!! an invalid character, +!! * `eof_failure` - if a `read` statement reached an end-of-file before +!! completing the read of the bitset literal, +!! * `integer_overflow_error` - if the bitset literal has a `bits(self)` +!! value too large to be represented, +!! * `read_failure` - if a `read` statement fails, +! + import :: bitset_type + class(bitset_type), intent(out) :: self + integer, intent(in) :: unit + character(*), intent(in), optional :: advance + integer, intent(out), optional :: status + end subroutine read_bitset_unit_abstract + + elemental subroutine set_bit_abstract(self, pos) +!! Version: experimental +!! +!! Sets the value at the `pos` position in `self`, provided the position is +!! valid. If the position is less than 0 or greater than `bits(self)-1` +!! then `self` is unchanged. +!! +!!#### Example +!! +!!```fortran +!! program demo_set +!! use stdlib_bitsets +!! type(bitset_large) :: set0 +!! call set0 % init(166) +!! if ( set0 % none() ) write(*,*) 'SET0 is properly initialized.' +!! call set0 % set(165) +!! if ( set0 % test(165) ) write(*,*) 'Bit 165 is set.' +!! call set0 % set(0,164) +!! if ( set0 % all() ) write(*,*) 'All bits are set.' +!! end program demo_set +!!``` + import :: bitset_type, bits_kind + class(bitset_type), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + end subroutine set_bit_abstract + + pure subroutine set_range_abstract(self, start_pos, stop_pos) +!! Version: experimental +!! +!! Sets all valid bits to 1 from the `start_pos` to the `stop_pos` positions +!! in `self`. If `stop_pos < start_pos` no bits are changed. Positions outside +!! the range 0 to `bits(self)-1` are ignored. + import :: bitset_type, bits_kind + class(bitset_type), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + end subroutine set_range_abstract + + elemental function test_abstract(self, pos) result(test) +!! Version: experimental +!! +!! Returns `.true.` if the `pos` position is set, `.false.` otherwise. If `pos` +!! is negative or greater than `bits(self) - 1` the result is `.false.`. +!! +!!#### Example +!! +!!```fortran +!! program demo_test +!! use stdlib_bitsets +!! type(bitset_large) :: set0 +!! call set0 % init(166) +!! call set0 % not() +!! if ( set0 % all() ) write(*,*) 'SET0 is properly initialized.' +!! call set0 % clear(165) +!! if ( .not. set0 % test(165) ) write(*,*) 'Bit 165 is cleared.' +!! call set0 % set(165) +!! if ( set0 % test(165) ) write(*,*) 'Bit 165 is set.' +!! end program demo_test +!!``` + import :: bitset_type, bits_kind + logical :: test + class(bitset_type), intent(in) :: self + integer(bits_kind), intent(in) :: pos + end function test_abstract + + subroutine to_string_abstract(self, string, status) +!! Version: experimental +!! +!! Represents the value of `self` as a binary literal in `string` +!! Status may have the values `success` or `alloc_fault`. +!! +!!#### Example +!! +!!```fortran +!! program demo_to_string +!! use stdlib_bitsets +!! character(*), parameter :: & +!! bits_all = '111111111111111111111111111111111' +!! type(bitset_64) :: set0 +!! character(:), allocatable :: new_string +!! call set0 % init(33) +!! call set0 % not() +!! call set0 % to_string( new_string ) +!! if ( new_string == bits_all ) then +!! write(*,*) "TO_STRING transferred BITS0 properly" // & +!! " into NEW_STRING." +!! end if +!! end program demo_to_string +!!``` + import :: bitset_type + class(bitset_type), intent(in) :: self + character(:), allocatable, intent(out) :: string + integer, intent(out), optional :: status + end subroutine to_string_abstract + + elemental function value_abstract(self, pos) result(value) +!! Version: experimental +!! +!! Returns 1 if the `pos` position is set, 0 otherwise. If `pos` is negative +!! or greater than `bits(set) - 1` the result is 0. +!! +!!#### Example +!! +!!```fortran +!! program demo_value +!! use stdlib_bitsets +!! type(bitset_large) :: set0 +!! call set0 % init(166) +!! call set0 % not() +!! if ( set0 % all() ) write(*,*) 'SET0 is properly initialized.' +!! call set0 % clear(165) +!! if ( set0 % value(165) == 0 ) write(*,*) 'Bit 165 is cleared.' +!! call set0 % set(165) +!! if ( set0 % value(165) == 1 ) write(*,*) 'Bit 165 is set.' +!! end program demo_value +!!``` + import :: bitset_type, bits_kind + integer :: value + class(bitset_type), intent(in) :: self + integer(bits_kind), intent(in) :: pos + end function value_abstract + + subroutine write_bitset_string_abstract(self, string, status) +!! Version: experimental +!! +!! Writes a bitset literal to the allocatable default character `string`, +!! representing the individual bit values in the `bitset_type`, `self`. +!! If `status` is absent an error results in an error stop with an +!! informative stop code. If `status` is present it has the default +!! value of `success`, or the value `alloc_fault` if allocation of +!! the output string failed. +!! +!!#### Example +!! +!!```fortran +!! program demo_write_bitset +!! character(*), parameter :: & +!! bits_0 = 'S33B000000000000000000000000000000000', & +!! bits_1 = 'S33B000000000000000000000000000000001', & +!! bits_33 = 'S33B100000000000000000000000000000000' +!! character(:), allocatable :: test_0, test_1, test_2 +!! integer :: unit +!! type(bitset_64) :: set0, set1, set2, set3, set4, set5 +!! call set0 % read_bitset( bits_0, status ) +!! call set1 % read_bitset( bits_1, status ) +!! call set2 % read_bitset( bits_2, status ) +!! call set0 % write_bitset( test_0, status ) +!! call set1 % write_bitset( test_1, status ) +!! call set2 % write_bitset( test_2, status ) +!! if ( bits_0 == test_0 .and. bits_1 == test_1 .and. & +!! bits_2 == test_2 ) then +!! write(*,*) 'READ_BITSET to WRITE_BITSET strings worked.' +!! end if +!! open( newunit=unit, file='test.txt', status='replace', & +!! form='formatted', action='write' ) +!! call set2 % write_bitset(unit, advance='no') +!! call set1 % write_bitset(unit, advance='no') +!! call set0 % write_bitset(unit) +!! close( unit ) +!! open( newunit=unit, file='test.txt', status='old', & +!! form='formatted', action='read' ) +!! call set3 % read_bitset(unit, advance='no') +!! call set4 % read_bitset(unit, advance='no') +!! call set5 % read_bitset(unit) +!! if ( set3 == set0 .and. set4 == set1 .and. set5 == set2 ) then +!! write(*,*) WRITE_BITSET to READ_BITSET through unit worked.' +!! end if +!! end program demo_write_bitset +!!``` + import :: bitset_type + class(bitset_type), intent(in) :: self + character(len=:), allocatable, intent(out) :: string + integer, intent(out), optional :: status + end subroutine write_bitset_string_abstract + + subroutine write_bitset_unit_abstract(self, unit, advance, & + status) +!! Version: experimental +!! +!! Writes a bitset literal to the I/O unit, `unit`, representing the +!! individual bit values in the `bitset_t`, `self`. If an error occurs then +!! processing stops with a message to `error_unit`. By default or if +!! `advance` is present with the value 'YES', advancing output is used. +!! If `advance` is present with the value 'NO', then the current record +!! is not advanced by the write. If `status` is absent, an error results +!! in an error stop with an informative stop code. If `status` is +!! present it has the default value of `success`, the value +!! `alloc_fault` if allocation of the output string failed, +!! `write_failure` if the `write` statement outputting the literal failed. + import :: bitset_type + class(bitset_type), intent(in) :: self + integer, intent(in) :: unit + character(len=*), intent(in), optional :: advance + integer, intent(out), optional :: status + end subroutine write_bitset_unit_abstract + + end interface + + type, extends(bitset_type) :: bitset_large +!! Version: experimental +!! +!! Type for bitsets with more than 64 bits ([Specification](../page/specs/stdlib_bitsets.html#the-stdlib_bitsets-derived-types)) + + private + integer(block_kind), private, allocatable :: blocks(:) + + contains + + procedure, pass(self) :: all => all_large + procedure, pass(self) :: any => any_large + procedure, pass(self) :: bit_count => bit_count_large + procedure, pass(self) :: clear_bit => clear_bit_large + procedure, pass(self) :: clear_range => clear_range_large + procedure, pass(self) :: flip_bit => flip_bit_large + procedure, pass(self) :: flip_range => flip_range_large + procedure, pass(self) :: from_string => from_string_large + procedure, pass(self) :: init_zero => init_zero_large + procedure, pass(self) :: input => input_large + procedure, pass(self) :: none => none_large + procedure, pass(self) :: not => not_large + procedure, pass(self) :: output => output_large + procedure, pass(self) :: & + read_bitset_string => read_bitset_string_large + procedure, pass(self) :: read_bitset_unit => read_bitset_unit_large + procedure, pass(self) :: set_bit => set_bit_large + procedure, pass(self) :: set_range => set_range_large + procedure, pass(self) :: test => test_large + procedure, pass(self) :: to_string => to_string_large + procedure, pass(self) :: value => value_large + procedure, pass(self) :: & + write_bitset_string => write_bitset_string_large + procedure, pass(self) :: write_bitset_unit => write_bitset_unit_large + + end type bitset_large + + + interface + + elemental module function all_large( self ) result(all) +!! Version: experimental +!! +!! Returns `.true.` if all bits in `self` are 1, `.false.` otherwise. + logical :: all + class(bitset_large), intent(in) :: self + end function all_large + + elemental module function any_large(self) result(any) +!! Version: experimental +!! +!! Returns `.true.` if any bit in `self` is 1, `.false.` otherwise. + logical :: any + class(bitset_large), intent(in) :: self + end function any_large + + elemental module function bit_count_large(self) result(bit_count) +!! Version: experimental +!! +!! Returns the number of non-zero bits in `self`. + integer(bits_kind) :: bit_count + class(bitset_large), intent(in) :: self + end function bit_count_large + + elemental module subroutine clear_bit_large(self, pos) +!! Version: experimental +!! +!! Sets to zero the bit at `pos` position in `self`. If `pos` is less than +!! zero or greater than `bits(self)-1` it is ignored. + class(bitset_large), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + end subroutine clear_bit_large + + pure module subroutine clear_range_large(self, start_pos, stop_pos) +!! Version: experimental +!! +!! Sets to zero all bits from the `start_pos` to `stop_pos` positions in `self`. +!! If `stop_pos < start_pos` then no bits are modified. Positions outside +!! the range 0 to `bits(set)-1` are ignored. + class(bitset_large), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + end subroutine clear_range_large + + elemental module subroutine flip_bit_large(self, pos) +!! Version: experimental +!! +!! Flips the bit value at the `pos` position in `self`, provided the position is +!! valid. If `pos` is less than 0 or greater than `bits(self)-1`, no value is +!! changed. + class(bitset_large), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + end subroutine flip_bit_large + + pure module subroutine flip_range_large(self, start_pos, stop_pos) +!! Version: experimental +!! +!! Flips all valid bits from the `start_pos` to the `stop_pos` positions in +!! `self`. If `stop_pos < start_pos` no bits are flipped. Positions less than +!! 0 or greater than `bits(self)-1` are ignored. + class(bitset_large), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + end subroutine flip_range_large + + module subroutine from_string_large(self, string, status) +!! Version: experimental +!! +!! Initializes the bitset `self` treating `string` as a binary literal +!! `status` may have the values: +!! * `success` - if no problems were found, +!! * `alloc_fault` - if allocation of the bitset failed +!! * `char_string_too_large_error` - if `string` was too large, or +!! * `char_string_invalid_error` - if string had an invalid character. + class(bitset_large), intent(out) :: self + character(*), intent(in) :: string + integer, intent(out), optional :: status + end subroutine from_string_large + + module subroutine init_zero_large(self, bits, status) +!! Version: experimental +!! +!! Creates the bitset, `self`, of size `bits`, with all bits initialized to +!! zero. `bits` must be non-negative. If an error occurs and `status` is +!! absent then processing stops with an informative stop code. `status` +!! will have one of the values; +!! * `success` - if no problems were found, +!! * `alloc_fault` - if memory allocation failed +!! * `array_size_invalid_error` - if `bits` is either negative or larger +!! than 64 with `self` of class `bitset_64`, or + class(bitset_large), intent(out) :: self + integer(bits_kind), intent(in) :: bits + integer, intent(out), optional :: status + end subroutine init_zero_large + + module subroutine input_large(self, unit, status) +!! Version: experimental +!! +!! Reads the components of the bitset, `self`, from the unformatted I/O +!! unit, `unit`, assuming that the components were written using `output`. +!! If an error occurs and `status` is absent then processing stops with +!! an informative stop code. `status` has one of the values: +!! * `success` - if no problem was found +!! * `alloc_fault` - if it failed allocating memory for `self`, or +!! * `array_size_invalid_error` if the `bits(self)` in `unit` is negative +!! or greater than 64 for a `bitset_64` input. +!! * `read_failure` - if it failed during the reads from `unit` + class(bitset_large), intent(out) :: self + integer, intent(in) :: unit + integer, intent(out), optional :: status + end subroutine input_large + + elemental module function none_large(self) result(none) +!! Version: experimental +!! +!! Returns `.true.` if none of the bits in `self` have the value 1. + logical :: none + class(bitset_large), intent(in) :: self + end function none_large + + elemental module subroutine not_large(self) +!! Version: experimental +!! +!! Sets the bits in `self` to their logical complement + class(bitset_large), intent(inout) :: self + end subroutine not_large + + module subroutine output_large(self, unit, status) +!! Version: experimental +!! +!! Writes the components of the bitset, `self`, to the unformatted I/O +!! unit, `unit`, in a unformatted sequence compatible with `input`. If +!! `status` is absent an error results in an error stop with an +!! informative stop code. If `status` is present it has the default +!! value of `success`, or the value `write_failure` if the write failed. + class(bitset_large), intent(in) :: self + integer, intent(in) :: unit + integer, intent(out), optional :: status + end subroutine output_large + + module subroutine read_bitset_string_large(self, string, status) +!! Version: experimental +!! +!! Uses the bitset literal in the default character `string`, to define +!! the bitset, `self`. The literal may be preceded by an an arbitrary +!! sequence of blank characters. If `status` is absent an error results +!! in an error stop with an informative stop code. If `status` +!! is present it has one of the values +!! * `success` - if no problems occurred, +!! * `alloc_fault` - if allocation of memory for SELF failed, +!! * `array_size_invalid_error - if `bits(self)` in `string` is greater +!! than 64 for a `bitset_64`, +!! * `char_string_invalid_error` - if the bitset literal has an invalid +!! character, +!! * `char_string_too_small_error - if the string ends before all the bits +!! are read. +!! * `integer_overflow_error` - if the bitset literal has a `bits(self)` +!! value too large to be represented, + class(bitset_large), intent(out) :: self + character(len=*), intent(in) :: string + integer, intent(out), optional :: status + end subroutine read_bitset_string_large + + module subroutine read_bitset_unit_large(self, unit, advance, status) +!! Version: experimental +!! +!! Uses the bitset literal at the current position in the formatted +!! file with I/O unit, `unit`, to define the bitset, `self`. The literal +!! may be preceded by an an arbitrary sequence of blank characters. +!! If `advance` is present it must be either 'YES' or 'NO'. If absent +!! it has the default value of 'YES' to determine whether advancing +!! I/O occurs. If `status` is absent an error results in an error stop +!! with an informative stop code. If `status` is present it has one of +!! the values: +!! * `success` - if no problem occurred, +!! * `alloc_fault` - if allocation of `self` failed, +!! * `array_size_invalid_error` - if `bits(self)` in the bitset literal +!! is greater than 64 for a `bitset_64`, +!! * `char_string_invalid_error` - if the read of the bitset literal found +!! an invalid character, +!! * `eof_failure` - if a `read` statement reached an end-of-file before +!! completing the read of the bitset literal, +!! * `integer_overflow_error` - if the bitset literal has a `bits(self)` +!! value too large to be represented, +!! * `read_failure` - if a `read` statement fails, + class(bitset_large), intent(out) :: self + integer, intent(in) :: unit + character(*), intent(in), optional :: advance + integer, intent(out), optional :: status + end subroutine read_bitset_unit_large + + elemental module subroutine set_bit_large(self, pos) +!! Version: experimental +!! +!! Sets the value at the `pos` position in `self`, provided the position is +!! valid. If the position is less than 0 or greater than `bits(self)-1` +!! then `self` is unchanged. + class(bitset_large), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + end subroutine set_bit_large + + pure module subroutine set_range_large(self, start_pos, stop_pos) +!! Version: experimental +!! +!! Sets all valid bits to 1 from the `start_pos` to the `stop_pos` positions +!! in `self`. If `stop_pos < start_pos` no bits are changed. Positions outside +!! the range 0 to `bits(self)-1` are ignored. + class(bitset_large), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + end subroutine set_range_large + + elemental module function test_large(self, pos) result(test) +!! Version: experimental +!! +!! Returns `.true.` if the `pos` position is set, `.false.` otherwise. If `pos` +!! is negative or greater than `bits(self) - 1` the result is `.false.`. + logical :: test + class(bitset_large), intent(in) :: self + integer(bits_kind), intent(in) :: pos + end function test_large + + module subroutine to_string_large(self, string, status) +!! Version: experimental +!! +!! Represents the value of `self` as a binary literal in `string` +!! Status may have the values `success` or `alloc_fault`. + class(bitset_large), intent(in) :: self + character(len=:), allocatable, intent(out) :: string + integer, intent(out), optional :: status + end subroutine to_string_large + + elemental module function value_large(self, pos) result(value) +!! Version: experimental +!! +!! Returns 1 if the `pos` position is set, 0 otherwise. If `pos` is negative +!! or greater than `bits(set) - 1` the result is 0. + integer :: value + class(bitset_large), intent(in) :: self + integer(bits_kind), intent(in) :: pos + end function value_large + + module subroutine write_bitset_string_large(self, string, status) +!! Version: experimental +!! +!! Writes a bitset literal to the allocatable default character `string`, +!! representing the individual bit values in the bitset_large, `self`. +!! If `status` is absent an error results in an error stop with an +!! informative stop code. If `status` is present it has the default +!! value of `success, or the value `alloc_fault` if allocation of +!! the output string failed. + class(bitset_large), intent(in) :: self + character(len=:), allocatable, intent(out) :: string + integer, intent(out), optional :: status + end subroutine write_bitset_string_large + + module subroutine write_bitset_unit_large(self, unit, advance, status) +!! Version: experimental +!! +!! Writes a bitset literal to the I/O unit, `unit`, representing the +!! individual bit values in the bitset, `self`. By default or if +!! `advance` is present with the value 'YES', advancing output is used. +!! If `advance` is present with the value 'NO', then the current record +!! is not advanced by the write. If `status` is absent an error results +!! in an error stop with an informative stop code. If `status` is +!! present it has the default value of `success`, the value +!! `alloc_fault` if allocation of the output string failed, or +!! `write_failure` if the `write` statement outputting the literal failed. + class(bitset_large), intent(in) :: self + integer, intent(in) :: unit + character(len=*), intent(in), optional :: advance + integer, intent(out), optional :: status + end subroutine write_bitset_unit_large + + end interface + + + interface assignment(=) +!! Version: experimental +!! +!! Used to define assignment for `bitset_large`. +!! ([Specification](../page/specs/stdlib_bitsets.html#-compare-two-bitsets-to-determine-whether-the-bits-have-the-same-value)) +!! +!!#### Example +!! +!!```fortran +!! program demo_assignment +!! use stdlib_bitsets +!! logical(int8) :: logical1(64) = .true. +!! logical(int32), allocatable :: logical2(:) +!! type(bitset_64) :: set0, set1 +!! set0 = logical1 +!! if ( set0 % bits() /= 64 ) then +!! error stop procedure // & +!! ' initialization with logical(int8) failed to set' // & +!! ' the right size.' +!! else if ( .not. set0 % all() ) then +!! error stop procedure // ' initialization with' // & +!! ' logical(int8) failed to set the right values.' +!! else +!! write(*,*) 'Initialization with logical(int8) succeeded.' +!! end if +!! set1 = set0 +!! if ( set1 == set0 ) & +!! write(*,*) 'Initialization by assignment succeeded' +!! logical2 = set1 +!! if ( all( logical2 ) ) then +!! write(*,*) 'Initialization of logical(int32) succeeded.' +!! end if +!! end program demo_assignment +!!``` + + pure module subroutine assign_large( set1, set2 ) +!! Version: experimental +!! +!! Used to define assignment for `bitset_large`. + type(bitset_large), intent(out) :: set1 + type(bitset_large), intent(in) :: set2 + end subroutine assign_large + + pure module subroutine assign_logint8_large( self, logical_vector ) +!! Version: experimental +!! +!! Used to define assignment from an array of type `logical(int8)` to a +!! `bitset_large`. + type(bitset_large), intent(out) :: self + logical(int8), intent(in) :: logical_vector(:) + end subroutine assign_logint8_large + + pure module subroutine logint8_assign_large( logical_vector, set ) +!! Version: experimental +!! +!! Used to define assignment to an array of type `logical(int8)` from a +!! `bitset_large`. + logical(int8), intent(out), allocatable :: logical_vector(:) + type(bitset_large), intent(in) :: set + end subroutine logint8_assign_large + pure module subroutine assign_logint16_large( self, logical_vector ) +!! Version: experimental +!! +!! Used to define assignment from an array of type `logical(int16)` to a +!! `bitset_large`. + type(bitset_large), intent(out) :: self + logical(int16), intent(in) :: logical_vector(:) + end subroutine assign_logint16_large + + pure module subroutine logint16_assign_large( logical_vector, set ) +!! Version: experimental +!! +!! Used to define assignment to an array of type `logical(int16)` from a +!! `bitset_large`. + logical(int16), intent(out), allocatable :: logical_vector(:) + type(bitset_large), intent(in) :: set + end subroutine logint16_assign_large + pure module subroutine assign_logint32_large( self, logical_vector ) +!! Version: experimental +!! +!! Used to define assignment from an array of type `logical(int32)` to a +!! `bitset_large`. + type(bitset_large), intent(out) :: self + logical(int32), intent(in) :: logical_vector(:) + end subroutine assign_logint32_large + + pure module subroutine logint32_assign_large( logical_vector, set ) +!! Version: experimental +!! +!! Used to define assignment to an array of type `logical(int32)` from a +!! `bitset_large`. + logical(int32), intent(out), allocatable :: logical_vector(:) + type(bitset_large), intent(in) :: set + end subroutine logint32_assign_large + pure module subroutine assign_logint64_large( self, logical_vector ) +!! Version: experimental +!! +!! Used to define assignment from an array of type `logical(int64)` to a +!! `bitset_large`. + type(bitset_large), intent(out) :: self + logical(int64), intent(in) :: logical_vector(:) + end subroutine assign_logint64_large + + pure module subroutine logint64_assign_large( logical_vector, set ) +!! Version: experimental +!! +!! Used to define assignment to an array of type `logical(int64)` from a +!! `bitset_large`. + logical(int64), intent(out), allocatable :: logical_vector(:) + type(bitset_large), intent(in) :: set + end subroutine logint64_assign_large + + end interface assignment(=) + + + type, extends(bitset_type) :: bitset_64 +!! Version: experimental +!! +!! Type for bitsets with no more than 64 bits ([Specification](../page/specs/stdlib_bitsets.html#the-stdlib_bitsets-derived-types)) + private + integer(block_kind), private :: block = 0 + + contains + + procedure, pass(self) :: all => all_64 + procedure, pass(self) :: any => any_64 + procedure, pass(self) :: bit_count => bit_count_64 + procedure, pass(self) :: clear_bit => clear_bit_64 + procedure, pass(self) :: clear_range => clear_range_64 + procedure, pass(self) :: flip_bit => flip_bit_64 + procedure, pass(self) :: flip_range => flip_range_64 + procedure, pass(self) :: from_string => from_string_64 + procedure, pass(self) :: init_zero => init_zero_64 + procedure, pass(self) :: input => input_64 + procedure, pass(self) :: none => none_64 + procedure, pass(self) :: not => not_64 + procedure, pass(self) :: output => output_64 + procedure, pass(self) :: read_bitset_string => read_bitset_string_64 + procedure, pass(self) :: read_bitset_unit => read_bitset_unit_64 + procedure, pass(self) :: set_bit => set_bit_64 + procedure, pass(self) :: set_range => set_range_64 + procedure, pass(self) :: test => test_64 + procedure, pass(self) :: to_string => to_string_64 + procedure, pass(self) :: value => value_64 + procedure, pass(self) :: write_bitset_string => write_bitset_string_64 + procedure, pass(self) :: write_bitset_unit => write_bitset_unit_64 + + end type bitset_64 + + + interface + + elemental module function all_64( self ) result(all) +!! Version: experimental +!! +!! Returns `.true.` if all bits in `self` are 1, `.false.` otherwise. + logical :: all + class(bitset_64), intent(in) :: self + end function all_64 + + elemental module function any_64(self) result(any) +!! Version: experimental +!! +!! Returns `.true.` if any bit in `self` is 1, `.false.` otherwise. + logical :: any + class(bitset_64), intent(in) :: self + end function any_64 + + elemental module function bit_count_64(self) result(bit_count) +!! Version: experimental +!! +!! Returns the number of non-zero bits in `self`. + integer(bits_kind) :: bit_count + class(bitset_64), intent(in) :: self + end function bit_count_64 + + elemental module subroutine clear_bit_64(self, pos) +!! Version: experimental +!! +!! Sets to zero the bit at `pos` position in `self`. If `pos` is less than +!! zero or greater than `bits(self)-1` it is ignored. + class(bitset_64), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + end subroutine clear_bit_64 + + pure module subroutine clear_range_64(self, start_pos, stop_pos) +!! Version: experimental +!! +!! Sets to zero all bits from the `start_pos` to `stop_pos` positions in `self`. +!! If `stop_pos < start_pos` then no bits are modified. Positions outside +!! the range 0 to `bits(set)-1` are ignored. + class(bitset_64), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + end subroutine clear_range_64 + + elemental module subroutine flip_bit_64(self, pos) +!! Version: experimental +!! +!! Flips the bit value at the `pos` position in `self`, provided the position is +!! valid. If `pos` is less than 0 or greater than `bits(self)-1`, no value is +!! changed. + class(bitset_64), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + end subroutine flip_bit_64 + + pure module subroutine flip_range_64(self, start_pos, stop_pos) +!! Version: experimental +!! +!! Flips all valid bits from the `start_pos` to the `stop_pos` positions in +!! `self`. If `stop_pos < start_pos` no bits are flipped. Positions less than +!! 0 or greater than `bits(self)-1` are ignored. + class(bitset_64), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + end subroutine flip_range_64 + + module subroutine from_string_64(self, string, status) +!! Version: experimental +!! +!! Initializes the bitset `self` treating `string` as a binary literal +!! `status` may have the values: +!! * `success` - if no problems were found, +!! * `alloc_fault` - if allocation of the bitset failed +!! * `char_string_too_large_error` - if `string` was too large, or +!! * `char_string_invalid_error` - if string had an invalid character. + class(bitset_64), intent(out) :: self + character(*), intent(in) :: string + integer, intent(out), optional :: status + end subroutine from_string_64 + + module subroutine init_zero_64(self, bits, status) +!! Version: experimental +!! +!! Creates the bitset, `self`, of size `bits`, with all bits initialized to +!! zero. `bits` must be non-negative. If an error occurs and `status` is +!! absent then processing stops with an informative stop code. `status` +!! will have one of the values: +!! * `success` - if no problems were found, +!! * `alloc_fault` - if memory allocation failed +!! * `array_size_invalid_error` - if `bits` is either negative or larger +!! than 64 with `self` of class `bitset_64`. + class(bitset_64), intent(out) :: self + integer(bits_kind), intent(in) :: bits + integer, intent(out), optional :: status + end subroutine init_zero_64 + + module subroutine input_64(self, unit, status) +!! Version: experimental +!! +!! Reads the components of the bitset, `self`, from the unformatted I/O +!! unit, `unit`, assuming that the components were written using `output`. +!! If an error occurs and `status` is absent then processing stops with +!! an informative stop code. `status` has one of the values: +!! * `success` - if no problem was found +!! * `alloc_fault` - if it failed allocating memory for `self`, or +!! * `array_size_invalid_error` if the `bits(self)` in `unit` is negative +!! or greater than 64 for a `bitset_64` input. +!! * `read_failure` - if it failed during the reads from `unit` + class(bitset_64), intent(out) :: self + integer, intent(in) :: unit + integer, intent(out), optional :: status + end subroutine input_64 + + elemental module function none_64(self) result(none) +!! Version: experimental +!! +!! Returns `.true.` if none of the bits in `self` have the value 1. + logical :: none + class(bitset_64), intent(in) :: self + end function none_64 + + elemental module subroutine not_64(self) +!! Version: experimental +!! +!! Sets the bits in `self` to their logical complement. + class(bitset_64), intent(inout) :: self + end subroutine not_64 + + module subroutine output_64(self, unit, status) +!! Version: experimental +!! +!! Writes the components of the bitset, `self`, to the unformatted I/O +!! unit, `unit`, in a unformatted sequence compatible with `input`. If +!! `status` is absent an error results in an error stop with an +!! informative stop code. If `status` is present it has the default +!! value of `success`, or the value `write_failure` if the write failed. + class(bitset_64), intent(in) :: self + integer, intent(in) :: unit + integer, intent(out), optional :: status + end subroutine output_64 + + module subroutine read_bitset_string_64(self, string, status) +!! Version: experimental +!! +!! Uses the bitset literal in the default character `string`, to define +!! the bitset, `self`. The literal may be preceded by an an arbitrary +!! sequence of blank characters. If `status` is absent an error results +!! in an error stop with an informative stop code. If `status` +!! is present it has one of the values: +!! * `success` - if no problems occurred, +!! * `alloc_fault` - if allocation of memory for SELF failed, +!! * `array_size_invalid_error - if `bits(self)` in `string` is greater +!! than 64 for a `bitset_64`, +!! * `char_string_invalid_error` - if the bitset literal has an invalid +!! character, +!! * `char_string_too_small_error - if the string ends before all the bits +!! are read. +!! * `integer_overflow_error` - if the bitset literal has a `bits(self)` +!! value too large to be represented, + class(bitset_64), intent(out) :: self + character(len=*), intent(in) :: string + integer, intent(out), optional :: status + end subroutine read_bitset_string_64 + + module subroutine read_bitset_unit_64(self, unit, advance, status) +!! Version: experimental +!! +!! Uses the bitset literal at the current position in the formatted +!! file with I/O unit, `unit`, to define the bitset, `self`. The literal +!! may be preceded by an an arbitrary sequence of blank characters. +!! If `advance` is present it must be either 'YES' or 'NO'. If absent +!! it has the default value of 'YES' to determine whether advancing +!! I/O occurs. If `status` is absent an error results in an error stop +!! with an informative stop code. If `status` is present it has one of +!! the values: +!! * `success` - if no problem occurred, +!! * `alloc_fault` - if allocation of `self` failed, +!! * `array_size_invalid_error` - if `bits(self)` in the bitset literal +!! is greater than 64 for a `bitset_64`, +!! * `char_string_invalid_error` - if the read of the bitset literal found +!! an invalid character, +!! * `eof_failure` - if a `read` statement reached an end-of-file before +!! completing the read of the bitset literal, +!! * `integer_overflow_error` - if the bitset literal has a `bits(self)` +!! value too large to be represented, +!! * `read_failure` - if a `read` statement fails, + class(bitset_64), intent(out) :: self + integer, intent(in) :: unit + character(*), intent(in), optional :: advance + integer, intent(out), optional :: status + end subroutine read_bitset_unit_64 + + elemental module subroutine set_bit_64(self, pos) +!! Version: experimental +!! +!! Sets the value at the `pos` position in `self`, provided the position is +!! valid. If the position is less than 0 or greater than `bits(self)-1` +!! then `self` is unchanged. + class(bitset_64), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + end subroutine set_bit_64 + + pure module subroutine set_range_64(self, start_pos, stop_pos) +!! Version: experimental +!! +!! Sets all valid bits to 1 from the `start_pos` to the `stop_pos` positions +!! in `self`. If `stop_pos < start_pos` no bits are changed. Positions outside +!! the range 0 to `bits(self)-1` are ignored. + class(bitset_64), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + end subroutine set_range_64 + + elemental module function test_64(self, pos) result(test) +!! Version: experimental +!! +!! Returns `.true.` if the `pos` position is set, `.false.` otherwise. If `pos` +!! is negative or greater than `bits(self)-1` the result is `.false.`. + logical :: test + class(bitset_64), intent(in) :: self + integer(bits_kind), intent(in) :: pos + end function test_64 + + module subroutine to_string_64(self, string, status) +!! Version: experimental +!! +!! Represents the value of `self` as a binary literal in `string`. +!! Status may have the values `success` or `alloc_fault` + class(bitset_64), intent(in) :: self + character(len=:), allocatable, intent(out) :: string + integer, intent(out), optional :: status + end subroutine to_string_64 + + elemental module function value_64(self, pos) result(value) +!! Version: experimental +!! +!! Returns 1 if the `pos` position is set, 0 otherwise. If `pos` is negative +!! or greater than `bits(set)-1` the result is 0. + integer :: value + class(bitset_64), intent(in) :: self + integer(bits_kind), intent(in) :: pos + end function value_64 + + module subroutine write_bitset_string_64(self, string, status) +!! Version: experimental +!! +!! Writes a bitset literal to the allocatable default character `string`, +!! representing the individual bit values in the `bitset_64`, `self`. +!! If `status` is absent an error results in an error stop with an +!! informative stop code. If `status` is present it has the default +!! value of `success`, or the value `alloc_fault` if allocation of +!! the output string failed. + class(bitset_64), intent(in) :: self + character(len=:), allocatable, intent(out) :: string + integer, intent(out), optional :: status + end subroutine write_bitset_string_64 + + module subroutine write_bitset_unit_64(self, unit, advance, status) +!! Version: experimental +!! +!! Writes a bitset literal to the I/O unit, `unit`, representing the +!! individual bit values in the bitset, `self`. By default or if +!! `advance` is present with the value 'YES', advancing output is used. +!! If `advance` is present with the value 'NO', then the current record +!! is not advanced by the write. If `status` is absent an error results +!! in an error stop with an informative stop code. If `status` is +!! present it has the default value of `success`, the value +!! `alloc_fault` if allocation of the output string failed, or +!! `write_failure` if the `write` statement outputting the literal failed. + class(bitset_64), intent(in) :: self + integer, intent(in) :: unit + character(len=*), intent(in), optional :: advance + integer, intent(out), optional :: status + end subroutine write_bitset_unit_64 + + end interface + + + interface assignment(=) + + pure module subroutine assign_64( set1, set2 ) +!! Version: experimental +!! +!! Used to define assignment for `bitset_64`. + type(bitset_64), intent(out) :: set1 + type(bitset_64), intent(in) :: set2 + end subroutine assign_64 + + module subroutine assign_logint8_64( self, logical_vector ) +!! Version: experimental +!! +!! Used to define assignment from an array of type `logical(int8)` to a +!! `bitset_64`. + type(bitset_64), intent(out) :: self + logical(int8), intent(in) :: logical_vector(:) + end subroutine assign_logint8_64 + + pure module subroutine logint8_assign_64( logical_vector, set ) +!! Version: experimental +!! +!! Used to define assignment to an array of type `logical(int8)` from a +!! `bitset_64`. + logical(int8), intent(out), allocatable :: logical_vector(:) + type(bitset_64), intent(in) :: set + end subroutine logint8_assign_64 + module subroutine assign_logint16_64( self, logical_vector ) +!! Version: experimental +!! +!! Used to define assignment from an array of type `logical(int16)` to a +!! `bitset_64`. + type(bitset_64), intent(out) :: self + logical(int16), intent(in) :: logical_vector(:) + end subroutine assign_logint16_64 + + pure module subroutine logint16_assign_64( logical_vector, set ) +!! Version: experimental +!! +!! Used to define assignment to an array of type `logical(int16)` from a +!! `bitset_64`. + logical(int16), intent(out), allocatable :: logical_vector(:) + type(bitset_64), intent(in) :: set + end subroutine logint16_assign_64 + module subroutine assign_logint32_64( self, logical_vector ) +!! Version: experimental +!! +!! Used to define assignment from an array of type `logical(int32)` to a +!! `bitset_64`. + type(bitset_64), intent(out) :: self + logical(int32), intent(in) :: logical_vector(:) + end subroutine assign_logint32_64 + + pure module subroutine logint32_assign_64( logical_vector, set ) +!! Version: experimental +!! +!! Used to define assignment to an array of type `logical(int32)` from a +!! `bitset_64`. + logical(int32), intent(out), allocatable :: logical_vector(:) + type(bitset_64), intent(in) :: set + end subroutine logint32_assign_64 + module subroutine assign_logint64_64( self, logical_vector ) +!! Version: experimental +!! +!! Used to define assignment from an array of type `logical(int64)` to a +!! `bitset_64`. + type(bitset_64), intent(out) :: self + logical(int64), intent(in) :: logical_vector(:) + end subroutine assign_logint64_64 + + pure module subroutine logint64_assign_64( logical_vector, set ) +!! Version: experimental +!! +!! Used to define assignment to an array of type `logical(int64)` from a +!! `bitset_64`. + logical(int64), intent(out), allocatable :: logical_vector(:) + type(bitset_64), intent(in) :: set + end subroutine logint64_assign_64 + + end interface assignment(=) + + + interface and +!! Version: experimental +!! +!! Sets the bits in `set1` to the bitwise `and` of the original bits in `set1` +!! and `set2`. The sets must have the same number of bits +!! otherwise the result is undefined. +!! ([Specification](../page/specs/stdlib_bitsets.html#and-bitwise-and-of-the-bits-of-two-bitsets)) +!! +!!#### Example +!! +!!```fortran +!! program demo_and +!! use stdlib_bitsets +!! type(bitset_large) :: set0, set1 +!! call set0 % init(166) +!! call set1 % init(166) +!! call and( set0, set1 ) ! none none +!! if ( none(set0) ) write(*,*) 'First test of AND worked.' +!! call set0 % not() +!! call and( set0, set1 ) ! all none +!! if ( none(set0) ) write(*,*) 'Second test of AND worked.' +!! call set1 % not() +!! call and( set0, set1 ) ! none all +!! if ( none(set0) ) write(*,*) 'Third test of AND worked.' +!! call set0 % not() +!! call and( set0, set1 ) ! all all +!! if ( all(set0) ) write(*,*) 'Fourth test of AND worked.' +!! end program demo_and +!!``` + elemental module subroutine and_large(set1, set2) + type(bitset_large), intent(inout) :: set1 + type(bitset_large), intent(in) :: set2 + end subroutine and_large + + elemental module subroutine and_64(set1, set2) + type(bitset_64), intent(inout) :: set1 + type(bitset_64), intent(in) :: set2 + end subroutine and_64 + + end interface and + + + interface and_not +!! Version: experimental +!! +!! Sets the bits in `set1` to the bitwise and of the original bits in `set1` +!! with the bitwise negation of `set2`. The sets must have the same +!! number of bits otherwise the result is undefined. +!! +!! ([Specification](../page/specs/stdlib_bitsets.html#and_not-bitwise-and-of-one-bitset-with-the-negation-of-another)) +!! +!!#### Example +!! +!!```fortran +!! program demo_and_not +!! use stdlib_bitsets +!! type(bitset_large) :: set0, set1 +!! call set0 % init(166) +!! call set1 % init(166) +!! call and_not( set0, set1 ) ! none none +!! if ( none(set0) ) write(*,*) 'First test of AND_NOT worked.' +!! call set0 % not() +!! call and_not( set0, set1 ) ! all none +!! if ( all(set0) ) write(*,*) 'Second test of AND_NOT worked.' +!! call set0 % not() +!! call set1 % not() +!! call and_not( set0, set1 ) ! none all +!! if ( none(set0) ) write(*,*) 'Third test of AND_NOT worked.' +!! call set0 % not() +!! call and_not( set0, set1 ) ! all all +!! if ( none(set0) ) write(*,*) 'Fourth test of AND_NOT worked.' +!! end program demo_and_not +!!``` + + elemental module subroutine and_not_large(set1, set2) + type(bitset_large), intent(inout) :: set1 + type(bitset_large), intent(in) :: set2 + end subroutine and_not_large + + elemental module subroutine and_not_64(set1, set2) + type(bitset_64), intent(inout) :: set1 + type(bitset_64), intent(in) :: set2 + end subroutine and_not_64 + + end interface and_not + + interface extract +!! Version: experimental +!! +!! Creates a new bitset, `new`, from a range, `start_pos` to `stop_pos`, in +!! bitset `old`. If `start_pos` is greater than `stop_pos` the new bitset is +!! empty. If `start_pos` is less than zero or `stop_pos` is greater than +!! `bits(old)-1` then if `status` is present it has the value +!! `index_invalid_error` and `new` is undefined, otherwise processing stops +!! with an informative message. +!! ([Specification](../page/specs/stdlib_bitsets.html#extract-create-a-new-bitset-from-a-range-in-an-old-bitset)) +!! +!!#### Example +!! +!!```fortran +!! program demo_extract +!! use stdlib_bitsets +!! type(bitset_large) :: set0, set1 +!! call set0 % init(166) +!! call set0 % set(100,150) +!! call extract( set1, set0, 100, 150) +!! if ( set1 % bits() == 51 ) & +!! write(*,*) 'SET1 has the proper size.' +!! if ( set1 % all() ) write(*,*) 'SET1 has the proper values.' +!! end program demo_extract +!!``` + + module subroutine extract_large(new, old, start_pos, stop_pos, status) + type(bitset_large), intent(out) :: new + type(bitset_large), intent(in) :: old + integer(bits_kind), intent(in) :: start_pos, stop_pos + integer, intent(out), optional :: status + end subroutine extract_large + + module subroutine extract_64(new, old, start_pos, stop_pos, status) + type(bitset_64), intent(out) :: new + type(bitset_64), intent(in) :: old + integer(bits_kind), intent(in) :: start_pos, stop_pos + integer, intent(out), optional :: status + end subroutine extract_64 + + end interface extract + + + interface or +!! Version: experimental +!! +!! Sets the bits in `set1` to the bitwise `or` of the original bits in `set1` +!! and `set2`. The sets must have the same number of bits otherwise +!! the result is undefined. +!! ([Specification](../page/specs/stdlib_bitsets.html#or-bitwise-or-of-the-bits-of-two-bitsets)) +!! +!!#### Example +!! +!!```fortran +!! program demo_or +!! use stdlib_bitsets +!! type(bitset_large) :: set0, set1 +!! call set0 % init(166) +!! call set1 % init(166) +!! call or( set0, set1 ) ! none none +!! if ( none(set0) ) write(*,*) 'First test of OR worked.' +!! call set0 % not() +!! call or( set0, set1 ) ! all none +!! if ( all(set0) ) write(*,*) 'Second test of OR worked.' +!! call set0 % not() +!! call set1 % not() +!! call or( set0, set1 ) ! none all +!! if ( all(set0) ) write(*,*) 'Third test of OR worked.' +!! call set0 % not() +!! call or( set0, set1 ) ! all all +!! if ( all(set0) ) write(*,*) 'Fourth test of OR worked.' +!! end program demo_or +!!``` + elemental module subroutine or_large(set1, set2) + type(bitset_large), intent(inout) :: set1 + type(bitset_large), intent(in) :: set2 + end subroutine or_large + + elemental module subroutine or_64(set1, set2) + type(bitset_64), intent(inout) :: set1 + type(bitset_64), intent(in) :: set2 + end subroutine or_64 + + end interface or + + + interface xor +!! Version: experimental +!! +!! Sets the bits in `set1` to the bitwise `xor` of the original bits in `set1` +!! and `set2`. The sets must have the same number of bits +!! otherwise the result is undefined. +!!([Specification](../page/specs/stdlib_bitsets.html#xor-bitwise-exclusive-or)) +!! +!!#### Example +!! +!!```fortran +!! program demo_xor +!! use stdlib_bitsets +!! type(bitset_large) :: set0, set1 +!! call set0 % init(166) +!! call set1 % init(166) +!! call xor( set0, set1 ) ! none none +!! if ( none(set0) ) write(*,*) 'First test of XOR worked.' +!! call set0 % not() +!! call xor( set0, set1 ) ! all none +!! if ( all(set0) ) write(*,*) 'Second test of XOR worked.' +!! call set0 % not() +!! call set1 % not() +!! call xor( set0, set1 ) ! none all +!! if ( all(set0) ) write(*,*) 'Third test of XOR worked.' +!! call set0 % not() +!! call xor( set0, set1 ) ! all all +!! if ( none(set0) ) write(*,*) 'Fourth test of XOR worked.' +!! end program demo_xor +!!``` + elemental module subroutine xor_large(set1, set2) + type(bitset_large), intent(inout) :: set1 + type(bitset_large), intent(in) :: set2 + end subroutine xor_large + + elemental module subroutine xor_64(set1, set2) + type(bitset_64), intent(inout) :: set1 + type(bitset_64), intent(in) :: set2 + end subroutine xor_64 + + end interface xor + + + interface operator(==) +!! Version: experimental +!! +!! Returns `.true.` if all bits in `set1` and `set2` have the same value, +!! `.false.` otherwise. The sets must have the same number of bits +!! otherwise the result is undefined. +!!([Specification](../page/specs/stdlib_bitsets.html#-compare-two-bitsets-to-determine-whether-the-bits-have-the-same-value)) +!! +!!#### Example +!! +!!```fortran +!! program demo_equality +!! use stdlib_bitsets +!! type(bitset_64) :: set0, set1, set2 +!! call set0 % init( 33 ) +!! call set1 % init( 33 ) +!! call set2 % init( 33 ) +!! call set1 % set( 0 ) +!! call set2 % set( 32 ) +!! if ( set0 == set0 .and. set1 == set1 .and. set2 == set2 .and. & +!! .not. set0 == set1 .and. .not. set0 == set2 .and. .not. & +!! set1 == set2 ) then +!! write(*,*) 'Passed 64 bit equality tests.' +!! else +!! error stop 'Failed 64 bit equality tests.' +!! end if +!! end program demo_equality +!!``` + elemental module function eqv_large(set1, set2) result(eqv) + logical :: eqv + type(bitset_large), intent(in) :: set1, set2 + end function eqv_large + + elemental module function eqv_64(set1, set2) result(eqv) + logical :: eqv + type(bitset_64), intent(in) :: set1, set2 + end function eqv_64 + + end interface operator(==) + + + interface operator(/=) +!! Version: experimental +!! +!! Returns `.true.` if not all bits in `set1` and `set2` have the same value, +!! `.false.` otherwise. The sets must have the same number of bits +!! otherwise the result is undefined. +!!([Specification](../page/specs/stdlib_bitsets.html#-compare-two-bitsets-to-determine-whether-any-bits-differ-in-value)) +!! +!!#### Example +!! +!!```fortran +!! program demo_inequality +!! use stdlib_bitsets +!! type(bitset_64) :: set0, set1, set2 +!! call set0 % init( 33 ) +!! call set1 % init( 33 ) +!! call set2 % init( 33 ) +!! call set1 % set( 0 ) +!! call set2 % set( 32 ) +!! if ( set0 /= set1 .and. set0 /= set2 .and. set1 /= set2 .and. & +!! .not. set0 /= set0 .and. .not. set1 /= set1 .and. .not. & +!! set2 /= set2 ) then +!! write(*,*) 'Passed 64 bit inequality tests.' +!! else +!! error stop 'Failed 64 bit inequality tests.' +!! end if +!! end program demo_inequality +!!``` + elemental module function neqv_large(set1, set2) result(neqv) + logical :: neqv + type(bitset_large), intent(in) :: set1, set2 + end function neqv_large + + elemental module function neqv_64(set1, set2) result(neqv) + logical :: neqv + type(bitset_64), intent(in) :: set1, set2 + end function neqv_64 + + end interface operator(/=) + + + interface operator(>) +!! Version: experimental +!! +!! Returns `.true.` if the bits in `set1` and `set2` differ and the +!! highest order different bit is set to 1 in `set1` and to 0 in `set2`, +!! `.false.` otherwise. The sets must have the same number of bits +!! otherwise the result is undefined. +!!([Specification](../page/specs/stdlib_bitsets.html#gt-compare-two-bitsets-to-determine-whether-the-first-is-greater-than-the-other)) +!! +!!#### Example +!! +!!```fortran +!! program demo_gt +!! use stdlib_bitsets +!! type(bitset_64) :: set0, set1, set2 +!! call set0 % init( 33 ) +!! call set1 % init( 33 ) +!! call set2 % init( 33 ) +!! call set1 % set( 0 ) +!! call set2 % set( 32 ) +!! if ( set1 > set0 .and. set2 > set1 .and. set2 > set0 .and. & +!! .not. set0 > set0 .and. .not. set0 > set1 .and. .not. & +!! set1 > set2 ) then +!! write(*,*) 'Passed 64 bit greater than tests.' +!! else +!! error stop 'Failed 64 bit greater than tests.' +!! end if +!! end program demo_gt +!!``` + elemental module function gt_large(set1, set2) result(gt) + logical :: gt + type(bitset_large), intent(in) :: set1, set2 + end function gt_large + + elemental module function gt_64(set1, set2) result(gt) + logical :: gt + type(bitset_64), intent(in) :: set1, set2 + end function gt_64 + + end interface operator(>) + + + interface operator(>=) +!! Version: experimental +!! +!! Returns `.true.` if the bits in `set1` and `set2` are the same or the +!! highest order different bit is set to 1 in `set1` and to 0 in `set2`, +!! `.false.` otherwise. The sets must have the same number of bits +!! otherwise the result is undefined. +!! ([Specification](../page/specs/stdlib_bitsets.html#gt-compare-two-bitsets-to-determine-whether-the-first-is-greater-than-or-equal-to-the-second)) +!! +!!#### Example +!! +!!```fortran +!! program demo_ge +!! use stdlib_bitsets +!! type(bitset_64) :: set0, set1, set2 +!! call set0 % init( 33 ) +!! call set1 % init( 33 ) +!! call set2 % init( 33 ) +!! call set1 % set( 0 ) +!! call set2 % set( 32 ) +!! if ( set1 >= set0 .and. set2 >= set1 .and. set2 >= set0 .and. & +!! set0 >= set0 .and. set1 >= set1 .and. set2 >= set2 .and. & +!! .not. set0 >= set1 .and. .not. set0 >= set2 .and. .not. & +!! set1 >= set2 ) then +!! write(*,*) 'Passed 64 bit greater than or equals tests.' +!! else +!! error stop 'Failed 64 bit greater than or equals tests.' +!! end if +!! end program demo_ge +!!``` + elemental module function ge_large(set1, set2) result(ge) + logical :: ge + type(bitset_large), intent(in) :: set1, set2 + end function ge_large + + elemental module function ge_64(set1, set2) result(ge) + logical :: ge + type(bitset_64), intent(in) :: set1, set2 + end function ge_64 + + end interface operator(>=) + + + interface operator(<) +!! Version: experimental +!! +!! Returns `.true.` if the bits in `set1` and `set2` differ and the +!! highest order different bit is set to 0 in `set1` and to 1 in `set2`, +!! `.false.` otherwise. The sets must have the same number of bits +!! otherwise the result is undefined. +!!([Specification](../page/specs/stdlib_bitsets.html#lt-compare-two-bitsets-to-determine-whether-the-first-is-less-than-the-other)) +!! +!!#### Example +!! +!!```fortran +!! program demo_lt +!! use stdlib_bitsets +!! type(bitset_64) :: set0, set1, set2 +!! call set0 % init( 33 ) +!! call set1 % init( 33 ) +!! call set2 % init( 33 ) +!! call set1 % set( 0 ) +!! call set2 % set( 32 ) +!! if ( set0 < set1 .and. set1 < set2 .and. set0 < set2 .and. & +!! .not. set0 < set0 .and. .not. set2 < set0 .and. .not. & +!! set2 < set1 ) then +!! write(*,*) 'Passed 64 bit less than tests.' +!! else +!! error stop 'Failed 64 bit less than tests.' +!! end if +!! end program demo_lt +!!``` + elemental module function lt_large(set1, set2) result(lt) + logical :: lt + type(bitset_large), intent(in) :: set1, set2 + end function lt_large + + elemental module function lt_64(set1, set2) result(lt) + logical :: lt + type(bitset_64), intent(in) :: set1, set2 + end function lt_64 + + end interface operator(<) + + + interface operator(<=) +!! Version: experimental +!! +!! Returns `.true.` if the bits in `set1` and `set2` are the same or the +!! highest order different bit is set to 0 in `set1` and to 1 in `set2`, +!! `.false.` otherwise. The sets must have the same number of bits +!! otherwise the result is undefined. +!!([Specification](../page/specs/stdlib_bitsets.html#lt-compare-two-bitsets-to-determine-whether-the-first-is-less-than-or-equal-to-the-other)) +!! +!!#### Example +!! +!!```fortran +!! program demo_le +!! use stdlib_bitsets +!! type(bitset_64) :: set0, set1, set2 +!! call set0 % init( 33 ) +!! call set1 % init( 33 ) +!! call set2 % init( 33 ) +!! call set1 % set( 0 ) +!! call set2 % set( 32 ) +!! if ( set0 <= set1 .and. set1 <= set2 .and. set0 <= set2 .and. & +!! set0 <= set0 .and. set1 <= set1 .and. set2 <= set2 .and. & +!! .not. set1 <= set0 .and. .not. set2 <= set0 .and. .not. & +!! set2 <= set1 ) then +!! write(*,*) 'Passed 64 bit less than or equal tests.' +!! else +!! error stop 'Failed 64 bit less than or equal tests.' +!! end if +!! end program demo_le +!!``` + elemental module function le_large(set1, set2) result(le) + logical :: le + type(bitset_large), intent(in) :: set1, set2 + end function le_large + + elemental module function le_64(set1, set2) result(le) + logical :: le + type(bitset_64), intent(in) :: set1, set2 + end function le_64 + + end interface operator(<=) + + interface error_handler + module subroutine error_handler( message, error, status, & + module, procedure ) + character(*), intent(in) :: message + integer, intent(in) :: error + integer, intent(out), optional :: status + character(*), intent(in), optional :: module + character(*), intent(in), optional :: procedure + end subroutine error_handler + end interface error_handler + +contains + + elemental function bits(self) +!! Version: experimental +!! +!! Returns the number of bit positions in `self`. + integer(bits_kind) :: bits + class(bitset_type), intent(in) :: self + + bits = self % num_bits + + return + end function bits + + module subroutine error_handler( message, error, status, module, procedure ) + character(*), intent(in) :: message + integer, intent(in) :: error + integer, intent(out), optional :: status + character(*), intent(in), optional :: module + character(*), intent(in), optional :: procedure + + if ( present(status) ) then + status = error + else + if ( present(module) ) then + if ( present(procedure) ) then + write(error_unit, '(a)') trim(module) // ' % ' // & + trim(procedure) // ': ' // trim(message) + else + write(error_unit, '(a)') trim(module) // ' % N/A: ' // & + trim(message) + end if + else if ( present(procedure) ) then + write(error_unit, '(a)') trim(procedure) // ': ' // & + trim(message) + else + write(error_unit, '(a)') trim(message) + end if + select case(error) + case( alloc_fault ) + error stop 'A memory allocation failed.' + case( array_size_invalid_error ) + error stop "An array size was invalid." + case( char_string_invalid_error ) + error stop "A character string had an invalid character." + case( char_string_too_large_error ) + error stop "A character string was too large." + case( char_string_too_small_error ) + error stop "A character string was too small." + case( eof_failure ) + error stop "An End-Of-File failure occurred on a READ " // & + "statement." + case( index_invalid_error ) + error stop "An index was invalid." + case( integer_overflow_error ) + error stop "An integer overflow error occurred." + case( read_failure ) + error stop "A failure occurred in a READ statement." + case( write_failure ) + error stop "A failure occurred on a WRITE statement." + end select + end if + end subroutine error_handler + + +end module stdlib_bitsets diff --git a/src/fpm/stdlib_bitsets_64.f90 b/src/fpm/stdlib_bitsets_64.f90 new file mode 100644 index 000000000..e999bf497 --- /dev/null +++ b/src/fpm/stdlib_bitsets_64.f90 @@ -0,0 +1,1245 @@ +submodule(stdlib_bitsets) stdlib_bitsets_64 + implicit none + +contains + + elemental module function all_64( self ) result(all) +! Returns .TRUE. if all bits in SELF are 1, .FALSE. otherwise. + logical :: all + class(bitset_64), intent(in) :: self + + intrinsic :: btest + integer(bits_kind) :: pos + + do pos=0, self % num_bits - 1 + if ( .not. btest(self % block, pos) ) then + all = .false. + return + end if + end do + all = .true. + + end function all_64 + + + elemental module subroutine and_64(set1, set2) +! +! Sets the bits in SET1 to the bitwise AND of the original bits in SET1 +! and SET2. It is required that SET1 have the same number of bits as +! SET2 otherwise the result is undefined. +! + type(bitset_64), intent(inout) :: set1 + type(bitset_64), intent(in) :: set2 + +! The set2 extent includes the entire extent of set1. +! The (zeroed) region past the end of set1 is unaffected by +! the iand. + set1 % block = iand( set1 % block, & + set2 % block ) + + end subroutine and_64 + + + elemental module subroutine and_not_64(set1, set2) +! +! Sets the bits in SET1 to the bitwise and of the original bits in SET1 +! with the bitwise negation of SET2. SET1 and SET2 must have the same +! number of bits otherwise the result is undefined. +! + type(bitset_64), intent(inout) :: set1 + type(bitset_64), intent(in) :: set2 + +! The not with iand means that the zero'ed regions past the end of each set +! do not interact with the in set regions + set1 % block = iand( set1 % block, not( set2 % block ) ) + + end subroutine and_not_64 + + + elemental module function any_64(self) result(any) +! Returns .TRUE. if any bit in SELF is 1, .FALSE. otherwise. + logical :: any + class(bitset_64), intent(in) :: self + + if ( self % block /= 0 ) then + any = .true. + return + else + any = .false. + end if + + end function any_64 + + + pure module subroutine assign_64( set1, set2 ) +! Used to define assignment for bitset_64 + type(bitset_64), intent(out) :: set1 + type(bitset_64), intent(in) :: set2 + + set1 % num_bits = set2 % num_bits + set1 % block = set2 % block + + end subroutine assign_64 + + + module subroutine assign_logint8_64( self, logical_vector ) +! Used to define assignment from an array of type logical for bitset_64 + type(bitset_64), intent(out) :: self + logical(int8), intent(in) :: logical_vector(:) + + integer(bits_kind) :: log_size + integer(bits_kind) :: index + + log_size = size( logical_vector, kind=bits_kind ) + if ( log_size > 64 ) then + error stop module_name // ' % ' // 'ASSIGNMENT' // " has " // & + "SIZE(LOGICAL_VECTOR) > 64 with assignment to a BITSET_64." + end if + self % num_bits = log_size + self % block = 0 + + do index=0, log_size-1 + if ( logical_vector(index+1) ) then + self % block = ibset( self % block, index ) + end if + end do + + end subroutine assign_logint8_64 + + + pure module subroutine logint8_assign_64( logical_vector, set ) +! Used to define assignment to an array of type logical for bitset_64 + logical(int8), intent(out), allocatable :: logical_vector(:) + type(bitset_64), intent(in) :: set + + integer(bits_kind) :: index + + allocate( logical_vector( set % num_bits ) ) + do index=0, set % num_bits-1 + if ( set % value( index ) == 1 ) then + logical_vector(index+1) = .true. + else + logical_vector(index+1) = .false. + end if + end do + + end subroutine logint8_assign_64 + module subroutine assign_logint16_64( self, logical_vector ) +! Used to define assignment from an array of type logical for bitset_64 + type(bitset_64), intent(out) :: self + logical(int16), intent(in) :: logical_vector(:) + + integer(bits_kind) :: log_size + integer(bits_kind) :: index + + log_size = size( logical_vector, kind=bits_kind ) + if ( log_size > 64 ) then + error stop module_name // ' % ' // 'ASSIGNMENT' // " has " // & + "SIZE(LOGICAL_VECTOR) > 64 with assignment to a BITSET_64." + end if + self % num_bits = log_size + self % block = 0 + + do index=0, log_size-1 + if ( logical_vector(index+1) ) then + self % block = ibset( self % block, index ) + end if + end do + + end subroutine assign_logint16_64 + + + pure module subroutine logint16_assign_64( logical_vector, set ) +! Used to define assignment to an array of type logical for bitset_64 + logical(int16), intent(out), allocatable :: logical_vector(:) + type(bitset_64), intent(in) :: set + + integer(bits_kind) :: index + + allocate( logical_vector( set % num_bits ) ) + do index=0, set % num_bits-1 + if ( set % value( index ) == 1 ) then + logical_vector(index+1) = .true. + else + logical_vector(index+1) = .false. + end if + end do + + end subroutine logint16_assign_64 + module subroutine assign_logint32_64( self, logical_vector ) +! Used to define assignment from an array of type logical for bitset_64 + type(bitset_64), intent(out) :: self + logical(int32), intent(in) :: logical_vector(:) + + integer(bits_kind) :: log_size + integer(bits_kind) :: index + + log_size = size( logical_vector, kind=bits_kind ) + if ( log_size > 64 ) then + error stop module_name // ' % ' // 'ASSIGNMENT' // " has " // & + "SIZE(LOGICAL_VECTOR) > 64 with assignment to a BITSET_64." + end if + self % num_bits = log_size + self % block = 0 + + do index=0, log_size-1 + if ( logical_vector(index+1) ) then + self % block = ibset( self % block, index ) + end if + end do + + end subroutine assign_logint32_64 + + + pure module subroutine logint32_assign_64( logical_vector, set ) +! Used to define assignment to an array of type logical for bitset_64 + logical(int32), intent(out), allocatable :: logical_vector(:) + type(bitset_64), intent(in) :: set + + integer(bits_kind) :: index + + allocate( logical_vector( set % num_bits ) ) + do index=0, set % num_bits-1 + if ( set % value( index ) == 1 ) then + logical_vector(index+1) = .true. + else + logical_vector(index+1) = .false. + end if + end do + + end subroutine logint32_assign_64 + module subroutine assign_logint64_64( self, logical_vector ) +! Used to define assignment from an array of type logical for bitset_64 + type(bitset_64), intent(out) :: self + logical(int64), intent(in) :: logical_vector(:) + + integer(bits_kind) :: log_size + integer(bits_kind) :: index + + log_size = size( logical_vector, kind=bits_kind ) + if ( log_size > 64 ) then + error stop module_name // ' % ' // 'ASSIGNMENT' // " has " // & + "SIZE(LOGICAL_VECTOR) > 64 with assignment to a BITSET_64." + end if + self % num_bits = log_size + self % block = 0 + + do index=0, log_size-1 + if ( logical_vector(index+1) ) then + self % block = ibset( self % block, index ) + end if + end do + + end subroutine assign_logint64_64 + + + pure module subroutine logint64_assign_64( logical_vector, set ) +! Used to define assignment to an array of type logical for bitset_64 + logical(int64), intent(out), allocatable :: logical_vector(:) + type(bitset_64), intent(in) :: set + + integer(bits_kind) :: index + + allocate( logical_vector( set % num_bits ) ) + do index=0, set % num_bits-1 + if ( set % value( index ) == 1 ) then + logical_vector(index+1) = .true. + else + logical_vector(index+1) = .false. + end if + end do + + end subroutine logint64_assign_64 + + + elemental module function bit_count_64(self) result(bit_count) +! Returns the number of non-zero bits in SELF. + integer(bits_kind) :: bit_count + class(bitset_64), intent(in) :: self + + integer(bits_kind) :: pos + + bit_count = 0 + + do pos = 0, self % num_bits - 1 + if ( btest( self % block, pos ) ) bit_count = bit_count + 1 + end do + + end function bit_count_64 + + + elemental module subroutine clear_bit_64(self, pos) +! +! Sets to zero the POS position in SELF. If POS is less than zero or +! greater than BITS(SELF)-1 it is ignored. +! + class(bitset_64), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + + if ( pos < 0 .OR. (pos > self % num_bits-1) ) & + return + self % block = ibclr( self % block, pos ) + + end subroutine clear_bit_64 + + + pure module subroutine clear_range_64(self, start_pos, stop_pos) +! +! Sets to zero all bits from the START_POS to STOP_POS positions in SELF. +! If STOP_POS < START_POS then no bits are modified. Positions outside +! the range 0 to BITS(SELF)-1 are ignored. +! + class(bitset_64), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + + integer(bits_kind) :: true_first, true_last + + true_first = max( 0_bits_kind, start_pos ) + true_last = min( self % num_bits-1, stop_pos ) + if ( true_last < true_first ) return + + call mvbits( all_zeros, & + true_first, & + true_last - true_first + 1, & + self % block, & + true_first ) + + end subroutine clear_range_64 + + + elemental module function eqv_64(set1, set2) result(eqv) +! +! Returns .TRUE. if all bits in SET1 and SET2 have the same value, +! .FALSE. otherwise. The sets must have the same number of bits +! otherwise the results are undefined. +! + logical :: eqv + type(bitset_64), intent(in) :: set1, set2 + + eqv = set1 % block == set2 % block + + end function eqv_64 + + + module subroutine extract_64(new, old, start_pos, stop_pos, status) +! Creates a new bitset, NEW, from a range, START_POS to STOP_POS, in bitset +! OLD. If START_POS is greater than STOP_POS the new bitset is empty. +! If START_POS is less than zero or STOP_POS is greater than BITS(OLD)-1 +! then if STATUS is present it has the value INDEX_INVALID_ERROR, +! otherwise processing stops with an informative message. + type(bitset_64), intent(out) :: new + type(bitset_64), intent(in) :: old + integer(bits_kind), intent(in) :: start_pos, stop_pos + integer, intent(out), optional :: status + + integer(bits_kind) :: bits, i, k + character(*), parameter :: procedure = 'EXTRACT' + + if ( start_pos < 0 ) then + call error_handler( 'had a START_POS less than 0.', & + index_invalid_error, status, & + module_name, procedure ) + return + end if + if ( stop_pos >= old % num_bits ) then + call error_handler( 'had a STOP_POS greater than BITS(OLD)-1.', & + index_invalid_error, status, & + module_name, procedure ) + return + end if + bits = stop_pos - start_pos + 1 + + if ( bits <= 0 ) then + new % num_bits = 0 + new % block = 0 + return + else + new % num_bits = bits + do i=0, bits-1 + k = start_pos + i + if ( btest( old % block, k ) ) & + new % block = ibset(new % block, i) + end do + end if + + if ( present(status) ) status = success + + end subroutine extract_64 + + + elemental module subroutine flip_bit_64(self, pos) +! +! Flips the value at the POS position in SELF, provided the position is +! valid. If POS is less than 0 or greater than BITS(SELF)-1, no value is +! changed. +! + class(bitset_64), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + + if ( pos < 0 .OR. pos > self % num_bits-1 ) return + + if ( btest( self % block, pos ) ) then + self % block = ibclr( self % block, pos ) + else + self % block = ibset( self % block, pos ) + end if + + end subroutine flip_bit_64 + + + pure module subroutine flip_range_64(self, start_pos, stop_pos) +! +! Flips all valid bits from the START_POS to the STOP_POS positions in +! SELF. If STOP_POS < START_POS no bits are flipped. Positions less than +! 0 or greater than BITS(SELF)-1 are ignored. +! + class(bitset_64), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + + integer(bits_kind) :: end_bit, start_bit + + start_bit = max( 0_bits_kind, start_pos ) + end_bit = min( stop_pos , self % num_bits-1 ) + call mvbits( not(self % block), & + start_bit, & + end_bit - start_bit + 1, & + self % block, & + start_bit ) + + end subroutine flip_range_64 + + + module subroutine from_string_64(self, string, status) +! Initializes the bitset `self` treating `string` as a binary literal +! `status` may have the values: +! `success` - if no problems were found, +! `alloc_fault` - if allocation of the bitset failed +! `char_string_too_large_error` - if `string` was too large, or +! `char_string_invalid_error` - if string had an invalid character. + class(bitset_64), intent(out) :: self + character(*), intent(in) :: string + integer, intent(out), optional :: status + + character(*), parameter :: procedure = 'FROM_STRING' + integer(int64) :: bit + integer(int64) :: bits + character(1) :: char + + bits = len(string, kind=int64) + if ( bits > 64 ) then + call error_handler( 'STRING was too long for a ' // & + 'BITSET_64 SELF.', & + char_string_too_large_error, status, & + module_name, procedure ) + return + end if + self % num_bits = bits + do bit = 1, bits + char = string(bit:bit) + if ( char == '0' ) then + call self % clear( int(bits-bit, kind=bits_kind) ) + else if ( char == '1' ) then + call self % set( int(bits-bit, kind=bits_kind) ) + else + call error_handler( 'STRING had a character other than ' // & + '0 or 1.', & + char_string_invalid_error, status, & + module_name, procedure ) + return + end if + end do + + if ( present(status) ) status = success + + end subroutine from_string_64 + + + elemental module function ge_64(set1, set2) result(ge) +! +! Returns .TRUE. if the bits in SET1 and SET2 are the same or the +! highest order different bit is set to 1 in SET1 and to 0 in set2. +! .FALSE. otherwise. The sets must have the same number of bits +! otherwise the results are undefined. +! + logical :: ge + type(bitset_64), intent(in) :: set1, set2 + + ge = bge( set1 % block, set2 % block ) + + end function ge_64 + + + elemental module function gt_64(set1, set2) result(gt) +! +! Returns .TRUE. if the bits in SET1 and SET2 differ and the +! highest order different bit is set to 1 in SET1 and to 0 in set2. +! .FALSE. otherwise. The sets must have the same number of bits +! otherwise the results are undefined. +! + logical :: gt + type(bitset_64), intent(in) :: set1, set2 + + gt = bgt( set1 % block, set2 % block ) + + end function gt_64 + + + module subroutine init_zero_64(self, bits, status) +! +! Creates the bitset, `self`, of size `bits`, with all bits initialized to +! zero. `bits` must be non-negative. If an error occurs and `status` is +! absent then processing stops with an informative stop code. `status` +! will have one of the values: +! * `success` - if no problems were found, +! * `array_size_invalid_error` - if `bits` is either negative or larger +! than 64 with `self` of class `bitset_64`, or +! * `alloc_fault` - if memory allocation failed +! + class(bitset_64), intent(out) :: self + integer(bits_kind), intent(in) :: bits + integer, intent(out), optional :: status + + character(*), parameter :: procedure = "INIT" + + if ( bits < 0 ) then + call error_handler( 'BITS had a negative value.', & + array_size_invalid_error, status, & + module_name, procedure ) + return + end if + if ( bits > 64 ) then + call error_handler( 'BITS had a value greater than 64.', & + array_size_invalid_error, status, & + module_name, procedure ) + return + end if + + self % num_bits = bits + self % block = all_zeros + + if ( present(status) ) status = success + + end subroutine init_zero_64 + + + module subroutine input_64(self, unit, status) +! +! Reads the components of the bitset, `self`, from the unformatted I/O +! unit, `unit`, assuming that the components were written using `output`. +! If an error occurs and `status` is absent then processing stops with +! an informative stop code. `status` has one of the values: +! * `success` - if no problem was found +! * `alloc_fault` - if it failed during allocation of memory for `self`, or +! * `array_size_invalid_error` if the `bits(self)` in `unit` is negative +! or greater than 64 for a `bitset_64` input. +! * `read_failure` - if it failed during the reads from `unit` +! + class(bitset_64), intent(out) :: self + integer, intent(in) :: unit + integer, intent(out), optional :: status + + integer(bits_kind) :: bits + integer :: ierr + character(len=120) :: message + character(*), parameter :: procedure = 'INPUT' + integer :: stat + + read(unit, iostat=ierr, iomsg=message) bits + if (ierr /= 0) then + call error_handler( 'Failure on a READ statement for UNIT.', & + read_failure, status, module_name, procedure ) + return + end if + if ( bits < 0 ) then + call error_handler( 'BITS in UNIT had a negative value.', & + array_size_invalid_error, status, & + module_name, procedure ) + return + end if + if ( bits > 64 ) then + call error_handler( 'BITS in UNIT had a value greater than 64.', & + array_size_invalid_error, status, & + module_name, procedure ) + return + end if + + call self % init(bits, stat) + if (stat /= success) then + call error_handler( 'Allocation failure for SELF.', & + alloc_fault, status, module_name, procedure ) + return + end if + + if (bits < 1) return + + read(unit, iostat=ierr, iomsg=message) self % block + if (ierr /= 0) then + call error_handler( 'Failure on a READ statement for UNIT.', & + read_failure, status, module_name, procedure ) + return + end if + + if ( present(status) ) status = success + + end subroutine input_64 + + + elemental module function le_64(set1, set2) result(le) +! +! Returns .TRUE. if the bits in SET1 and SET2 are the same or the +! highest order different bit is set to 0 in SET1 and to 1 in set2. +! .FALSE. otherwise. The sets must have the same number of bits +! otherwise the results are undefined. +! + logical :: le + type(bitset_64), intent(in) :: set1, set2 + + le = ble( set1 % block, set2 % block ) + + end function le_64 + + + elemental module function lt_64(set1, set2) result(lt) +! +! Returns .TRUE. if the bits in SET1 and SET2 differ and the +! highest order different bit is set to 0 in SET1 and to 1 in set2. +! .FALSE. otherwise. The sets must have the same number of bits +! otherwise the results are undefined. +! + logical :: lt + type(bitset_64), intent(in) :: set1, set2 + + lt = blt( set1 % block, set2 % block ) + + end function lt_64 + + + elemental module function neqv_64(set1, set2) result(neqv) +! +! Returns .TRUE. if all bits in SET1 and SET2 have the same value, +! .FALSE. otherwise. The sets must have the same number of bits +! otherwise the results are undefined. +! + logical :: neqv + type(bitset_64), intent(in) :: set1, set2 + + neqv = set1 % block /= set2 % block + + end function neqv_64 + + + elemental module function none_64(self) result(none) +! +! Returns .TRUE. if none of the bits in SELF have the value 1. +! + logical :: none + class(bitset_64), intent(in) :: self + + none = .true. + if (self % block /= 0) then + none = .false. + return + end if + + end function none_64 + + + elemental module subroutine not_64(self) +! +! Sets the bits in SELF to their logical complement +! + class(bitset_64), intent(inout) :: self + + integer(bits_kind) :: bit + + if ( self % num_bits == 0 ) return + + do bit=0, self % num_bits - 1 + if ( btest( self % block, bit ) ) then + self % block = ibclr( self % block, bit ) + else + self % block = ibset( self % block, bit ) + end if + end do + + end subroutine not_64 + + + elemental module subroutine or_64(set1, set2) +! +! Sets the bits in SET1 to the bitwise OR of the original bits in SET1 +! and SET2. If SET1 has fewer bits than SET2 then the additional bits +! in SET2 are ignored. If SET1 has more bits than SET2, then the +! absent SET2 bits are treated as if present with zero value. +! + type(bitset_64), intent(inout) :: set1 + type(bitset_64), intent(in) :: set2 + + if ( set1 % num_bits >= set2 % num_bits ) then + set1 % block = ior( set1 % block, & + set2 % block ) + else +! The set1 extent ends before set2 => set2 bits must not affect bits in +! set1 beyond its extent => set those bits to zero while keeping proper +! values of other bits in set2 + set1 % block = & + ior( set1 % block, & + ibits( set2 % block, & + 0, & + set1 % num_bits ) ) + end if + + end subroutine or_64 + + + module subroutine output_64(self, unit, status) +! +! Writes the components of the bitset, SELF, to the unformatted I/O +! unit, UNIT, in a unformatted sequence compatible with INPUT. If +! STATUS is absent an error results in an error stop with an +! informative stop code. If STATUS is present it has the default +! value of SUCCESS, or the value WRITE_FAILURE if the write failed. +! + class(bitset_64), intent(in) :: self + integer, intent(in) :: unit + integer, intent(out), optional :: status + + integer :: ierr + character(len=120) :: message + character(*), parameter :: procedure = "OUTPUT" + + write(unit, iostat=ierr, iomsg=message) self % num_bits + if (ierr /= 0) go to 999 + + if (self % num_bits < 1) return + write(unit, iostat=ierr, iomsg=message) self % block + if (ierr /= 0) go to 999 + + return + +999 call error_handler( 'Failure on a WRITE statement for UNIT.', & + write_failure, status, module_name, procedure ) + + end subroutine output_64 + + + module subroutine read_bitset_string_64(self, string, status) +! +! Uses the bitset literal in the default character `string`, to define +! the bitset, `self`. The literal may be preceded by an an arbitrary +! sequence of blank characters. If `status` is absent an error results +! in an error stop with an informative stop code. If `status` +! is present it has one of the values +! * `success` - if no problems occurred, +! * `alloc_fault` - if allocation of memory for SELF failed, +! * `array_size_invalid_error - if `bits(self)` in `string` is greater +! than 64 for a `bitset_64`, +! * `char_string_invalid_error` - if the bitset literal has an invalid +! character, +! * `char_string_too_small_error - if the string ends before all the bits +! are read. +! * `integer_overflow_error` - if the bitset literal has a `bits(self)` +! value too large to be represented, +! + class(bitset_64), intent(out) :: self + character(len=*), intent(in) :: string + integer, intent(out), optional :: status + + integer(bits_kind) :: bit, bits + integer(bits_kind) :: digits, pos + character(*), parameter :: procedure = "READ_BITSET" + integer :: stat + + pos = 1 + find_start: do pos=1, len(string) + if ( string(pos:pos) /= ' ' ) exit + end do find_start + + if ( pos > len(string) - 8 ) go to 999 + + if ( string(pos:pos) /= 's' .AND. string(pos:pos) /= 'S' ) go to 999 + + pos = pos + 1 + bits = 0 + digits = 0 + + do + select case( iachar( string(pos:pos) ) ) + case(ia0:ia9) + digits = digits + 1 + if ( digits == max_digits .AND. bits > overflow_bits ) & + go to 996 + if ( digits > max_digits ) go to 996 + bits = bits*10 + iachar( string(pos:pos) ) - ia0 + if ( bits < 0 ) go to 996 + case(iachar('b'), iachar('B')) + exit + case default + go to 999 + end select + + pos = pos + 1 + + end do + + if ( bits > 64 ) then + call error_handler( 'BITS in STRING was greater than 64.', & + char_string_too_large_error, status, & + module_name, procedure ) + return + end if + if ( bits + pos > len(string) ) then + call error_handler( 'STRING was too small for the number of ' // & + 'bits specified by STRING.', & + char_string_too_small_error, status, & + module_name, procedure ) + return + end if + call self % init( bits, stat ) + if (stat /= success) then + call error_handler( 'There was an allocation fault for SELF.', & + alloc_fault, status, module_name, procedure ) + return + end if + + pos = pos + 1 + bit = bits - 1 + do + if ( string(pos:pos) == '0' ) then + call self % clear( bit ) ! this may not be needed + else if ( string(pos:pos) == '1' ) then + call self % set( bit ) + else + go to 999 + end if + pos = pos + 1 + bit = bit - 1 + if ( bit < 0 ) exit + end do + + if ( present(status) ) status = success + + return + +996 call error_handler( 'There was an integer overflow in reading' // & + 'size of bitset literal from UNIT', & + integer_overflow_error, status, & + module_name, procedure ) + return + +999 call error_handler( 'There was an invalid character in STRING', & + char_string_invalid_error, status, & + module_name, procedure ) + + end subroutine read_bitset_string_64 + + + module subroutine read_bitset_unit_64(self, unit, advance, status) +! +! Uses the bitset literal at the current position in the formatted +! file with I/O unit, `unit`, to define the bitset, `self`. The literal +! may be preceded by an arbitrary sequence of blank characters. +! If `advance` is present it must be either 'YES' or 'NO'. If absent +! it has the default value of 'YES' to determine whether advancing +! I/O occurs. If `status` is absent an error results in an error stop +! with an informative stop code. If `status` is present it has one of +! the values: +! * `success` - if no problem occurred, +! * `alloc_fault` - if allocation of `self` failed, +! * `array_size_invalid_error` - if `bits(self)` in the bitset literal +! is greater than 64 for a `bitset_64`. +! * `char_string_invalid_error` - if the read of the bitset literal found +! an invalid character, +! * `eof_failure` - if a `read` statement reaches an end-of-file before +! completing the read of the bitset literal, +! * `integer_overflow_error` - if the bitset literal has a `bits(self)` +! value too large to be represented, +! * `read_failure` - if a `read` statement fails, +! + class(bitset_64), intent(out) :: self + integer, intent(in) :: unit + character(*), intent(in), optional :: advance + integer, intent(out), optional :: status + + integer(bits_kind) :: bit, bits, digits + integer :: ierr + character(len=128) :: message + character(*), parameter :: procedure = "READ_BITSET" + character(len=1) :: char + + do + read( unit, & + advance='NO', & + FMT='(A1)', & + err=997, & + end=998, & + iostat=ierr, & + iomsg=message ) char + select case( char ) + case( ' ' ) + cycle + case( 's', 'S' ) + exit + case default + go to 999 + end select + end do + + bits = 0 + digits = 0 + do + read( unit, & + advance='NO', & + FMT='(A1)', & + err=998, & + end=999, & + iostat=ierr, & + iomsg=message ) char + if ( char == 'b' .or. char == 'B' ) exit + select case( char ) + case( '0', '1', '2', '3', '4', '5', '6', '7', '8', '9' ) + digits = digits + 1 + if ( digits == max_digits .AND. bits > overflow_bits ) & + go to 996 + if ( digits > max_digits ) go to 996 + bits = 10*bits + iachar(char) - iachar('0') + if ( bits < 0 ) go to 996 + case default + go to 999 + end select + end do + + if ( bits < 0 .OR. digits == 0 .OR. digits > max_digits ) go to 999 + + if ( bits > 64 ) then + call error_handler( 'BITS in UNIT was greater than 64.', & + array_size_invalid_error, status, & + module_name, procedure ) + return + end if + call self % init( bits ) + do bit = 1, bits-1 + read( unit, & + advance='NO', & + FMT='(A1)', & + err=997, & + end=998, & + iostat=ierr, & + iomsg=message ) char + if ( char == '0' ) then + call self % clear( bits-bit ) + else if ( char == '1' ) then + call self % set( bits-bit ) + else + go to 999 + end if + end do + + if ( present(advance) ) then + read( unit, & + advance=advance, & + FMT='(A1)', & + err=997, & + end=998, & + iostat=ierr, & + iomsg=message ) char + else + read( unit, & + advance='YES', & + FMT='(A1)', & + err=997, & + end=998, & + iostat=ierr, & + iomsg=message ) char + end if + if ( char == '0' ) then + call self % clear( bits-bit ) + else if ( char == '1' ) then + call self % set( bits-bit ) + else + go to 999 + end if + + if ( present(status) ) status = success + + return + +996 call error_handler( 'Integer overflow in reading size of ' // & + 'bitset literal from UNIT.', & + read_failure, status, module_name, procedure ) + return + +997 call error_handler( 'Failure on read of UNIT.', & + read_failure, status, module_name, procedure ) + return + +998 call error_handler( 'End of File of UNIT before finishing a ' // & + 'bitset literal.', & + eof_failure, status, module_name, procedure ) + return + +999 call error_handler( 'Invalid character in bitset literal in UNIT ', & + char_string_invalid_error, status, & + module_name, procedure ) + + end subroutine read_bitset_unit_64 + + + elemental module subroutine set_bit_64(self, pos) +! +! Sets the value at the POS position in SELF, provided the position is +! valid. If the position is less than 0 or greater than BITS(SELF)-1 +! then SELF is unchanged. +! + class(bitset_64), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + integer(block_kind) :: dummy + + if ( pos < 0 .OR. pos > self % num_bits-1 ) return + dummy = ibset( self % block, pos ) + self % block = dummy + + end subroutine set_bit_64 + + + pure module subroutine set_range_64(self, start_pos, stop_pos) +! +! Sets all valid bits to 1 from the START_POS to the STOP_POS positions +! in SELF. If STOP_POA < START_POS no bits are changed. Positions outside +! the range 0 to BITS(SELF)-1 are ignored. +! + class(bitset_64), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + + integer(bits_kind) :: end_bit, start_bit + + start_bit = max( 0_bits_kind, start_pos ) + end_bit = min( stop_pos, self % num_bits-1 ) + if ( end_bit < start_bit ) return + +! FIRST and LAST are in the same block + call mvbits( all_ones, & + start_bit, & + end_bit - start_bit + 1, & + self % block, & + start_bit ) + + end subroutine set_range_64 + + + elemental module function test_64(self, pos) result(test) +! +! Returns .TRUE. if the POS position is set, .FALSE. otherwise. If POS +! is negative or greater than BITS(SELF) - 1 the result is .FALSE.. +! + logical :: test + class(bitset_64), intent(in) :: self + integer(bits_kind), intent(in) :: pos + + if ( pos < 0 .or. pos >= self % num_bits ) then + test = .false. + else + test = btest( self % block, pos ) + end if + + end function test_64 + + + module subroutine to_string_64(self, string, status) +! +! Represents the value of SELF as a binary literal in STRING +! Status may have the values SUCCESS or ALLOC_FAULT +! + class(bitset_64), intent(in) :: self + character(len=:), allocatable, intent(out) :: string + integer, intent(out), optional :: status + + character(*), parameter :: procedure = 'TO_STRING' + integer :: bit, bit_count, pos, stat + + bit_count = self % num_bits + allocate( character(len=bit_count)::string, stat=stat ) + if ( stat > 0 ) then + call error_handler( 'There was an allocation fault for STRING.', & + alloc_fault, status, module_name, procedure ) + return + end if + do bit=0, bit_count-1 + pos = bit_count - bit + if ( btest( self % block, bit ) ) then + string( pos:pos ) = '1' + else + string( pos:pos ) = '0' + end if + end do + + if ( present(status) ) status = success + + end subroutine to_string_64 + + + elemental module function value_64(self, pos) result(value) +! +! Returns 1 if the POS position is set, 0 otherwise. If POS is negative +! or greater than BITS(SELF) - 1 the result is 0. +! + integer :: value + class(bitset_64), intent(in) :: self + integer(bits_kind), intent(in) :: pos + + if ( pos < 0 .or. pos >= self % num_bits ) then + value = 0 + + else + if ( btest( self % block, pos ) ) then + value = 1 + + else + value = 0 + + end if + + end if + + end function value_64 + + + module subroutine write_bitset_string_64(self, string, status) +! +! Writes a bitset literal to the allocatable default character STRING, +! representing the individual bit values in the bitset_t, SELF. +! If STATUS is absent an error results in an error stop with an +! informative stop code. If STATUS is present it has the default +! value of SUCCESS, or the value ALLOC_FAULT if allocation of +! the output string failed. +! + class(bitset_64), intent(in) :: self + character(len=:), allocatable, intent(out) :: string + integer, intent(out), optional :: status + + integer(bits_kind) :: bit, & + bit_count, & + count_digits, & + pos + integer :: stat + + character(*), parameter :: procedure = 'WRITE_BITSET' + + bit_count = bits(self) + + call digit_count( self % num_bits, count_digits ) + + allocate( character(len=count_digits+bit_count+2)::string, stat=stat ) + if ( stat > 0 ) then + call error_handler( 'There was an allocation fault for STRING.', & + alloc_fault, status, module_name, procedure ) + return + end if + write( string, "('S', i0)" ) self % num_bits + + string( count_digits + 2:count_digits + 2 ) = "B" + do bit=0, bit_count-1 + pos = count_digits + 2 + bit_count - bit + if ( btest( self % block, bit ) ) then + string( pos:pos ) = '1' + else + string( pos:pos ) = '0' + end if + end do + + if ( present(status) ) status = success + + contains + + subroutine digit_count( bits, digits ) + integer(bits_kind), intent(in) :: bits + integer(bits_kind), intent(out) :: digits + + integer(bits_kind) :: factor + + factor = bits + + if ( factor <= 0 ) then + digits = 1 + return + end if + + do digits = 1, 127 + factor = factor / 10 + if ( factor == 0 ) return + end do + + end subroutine digit_count + + end subroutine write_bitset_string_64 + + + module subroutine write_bitset_unit_64(self, unit, advance, status) +! +! Writes a bitset literal to the I/O unit, UNIT, representing the +! individual bit values in the bitset_t, SELF. By default or if +! ADVANCE is present with the value 'YES', advancing output is used. +! If ADVANCE is present with the value 'NO', then the current record +! is not advanced by the write. If STATUS is absent an error results +! in an error stop with an informative stop code. If STATUS is +! present it has the default value of SUCCESS, the value +! ALLOC_FAULT if allocation of the output string failed, or +! WRITE_FAILURE if the WRITE statement outputting the literal failed. +! + class(bitset_64), intent(in) :: self + integer, intent(in) :: unit + character(len=*), intent(in), optional :: advance + integer, intent(out), optional :: status + + integer :: ierr + character(:), allocatable :: string + character(len=120) :: message + character(*), parameter :: procedure = "WRITE_BITSET" + + call self % write_bitset(string, status) + + if ( present(status) ) then + if (status /= success ) return + end if + + + if ( present( advance ) ) then + write( unit, & + FMT='(A)', & + advance=advance, & + iostat=ierr, & + iomsg=message ) & + string + else + write( unit, & + FMT='(A)', & + advance='YES', & + iostat=ierr, & + iomsg=message ) & + string + end if + if (ierr /= 0) then + call error_handler( 'Failure on a WRITE statement for UNIT.', & + write_failure, status, module_name, procedure ) + return + endif + + end subroutine write_bitset_unit_64 + + + elemental module subroutine xor_64(set1, set2) +! +! Sets the bits in SET1 to the bitwise XOR of the original bits in SET1 +! and SET2. SET1 and SET2 must have the same number of bits otherwise +! the result is undefined. +! + type(bitset_64), intent(inout) :: set1 + type(bitset_64), intent(in) :: set2 + + set1 % block = ieor( set1 % block, & + set2 % block ) + + end subroutine xor_64 + + +end submodule stdlib_bitsets_64 diff --git a/src/fpm/stdlib_bitsets_large.f90 b/src/fpm/stdlib_bitsets_large.f90 new file mode 100644 index 000000000..8e3297d65 --- /dev/null +++ b/src/fpm/stdlib_bitsets_large.f90 @@ -0,0 +1,1479 @@ +submodule(stdlib_bitsets) stdlib_bitsets_large + implicit none + +contains + + + elemental module function all_large( self ) result(all) +! Returns .TRUE. if all bits in SELF are 1, .FALSE. otherwise. + logical :: all + class(bitset_large), intent(in) :: self + + integer(bits_kind) :: block, full_blocks, pos + + all = .true. + full_blocks = bits(self)/block_size + do block = 1_bits_kind, full_blocks + if ( self % blocks(block) /= -1_block_kind ) then + all = .false. + return + end if + end do + + if ( full_blocks == size(self % blocks) ) return + + do pos=0_bits_kind, modulo( bits(self), block_size )-1 + if ( .not. btest(self % blocks(full_blocks+1), pos) ) then + all = .false. + return + end if + end do + + end function all_large + + + elemental module subroutine and_large(set1, set2) +! +! Sets the bits in SET1 to the bitwise AND of the original bits in SET1 +! and SET2. It is required that SET1 have the same number of bits as +! SET2 otherwise the result is undefined. +! + type(bitset_large), intent(inout) :: set1 + type(bitset_large), intent(in) :: set2 + + integer(bits_kind) :: block_ + + do block_ = 1_bits_kind, size(set1 % blocks, kind=bits_kind) + set1 % blocks(block_) = iand( set1 % blocks(block_), & + set2 % blocks(block_) ) + end do + + end subroutine and_large + + + elemental module subroutine and_not_large(set1, set2) +! +! Sets the bits in SET1 to the bitwise and of the original bits in SET1 +! with the bitwise negation of SET2. SET1 and SET2 must have the same +! number of bits otherwise the result is undefined. +! + type(bitset_large), intent(inout) :: set1 + type(bitset_large), intent(in) :: set2 + + integer(bits_kind) :: block_ + + do block_ = 1_bits_kind, size( set1 % blocks, kind=bits_kind ) + set1 % blocks(block_) = & + iand( set1 % blocks(block_), not( set2 % blocks(block_) ) ) + end do + + end subroutine and_not_large + + + elemental module function any_large(self) result(any) +! Returns .TRUE. if any bit in SELF is 1, .FALSE. otherwise. + logical :: any + class(bitset_large), intent(in) :: self + + integer(bits_kind) :: block_ + + do block_ = 1_bits_kind, size(self % blocks, kind=bits_kind) + if ( self % blocks(block_) /= 0 ) then + any = .true. + return + end if + end do + any = .false. + + end function any_large + + + pure module subroutine assign_large( set1, set2 ) +! Used to define assignment for bitset_large + type(bitset_large), intent(out) :: set1 + type(bitset_large), intent(in) :: set2 + + set1 % num_bits = set2 % num_bits + allocate( set1 % blocks( size( set2 % blocks, kind=bits_kind ) ) ) + set1 % blocks(:) = set2 % blocks(:) + + end subroutine assign_large + + pure module subroutine assign_logint8_large( self, logical_vector ) +! Used to define assignment from an array of type logical for bitset_large + type(bitset_large), intent(out) :: self + logical(int8), intent(in) :: logical_vector(:) + + integer(bits_kind) :: blocks + integer(bits_kind) :: log_size + integer(bits_kind) :: index + + log_size = size( logical_vector, kind=bits_kind ) + self % num_bits = log_size + if ( log_size == 0 ) then + blocks = 0 + else + blocks = (log_size-1)/block_size + 1 + end if + allocate( self % blocks( blocks ) ) + self % blocks(:) = 0 + + do index=0_bits_kind, log_size-1 + if ( logical_vector(index+1) ) then + call self % set( index ) + end if + end do + + end subroutine assign_logint8_large + + + pure module subroutine logint8_assign_large( logical_vector, set ) +! Used to define assignment to an array of type logical for bitset_large + logical(int8), intent(out), allocatable :: logical_vector(:) + type(bitset_large), intent(in) :: set + + integer(bits_kind) :: index + + allocate( logical_vector( set % num_bits ) ) + do index=0_bits_kind, set % num_bits-1 + if ( set % value( index ) == 1 ) then + logical_vector(index+1) = .true. + else + logical_vector(index+1) = .false. + end if + end do + + end subroutine logint8_assign_large + pure module subroutine assign_logint16_large( self, logical_vector ) +! Used to define assignment from an array of type logical for bitset_large + type(bitset_large), intent(out) :: self + logical(int16), intent(in) :: logical_vector(:) + + integer(bits_kind) :: blocks + integer(bits_kind) :: log_size + integer(bits_kind) :: index + + log_size = size( logical_vector, kind=bits_kind ) + self % num_bits = log_size + if ( log_size == 0 ) then + blocks = 0 + else + blocks = (log_size-1)/block_size + 1 + end if + allocate( self % blocks( blocks ) ) + self % blocks(:) = 0 + + do index=0_bits_kind, log_size-1 + if ( logical_vector(index+1) ) then + call self % set( index ) + end if + end do + + end subroutine assign_logint16_large + + + pure module subroutine logint16_assign_large( logical_vector, set ) +! Used to define assignment to an array of type logical for bitset_large + logical(int16), intent(out), allocatable :: logical_vector(:) + type(bitset_large), intent(in) :: set + + integer(bits_kind) :: index + + allocate( logical_vector( set % num_bits ) ) + do index=0_bits_kind, set % num_bits-1 + if ( set % value( index ) == 1 ) then + logical_vector(index+1) = .true. + else + logical_vector(index+1) = .false. + end if + end do + + end subroutine logint16_assign_large + pure module subroutine assign_logint32_large( self, logical_vector ) +! Used to define assignment from an array of type logical for bitset_large + type(bitset_large), intent(out) :: self + logical(int32), intent(in) :: logical_vector(:) + + integer(bits_kind) :: blocks + integer(bits_kind) :: log_size + integer(bits_kind) :: index + + log_size = size( logical_vector, kind=bits_kind ) + self % num_bits = log_size + if ( log_size == 0 ) then + blocks = 0 + else + blocks = (log_size-1)/block_size + 1 + end if + allocate( self % blocks( blocks ) ) + self % blocks(:) = 0 + + do index=0_bits_kind, log_size-1 + if ( logical_vector(index+1) ) then + call self % set( index ) + end if + end do + + end subroutine assign_logint32_large + + + pure module subroutine logint32_assign_large( logical_vector, set ) +! Used to define assignment to an array of type logical for bitset_large + logical(int32), intent(out), allocatable :: logical_vector(:) + type(bitset_large), intent(in) :: set + + integer(bits_kind) :: index + + allocate( logical_vector( set % num_bits ) ) + do index=0_bits_kind, set % num_bits-1 + if ( set % value( index ) == 1 ) then + logical_vector(index+1) = .true. + else + logical_vector(index+1) = .false. + end if + end do + + end subroutine logint32_assign_large + pure module subroutine assign_logint64_large( self, logical_vector ) +! Used to define assignment from an array of type logical for bitset_large + type(bitset_large), intent(out) :: self + logical(int64), intent(in) :: logical_vector(:) + + integer(bits_kind) :: blocks + integer(bits_kind) :: log_size + integer(bits_kind) :: index + + log_size = size( logical_vector, kind=bits_kind ) + self % num_bits = log_size + if ( log_size == 0 ) then + blocks = 0 + else + blocks = (log_size-1)/block_size + 1 + end if + allocate( self % blocks( blocks ) ) + self % blocks(:) = 0 + + do index=0_bits_kind, log_size-1 + if ( logical_vector(index+1) ) then + call self % set( index ) + end if + end do + + end subroutine assign_logint64_large + + + pure module subroutine logint64_assign_large( logical_vector, set ) +! Used to define assignment to an array of type logical for bitset_large + logical(int64), intent(out), allocatable :: logical_vector(:) + type(bitset_large), intent(in) :: set + + integer(bits_kind) :: index + + allocate( logical_vector( set % num_bits ) ) + do index=0_bits_kind, set % num_bits-1 + if ( set % value( index ) == 1 ) then + logical_vector(index+1) = .true. + else + logical_vector(index+1) = .false. + end if + end do + + end subroutine logint64_assign_large + + + elemental module function bit_count_large(self) result(bit_count) +! Returns the number of non-zero bits in SELF. + integer(bits_kind) :: bit_count + class(bitset_large), intent(in) :: self + + integer(bits_kind) :: block_, pos + + bit_count = 0 + do block_ = 1_bits_kind, size(self % blocks, kind=bits_kind) - 1 + do pos = 0, block_size-1 + if ( btest( self % blocks(block_), pos ) ) & + bit_count = bit_count + 1 + end do + + end do + + do pos = 0_bits_kind, self % num_bits - (block_-1)*block_size - 1 + if ( btest( self % blocks(block_), pos ) ) bit_count = bit_count + 1 + end do + + end function bit_count_large + + + elemental module subroutine clear_bit_large(self, pos) +! +! Sets to zero the POS position in SELF. If POS is less than zero or +! greater than BITS(SELF)-1 it is ignored. +! + class(bitset_large), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + + integer :: clear_block, block_bit + + if ( pos < 0 .OR. (pos > self % num_bits-1) ) return + clear_block = pos / block_size + 1 + block_bit = pos - (clear_block - 1) * block_size + self % blocks(clear_block) = & + ibclr( self % blocks(clear_block), block_bit ) + + end subroutine clear_bit_large + + + pure module subroutine clear_range_large(self, start_pos, stop_pos) +! +! Sets to zero all bits from the START_POS to STOP_POS positions in SELF. +! If STOP_POS < START_POS then no bits are modified. Positions outside +! the range 0 to BITS(SELF)-1 are ignored. +! + class(bitset_large), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + + integer(bits_kind) :: bit, block_, first_block, last_block, & + true_first, true_last + + true_first = max( 0_bits_kind, start_pos ) + true_last = min( self % num_bits-1, stop_pos ) + if ( true_last < true_first ) return + + first_block = true_first / block_size + 1 + last_block = true_last / block_size + 1 + if ( first_block == last_block ) then +! TRUE_FIRST and TRUE_LAST are in the same block + call mvbits( all_zeros, & + true_first - (first_block-1)*block_size, & + true_last - true_first + 1, & + self % blocks(first_block), & + true_first - (first_block-1)*block_size ) + return + end if + +! Do "partial" black containing FIRST + bit = true_first - (first_block-1)*block_size + call mvbits( all_zeros, & + bit, & + block_size - bit, & + self % blocks(first_block), & + bit ) + +! Do "partial" black containing LAST + bit = true_last - (last_block-1)*block_size + call mvbits( all_zeros, & + 0, & + bit+1, & + self % blocks(last_block), & + 0 ) + +! Do intermediate blocks + do block_ = first_block+1, last_block-1 + self % blocks(block_) = all_zeros + end do + + end subroutine clear_range_large + + + elemental module function eqv_large(set1, set2) result(eqv) +! +! Returns .TRUE. if all bits in SET1 and SET2 have the same value, +! .FALSE. otherwise. The sets must have the same number of bits +! otherwise the results are undefined. +! + logical :: eqv + type(bitset_large), intent(in) :: set1, set2 + + integer(bits_kind) :: block, common_blocks + + eqv = .false. + common_blocks = size(set1 % blocks, kind=bits_kind) + do block = 1, common_blocks + if ( set1 % blocks(block) /= set2 % blocks(block) ) return + end do + eqv = .true. + + end function eqv_large + + + module subroutine extract_large(new, old, start_pos, stop_pos, status) +! Creates a new bitset, NEW, from a range, START_POS to STOP_POS, in bitset +! OLD. If START_POS is greater than STOP_POS the new bitset is empty. +! If START_POS is less than zero or STOP_POS is greater than BITS(OLD)-1 +! then if STATUS is present it has the value INDEX_INVALID_ERROR, +! otherwise processing stops with an informative message. + type(bitset_large), intent(out) :: new + type(bitset_large), intent(in) :: old + integer(bits_kind), intent(in) :: start_pos, stop_pos + integer, intent(out), optional :: status + + integer(bits_kind) :: bits, blocks, ex_block, i, j, k, old_block + character(*), parameter :: procedure = 'EXTRACT' + + if ( start_pos < 0 ) then + call error_handler( 'had a START_POS less than 0.', & + index_invalid_error, status, & + module_name, procedure ) + return + end if + if ( stop_pos >= old % num_bits ) then + call error_handler( 'had a STOP_POS greater than BITS(OLD)-1.', & + index_invalid_error, status, & + module_name, procedure ) + return + end if + bits = stop_pos - start_pos + 1 + + if ( bits <= 0 ) then + new % num_bits = 0 + allocate( new % blocks(0) ) + return + end if + + blocks = ((bits-1) / block_size) + 1 + + new % num_bits = bits + allocate( new % blocks(blocks) ) + new % blocks(:) = 0 + + do i=0_bits_kind, bits-1 + ex_block = i / block_size + 1 + j = i - (ex_block-1) * block_size + old_block = (start_pos + i) / block_size + 1 + k = (start_pos + i) - (old_block-1) * block_size + if ( btest( old % blocks(old_block), k ) ) then + new % blocks(ex_block) = ibset(new % blocks(ex_block), j) + end if + end do + + if ( present(status) ) status = success + + end subroutine extract_large + + + elemental module subroutine flip_bit_large(self, pos) +! +! Flips the value at the POS position in SELF, provided the position is +! valid. If POS is less than 0 or greater than BITS(SELF)-1, no value is +! changed. +! + class(bitset_large), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + + integer(bits_kind) :: flip_block, block_bit + + if ( pos < 0 .OR. pos > self % num_bits-1 ) return + + flip_block = pos / block_size + 1 + block_bit = pos - (flip_block - 1) * block_size + if ( btest( self % blocks(flip_block), block_bit ) ) then + self % blocks(flip_block) = ibclr( self % blocks(flip_block), & + block_bit ) + else + self % blocks(flip_block) = ibset( self % blocks(flip_block), & + block_bit ) + end if + + end subroutine flip_bit_large + + + pure module subroutine flip_range_large(self, start_pos, stop_pos) +! +! Flips all valid bits from the START_POS to the STOP_POS positions in +! SELF. If STOP_POS < START_POS no bits are flipped. Positions less than +! 0 or greater than BITS(SELF)-1 are ignored. +! + class(bitset_large), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + + integer(bits_kind) :: bit, block_, end_bit, first_block, last_block, & + start_bit + + start_bit = max( 0_bits_kind, start_pos ) + end_bit = min( stop_pos , self % num_bits-1 ) + if ( end_bit < start_bit ) return + + first_block = start_bit / block_size + 1 + last_block = end_bit / block_size + 1 + if (first_block == last_block) then +! FIRST and LAST are in the same block + call mvbits( not(self % blocks(first_block)), & + start_bit - (first_block-1)*block_size, & + end_bit - start_bit + 1, & + self % blocks(first_block), & + start_bit - (first_block-1)*block_size ) + return + end if + +! Do "partial" black containing FIRST + bit = start_bit - (first_block-1)*block_size + call mvbits( not(self % blocks(first_block) ), & + bit, & + block_size - bit, & + self % blocks(first_block), & + bit ) + +! Do "partial" black containing LAST + bit = end_bit - (last_block-1)*block_size + call mvbits( not( self % blocks(last_block) ), & + 0, & + bit+1, & + self % blocks(last_block), & + 0 ) + +! Do remaining blocks + do block_ = first_block+1, last_block-1 + self % blocks(block_) = not( self % blocks(block_) ) + end do + + end subroutine flip_range_large + + module subroutine from_string_large(self, string, status) +! Initializes the bitset `self` treating `string` as a binary literal +! `status` may have the values: +! `success` - if no problems were found, +! `alloc_fault` - if allocation of the bitset failed +! `char_string_too_large_error` - if `string` was too large, or +! `char_string_invalid_error` - if string had an invalid character. + class(bitset_large), intent(out) :: self + character(*), intent(in) :: string + integer, intent(out), optional :: status + + character(*), parameter :: procedure = 'FROM_STRING' + integer(int64) :: bit + integer(int64) :: bits + character(1) :: char + + bits = len(string, kind=int64) + if ( bits > huge(0_bits_kind) ) then + call error_handler( 'STRING was too long for a ' // & + 'BITSET_LARGE SELF.', & + char_string_too_large_error, status, & + module_name, procedure ) + return + end if + + call init_zero_large( self, int(bits, kind=bits_kind), status ) + + if ( present(status) ) then + if ( status /= success ) return + end if + + do bit = 1_bits_kind, bits + char = string(bit:bit) + if ( char == '0' ) then + call self % clear( int(bits-bit, kind=bits_kind) ) + else if ( char == '1' ) then + call self % set( int(bits-bit, kind=bits_kind) ) + else + call error_handler( 'STRING had a character other than ' // & + '0 or 1.', & + char_string_invalid_error, status, & + module_name, procedure ) + return + end if + end do + + if ( present(status) ) status = success + + end subroutine from_string_large + + + elemental module function ge_large(set1, set2) result(ge) +! +! Returns .TRUE. if the bits in SET1 and SET2 are the same or the +! highest order different bit is set to 1 in SET1 and to 0 in set2. +! .FALSE. otherwise. The sets must have the same number of bits +! otherwise the results are undefined. +! + logical :: ge + type(bitset_large), intent(in) :: set1, set2 + + integer(bits_kind) :: block_ + + do block_ = size(set1 % blocks, kind=bits_kind), 1_bits_kind, -1 + if ( set1 % blocks(block_) == set2 % blocks(block_) ) then + cycle + else if ( bgt(set1 % blocks(block_), set2 % blocks(block_) ) ) then + ge = .true. + return + else + ge = .false. + return + end if + end do + ge = .true. + + end function ge_large + + + elemental module function gt_large(set1, set2) result(gt) +! +! Returns .TRUE. if the bits in SET1 and SET2 differ and the +! highest order different bit is set to 1 in SET1 and to 0 in set2. +! .FALSE. otherwise. The sets must have the same number of bits +! otherwise the results are undefined. +! + logical :: gt + type(bitset_large), intent(in) :: set1, set2 + + integer(bits_kind) :: block_ + + do block_ = size(set1 % blocks, kind=bits_kind), 1_bits_kind, -1 + if ( set1 % blocks(block_) == set2 % blocks(block_) ) then + cycle + else if ( bgt( set1 % blocks(block_), & + set2 % blocks(block_) ) ) then + gt = .true. + return + else + gt = .false. + return + end if + end do + gt = .false. + + end function gt_large + + + module subroutine init_zero_large(self, bits, status) +! +! Creates the bitset, `self`, of size `bits`, with all bits initialized to +! zero. `bits` must be non-negative. If an error occurs and `status` is +! absent then processing stops with an informative stop code. `status` +! will have one of the values; +! * `success` - if no problems were found, +! * `array_size_invalid_error` - if `bits` is either negative or larger +! than 64 with `self` of class `bitset_64`, or +! * `alloc_fault` - if memory allocation failed +! + class(bitset_large), intent(out) :: self + integer(bits_kind), intent(in) :: bits + integer, intent(out), optional :: status + + character(len=120) :: message + character(*), parameter :: procedure = "INIT" + integer :: blocks, ierr + + message = '' + if ( bits < 0 ) then + call error_handler( 'BITS had a negative value.', & + array_size_invalid_error, status, & + module_name, procedure ) + return + end if + + if (bits == 0) then + self % num_bits = 0 + allocate( self % blocks(0), stat=ierr, errmsg=message ) + if (ierr /= 0) go to 998 + return + else + blocks = ((bits-1) / block_size) + 1 + end if + + self % num_bits = bits + allocate( self % blocks(blocks), stat=ierr, errmsg=message ) + if (ierr /= 0) go to 998 + + self % blocks(:) = all_zeros + + if ( present(status) ) status = success + + return + +998 call error_handler( 'Allocation failure for SELF.', & + alloc_fault, status, & + module_name, procedure ) + + end subroutine init_zero_large + + + module subroutine input_large(self, unit, status) +! +! Reads the components of the bitset, `self`, from the unformatted I/O +! unit, `unit`, assuming that the components were written using `output`. +! If an error occurs and `status` is absent then processing stops with +! an informative stop code. `status` has one of the values: +! * `success` - if no problem was found +! * `alloc_fault` - if it failed during allocation of memory for `self`, or +! * `array_size_invalid_error` if the `bits(self)` in `unit` is negative +! or greater than 64 for a `bitset_64` input. +! * `read_failure` - if it failed during the reads from `unit` +! + class(bitset_large), intent(out) :: self + integer, intent(in) :: unit + integer, intent(out), optional :: status + + integer(bits_kind) :: bits + integer :: ierr + character(len=120) :: message + character(*), parameter :: procedure = 'INPUT' + integer :: stat + + read(unit, iostat=ierr, iomsg=message) bits + if (ierr /= 0) then + call error_handler( 'Failure on a READ statement for UNIT.', & + read_failure, status, module_name, procedure ) + return + end if + + if ( bits < 0 ) then + call error_handler( 'BITS in UNIT had a negative value.', & + array_size_invalid_error, status, & + module_name, procedure ) + return + end if + + call self % init(bits, stat) + if (stat /= success) then + call error_handler( 'Allocation failure for SELF.', & + alloc_fault, status, module_name, procedure ) + return + end if + + if (bits < 1) return + + read(unit, iostat=ierr, iomsg=message) self % blocks(:) + if (ierr /= 0) then + call error_handler( 'Failure on a READ statement for UNIT.', & + read_failure, status, module_name, procedure ) + return + end if + + if ( present(status) ) status = success + + end subroutine input_large + + + elemental module function le_large(set1, set2) result(le) +! +! Returns .TRUE. if the bits in SET1 and SET2 are the same or the +! highest order different bit is set to 0 in SET1 and to 1 in set2. +! .FALSE. otherwise. The sets must have the same number of bits +! otherwise the results are undefined. +! + logical :: le + type(bitset_large), intent(in) :: set1, set2 + + integer(bits_kind) :: block_ + + do block_ = size(set1 % blocks, kind=bits_kind), 1_bits_kind, -1 + if ( set1 % blocks(block_) == set2 % blocks(block_) ) then + cycle + else if ( blt( set1 % blocks(block_), & + set2 % blocks(block_) ) ) then + le = .true. + return + else + le = .false. + return + end if + end do + + le = .true. + + end function le_large + + + elemental module function lt_large(set1, set2) result(lt) +! +! Returns .TRUE. if the bits in SET1 and SET2 differ and the +! highest order different bit is set to 0 in SET1 and to 1 in set2. +! .FALSE. otherwise. The sets must have the same number of bits +! otherwise the results are undefined. +! + logical :: lt + type(bitset_large), intent(in) :: set1, set2 + + integer(bits_kind) :: block_ + + do block_ = size(set1 % blocks, kind=bits_kind), 1_bits_kind, -1 + if ( set1 % blocks(block_) == set2 % blocks(block_) ) then + cycle + else if ( blt( set1 % blocks(block_), & + set2 % blocks(block_) ) ) then + lt = .true. + return + else + lt = .false. + return + end if + end do + lt = .false. + + end function lt_large + + + elemental module function neqv_large(set1, set2) result(neqv) +! +! Returns .TRUE. if any bits in SET1 and SET2 differ in value, +! .FALSE. otherwise. The sets must have the same number of bits +! otherwise the results are undefined. +! + logical :: neqv + type(bitset_large), intent(in) :: set1, set2 + + integer(bits_kind) :: block_ + + neqv = .true. + do block_ = 1_bits_kind, size(set1 % blocks, kind=bits_kind) + if ( set1 % blocks(block_) /= set2 % blocks(block_) ) return + end do + neqv = .false. + + end function neqv_large + + + elemental module function none_large(self) result(none) +! +! Returns .TRUE. if none of the bits in SELF have the value 1. +! + logical :: none + class(bitset_large), intent(in) :: self + + integer(bits_kind) :: block + + none = .true. + do block = 1_bits_kind, size(self % blocks, kind=bits_kind) + if (self % blocks(block) /= 0) then + none = .false. + return + end if + end do + + end function none_large + + + elemental module subroutine not_large(self) +! +! Sets the bits in SELF to their logical complement +! + class(bitset_large), intent(inout) :: self + + integer(bits_kind) :: bit, full_blocks, block + integer :: remaining_bits + + if ( self % num_bits == 0 ) return + full_blocks = self % num_bits / block_size + do block = 1_bits_kind, full_blocks + self % blocks(block) = not( self % blocks(block) ) + end do + remaining_bits = self % num_bits - full_blocks * block_size + + do bit=0, remaining_bits - 1 + if ( btest( self % blocks( block ), bit ) ) then + self % blocks( block ) = ibclr( self % blocks(block), bit ) + else + self % blocks( block ) = ibset( self % blocks(block), bit ) + end if + end do + + end subroutine not_large + + + elemental module subroutine or_large(set1, set2) +! +! Sets the bits in SET1 to the bitwise OR of the original bits in SET1 +! and SET2. SET1 and SET2 must have the same number of bits otherwise +! the result is undefined. +! + type(bitset_large), intent(inout) :: set1 + type(bitset_large), intent(in) :: set2 + + integer(bits_kind) :: block_ + + do block_ = 1, size( set1 % blocks, kind=bits_kind ) + set1 % blocks(block_) = ior( set1 % blocks(block_), & + set2 % blocks(block_) ) + end do + + end subroutine or_large + + + module subroutine output_large(self, unit, status) +! +! Writes the components of the bitset, SELF, to the unformatted I/O +! unit, UNIT, in a unformatted sequence compatible with INPUT. If +! STATUS is absent an error results in an error stop with an +! informative stop code. If STATUS is present it has the default +! value of SUCCESS, or the value WRITE_FAILURE if the write failed. +! + class(bitset_large), intent(in) :: self + integer, intent(in) :: unit + integer, intent(out), optional :: status + + integer :: ierr + character(len=120) :: message + character(*), parameter :: procedure = "OUTPUT" + + write(unit, iostat=ierr, iomsg=message) self % num_bits + if (ierr /= 0) go to 999 + + if (self % num_bits < 1) return + write(unit, iostat=ierr, iomsg=message) self % blocks(:) + if (ierr /= 0) go to 999 + + return + +999 call error_handler( 'Failure on a WRITE statement for UNIT.', & + write_failure, status, module_name, procedure ) + + end subroutine output_large + + + module subroutine read_bitset_string_large(self, string, status) +! +! Uses the bitset literal in the default character `string`, to define +! the bitset, `self`. The literal may be preceded by an an arbitrary +! sequence of blank characters. If `status` is absent an error results +! in an error stop with an informative stop code. If `status` +! is present it has one of the values +! * `success` - if no problems occurred, +! * `alloc_fault` - if allocation of memory for SELF failed, +! * `array_size_invalid_error - if `bits(self)` in `string` is greater +! than 64 for a `bitset_64`, +! * `char_string_invalid_error` - if the bitset literal has an invalid +! character, +! * `char_string_too_small_error - if the string ends before all the bits +! are read. +! * `integer_overflow_error` - if the bitset literal has a `bits(self)` +! value too large to be represented, +! + class(bitset_large), intent(out) :: self + character(len=*), intent(in) :: string + integer, intent(out), optional :: status + + integer(bits_kind) :: bit, bits + integer(bits_kind) :: digits, pos + character(*), parameter :: procedure = "READ_BITSET" + integer :: stat + + pos = 1 + find_start: do pos=1_bits_kind, len(string, kind=bits_kind) + if ( string(pos:pos) /= ' ' ) exit + end do find_start + + if ( pos > len(string) - 8 ) go to 999 + + if ( string(pos:pos) /= 's' .AND. string(pos:pos) /= 'S' ) go to 999 + + pos = pos + 1 + bits = 0 + digits = 0 + + do + select case( iachar( string(pos:pos) ) ) + case(ia0:ia9) + digits = digits + 1 + if ( digits == max_digits .AND. bits > overflow_bits ) go to 996 + if ( digits > max_digits ) go to 996 + bits = bits*10 + iachar( string(pos:pos) ) - ia0 + if ( bits < 0 ) go to 996 + case(iachar('b'), iachar('B')) + exit + case default + call error_handler( 'There was an invalid character ' // & + 'in STRING', & + char_string_invalid_error, status, & + module_name, procedure ) + return + end select + + pos = pos + 1 + end do + + if ( bits + pos > len(string) ) then + call error_handler( 'STRING was too small for the number of ' // & + 'bits specified by STRING.', & + char_string_too_small_error, status, & + module_name, procedure ) + return + end if + call self % init( bits, stat ) + if (stat /= success) then + call error_handler( 'There was an allocation fault for SELF.', & + alloc_fault, status, module_name, procedure ) + return + end if + + pos = pos + 1 + bit = bits - 1 + do + if ( string(pos:pos) == '0' ) then + call self % clear( bit ) + else if ( string(pos:pos) == '1' ) then + call self % set( bit ) + else + go to 999 + end if + pos = pos + 1 + bit = bit - 1 + if ( bit < 0 ) exit + end do + + if ( present(status) ) status = success + + return + +996 call error_handler( 'There was an integer overflow in reading' // & + 'size of bitset literal from UNIT', & + integer_overflow_error, status, & + module_name, procedure ) + return + +999 call error_handler( 'There was an invalid character in STRING', & + char_string_invalid_error, status, & + module_name, procedure ) + + end subroutine read_bitset_string_large + + + module subroutine read_bitset_unit_large(self, unit, advance, status) +! +! Uses the bitset literal at the current position in the formatted +! file with I/O unit, `unit`, to define the bitset, `self`. The literal +! may be preceded by an arbitrary sequence of blank characters. +! If `advance` is present it must be either 'YES' or 'NO'. If absent +! it has the default value of 'YES' to determine whether advancing +! I/O occurs. If `status` is absent an error results in an error stop +! with an informative stop code. If `status` is present it has one of +! the values: +! * `success` - if no problem occurred, +! * `alloc_fault` - if allocation of `self` failed, +! * `array_size_invalid_error` - if `bits(self)` in the bitset literal +! is greater than 64 for a `bitset_64`. +! * `char_string_invalid_error` - if the read of the bitset literal found +! an invalid character, +! * `eof_failure` - if a `read` statement reaches an end-of-file before +! completing the read of the bitset literal, +! * `integer_overflow_error` - if the bitset literal has a `bits(self)` +! value too large to be represented, +! * `read_failure` - if a `read` statement fails, +! + class(bitset_large), intent(out) :: self + integer, intent(in) :: unit + character(*), intent(in), optional :: advance + integer, intent(out), optional :: status + + integer(bits_kind) :: bit, bits, digits + integer :: ierr + character(len=128) :: message + character(*), parameter :: procedure = "READ_BITSET" + character(len=1) :: char + + do + read( unit, & + advance='NO', & + FMT='(A1)', & + err=997, & + end=998, & + iostat=ierr, & + iomsg=message ) char + select case( char ) + case( ' ' ) + cycle + case( 's', 'S' ) + exit + case default + go to 999 + end select + end do + + bits = 0 + digits = 0 + do + read( unit, & + advance='NO', & + FMT='(A1)', & + err=997, & + end=998, & + iostat=ierr, & + iomsg=message ) char + if ( char == 'b' .or. char == 'B' ) exit + select case( char ) + case( '0', '1', '2', '3', '4', '5', '6', '7', '8', '9' ) + digits = digits + 1 + if ( digits == max_digits .AND. bits > overflow_bits ) & + go to 996 + if ( digits > max_digits ) go to 996 + bits = 10*bits + iachar(char) - iachar('0') + if ( bits < 0 ) go to 996 + case default + go to 999 + end select + end do + + if ( bits < 0 .OR. digits == 0 .OR. digits > max_digits ) go to 999 + + call self % init( bits, status ) + if ( present(status) ) then + call error_handler( 'There was an allocation fault for SELF.', & + alloc_fault, status, module_name, procedure ) + return + end if + do bit = 1, bits-1 + read( unit, & + advance='NO', & + FMT='(A1)', & + err=997, & + end=998, & + iostat=ierr, & + iomsg=message ) char + if ( char == '0' ) then + call self % clear( bits-bit ) + else if ( char == '1' ) then + call self % set( bits-bit ) + else + go to 999 + end if + end do + + if ( present(advance) ) then + read( unit, & + advance=advance, & + FMT='(A1)', & + err=997, & + end=998, & + iostat=ierr, & + iomsg=message ) char + else + read( unit, & + advance='YES', & + FMT='(A1)', & + err=997, & + end=998, & + iostat=ierr, & + iomsg=message ) char + end if + + if ( char == '0' ) then + call self % clear( bits-bit ) + else if ( char == '1' ) then + call self % set( bits-bit ) + else + go to 999 + end if + + if ( present(status) ) status = success + + return + +996 call error_handler( 'Integer overflow in reading size of ' // & + 'bitset literal from UNIT.', & + read_failure, status, module_name, procedure ) + return + +997 call error_handler( 'Failure on read of UNIT.', & + read_failure, status, module_name, procedure ) + return + +998 call error_handler( 'End of File of UNIT before finishing a ' // & + 'bitset literal.', & + eof_failure, status, module_name, procedure ) + return + +999 call error_handler( 'Invalid character in bitset literal in UNIT ', & + char_string_invalid_error, status, & + module_name, procedure ) + + end subroutine read_bitset_unit_large + + + elemental module subroutine set_bit_large(self, pos) +! +! Sets the value at the POS position in SELF, provided the position is +! valid. If the position is less than 0 or greater than BITS(SELF)-1 +! then SELF is unchanged. +! + class(bitset_large), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + + integer(bits_kind) :: set_block, block_bit + + if ( pos < 0 .OR. pos > self % num_bits-1 ) return + + set_block = pos / block_size + 1 + block_bit = pos - (set_block - 1) * block_size + self % blocks(set_block) = ibset( self % blocks(set_block), block_bit ) + + end subroutine set_bit_large + + + pure module subroutine set_range_large(self, start_pos, stop_pos) +! +! Sets all valid bits to 1 from the START_POS to the STOP_POS positions +! in SELF. If STOP_POA < START_POS no bits are changed. Positions outside +! the range 0 to BITS(SELF)-1 are ignored. +! + class(bitset_large), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + + integer(bits_kind) :: bit, block_, end_bit, first_block, last_block, & + start_bit + + start_bit = max( 0_bits_kind, start_pos ) + end_bit = min( stop_pos, self % num_bits-1 ) + if ( end_bit < start_bit ) return + + first_block = start_bit / block_size + 1 + last_block = end_bit / block_size + 1 + if ( first_block == last_block ) then +! FIRST and LAST are in the same block + call mvbits( all_ones, & + start_bit - (first_block-1)*block_size, & + end_bit - start_bit + 1, & + self % blocks(first_block), & + start_bit - (first_block-1)*block_size ) + return + end if + +! Do "partial" black containing FIRST + bit = start_bit - (first_block-1)*block_size + call mvbits( all_ones, & + bit, & + block_size - bit, & + self % blocks(first_block), & + bit ) + +! Do "partial" black containing LAST + bit = end_bit - (last_block-1)*block_size + call mvbits( all_ones, & + 0, & + bit+1, & + self % blocks(last_block), & + 0 ) + +! Do remaining blocks + do block_ = first_block+1, last_block-1 + self % blocks(block_) = all_ones + end do + + end subroutine set_range_large + + + elemental module function test_large(self, pos) result(test) +! +! Returns .TRUE. if the POS position is set, .FALSE. otherwise. If POS +! is negative or greater than BITS(SELF) - 1 the result is .FALSE.. +! + logical :: test + class(bitset_large), intent(in) :: self + integer(bits_kind), intent(in) :: pos + + integer(bits_kind) :: bit_block + + if ( pos < 0 .or. pos >= self % num_bits ) then + test = .false. + else + bit_block = pos / block_size + 1 + test = btest( self % blocks(bit_block), & + pos - ( bit_block-1 ) * block_size ) + end if + + end function test_large + + + module subroutine to_string_large(self, string, status) +! +! Represents the value of SELF as a binary literal in STRING +! Status may have the values SUCCESS or ALLOC_FAULT +! + class(bitset_large), intent(in) :: self + character(len=:), allocatable, intent(out) :: string + integer, intent(out), optional :: status + + character(*), parameter :: procedure = 'TO_STRING' + integer(bits_kind) :: bit, bit_count, pos + integer :: stat + + bit_count = self % num_bits + allocate( character(len=bit_count)::string, stat=stat ) + if ( stat > 0 ) then + call error_handler( 'There was an allocation fault for STRING.', & + alloc_fault, status, module_name, procedure ) + return + end if + do bit=0_bits_kind, bit_count-1 + pos = bit_count - bit + if ( self % test( bit) ) then + string( pos:pos ) = '1' + else + string( pos:pos ) = '0' + end if + end do + + if ( present(status) ) status = success + + end subroutine to_string_large + + + elemental module function value_large(self, pos) result(value) +! +! Returns 1 if the POS position is set, 0 otherwise. If POS is negative +! or greater than BITS(SELF) - 1 the result is 0. +! + integer :: value + class(bitset_large), intent(in) :: self + integer(bits_kind), intent(in) :: pos + + integer :: bit_block + + if ( pos < 0 .or. pos >= self % num_bits ) then + value = 0 + else + bit_block = pos / block_size + 1 + if ( btest( self % blocks(bit_block), & + pos - ( bit_block-1 ) * block_size ) ) then + value = 1 + else + value = 0 + end if + end if + + end function value_large + + + module subroutine write_bitset_string_large(self, string, status) +! +! Writes a bitset literal to the allocatable default character STRING, +! representing the individual bit values in the bitset_t, SELF. +! If STATUS is absent an error results in an error stop with an +! informative stop code. If STATUS is present it has the default +! value of SUCCESS, or the value ALLOC_FAULT if allocation of +! the output string failed. +! + class(bitset_large), intent(in) :: self + character(len=:), allocatable, intent(out) :: string + integer, intent(out), optional :: status + + integer(bits_kind) :: bit, & + bit_count, & + count_digits, & + pos + integer :: stat + + character(*), parameter :: procedure = 'WRITE_BITSET' + + bit_count = bits(self) + + call digit_count( self % num_bits, count_digits ) + + allocate( character(len=count_digits+bit_count+2)::string, stat=stat ) + if ( stat > 0 ) then + call error_handler( 'There was an allocation fault for STRING.', & + alloc_fault, status, module_name, procedure ) + return + end if + + write( string, "('S', i0)" ) self % num_bits + + string( count_digits + 2:count_digits + 2 ) = "B" + do bit=0_bits_kind, bit_count-1 + pos = count_digits + 2 + bit_count - bit + if ( self % test( bit) ) then + string( pos:pos ) = '1' + else + string( pos:pos ) = '0' + end if + end do + + if ( present(status) ) status = success + + contains + + subroutine digit_count( bits, digits ) + integer(bits_kind), intent(in) :: bits + integer(bits_kind), intent(out) :: digits + + integer(bits_kind) :: factor + + factor = bits + + if ( factor <= 0 ) then + digits = 1 + return + end if + + do digits = 1, 127 + factor = factor / 10 + if ( factor == 0 ) return + end do + + end subroutine digit_count + + end subroutine write_bitset_string_large + + + module subroutine write_bitset_unit_large(self, unit, advance, status) +! +! Writes a bitset literal to the I/O unit, UNIT, representing the +! individual bit values in the bitset_t, SELF. By default or if +! ADVANCE is present with the value 'YES', advancing output is used. +! If ADVANCE is present with the value 'NO', then the current record +! is not advanced by the write. If STATUS is absent an error results +! in an error stop with an informative stop code. If STATUS is +! present it has the default value of SUCCESS, the value +! ALLOC_FAULT if allocation of the output string failed, or +! WRITE_FAILURE if the WRITE statement outputting the literal failed. +! + class(bitset_large), intent(in) :: self + integer, intent(in) :: unit + character(len=*), intent(in), optional :: advance + integer, intent(out), optional :: status + + integer :: ierr + character(:), allocatable :: string + character(len=120) :: message + character(*), parameter :: procedure = "WRITE_BITSET" + + call self % write_bitset(string, status) + + if ( present(status) ) then + if (status /= success ) return + end if + + + if ( present( advance ) ) then + write( unit, & + FMT='(A)', & + advance=advance, & + iostat=ierr, & + iomsg=message ) & + string + else + write( unit, & + FMT='(A)', & + advance='YES', & + iostat=ierr, & + iomsg=message ) & + string + end if + if (ierr /= 0) then + call error_handler( 'Failure on a WRITE statement for UNIT.', & + write_failure, status, module_name, procedure ) + return + endif + + end subroutine write_bitset_unit_large + + + elemental module subroutine xor_large(set1, set2) +! +! Sets the bits in SET1 to the bitwise XOR of the original bits in SET1 +! and SET2. SET1 and SET2 must have the same number of bits otherwise +! the result is undefined. +! + type(bitset_large), intent(inout) :: set1 + type(bitset_large), intent(in) :: set2 + + integer(bits_kind) :: block_ + + do block_ = 1_bits_kind, size(set1 % blocks, kind=bits_kind) + set1 % blocks(block_) = ieor( set1 % blocks(block_), & + set2 % blocks(block_) ) + end do + + end subroutine xor_large + +end submodule stdlib_bitsets_large diff --git a/src/fpm/stdlib_error.f90 b/src/fpm/stdlib_error.f90 new file mode 100644 index 000000000..a44f29917 --- /dev/null +++ b/src/fpm/stdlib_error.f90 @@ -0,0 +1,84 @@ +module stdlib_error + !! Provides support for catching and handling errors + !! ([Specification](../page/specs/stdlib_error.html)) +use, intrinsic :: iso_fortran_env, only: stderr => error_unit +use stdlib_optval, only: optval +implicit none +private + +interface ! f{08,18}estop.f90 + module subroutine error_stop(msg, code) + !! version: experimental + !! + !! Provides a call to `error stop` and allows the user to specify a code and message + !! ([Specification](..//page/specs/stdlib_error.html#description_1)) + character(*), intent(in) :: msg + integer, intent(in), optional :: code + end subroutine error_stop +end interface + +public :: check, error_stop + +contains + +subroutine check(condition, msg, code, warn) + !! version: experimental + !! + !! Checks the value of a logical condition + !! ([Specification](../page/specs/stdlib_error.html#description)) + !! + !!##### Behavior + !! + !! If `condition == .false.` and: + !! + !! * No other arguments are provided, it stops the program with the default + !! message and exit code `1`; + !! * `msg` is provided, it prints the value of `msg`; + !! * `code` is provided, it stops the program with the given exit code; + !! * `warn` is provided and `.true.`, it doesn't stop the program and prints + !! the message. + !! + !!##### Examples + !! + !!* If `a /= 5`, stops the program with exit code `1` + !! and prints `Check failed.` + !!``` fortran + !! call check(a == 5) + !!``` + !! + !!* As above, but prints `a == 5 failed`. + !!``` fortran + !! call check(a == 5, msg='a == 5 failed.') + !!``` + !! + !!* As above, but doesn't stop the program. + !!``` fortran + !! call check(a == 5, msg='a == 5 failed.', warn=.true.) + !!``` + !! + !!* As example #2, but stops the program with exit code `77` + !!``` fortran + !! call check(a == 5, msg='a == 5 failed.', code=77) + !!``` + + ! + ! Arguments + ! --------- + + logical, intent(in) :: condition + character(*), intent(in), optional :: msg + integer, intent(in), optional :: code + logical, intent(in), optional :: warn + character(*), parameter :: msg_default = 'Check failed.' + + if (.not. condition) then + if (optval(warn, .false.)) then + write(stderr,*) optval(msg, msg_default) + else + call error_stop(optval(msg, msg_default), optval(code, 1)) + end if + end if + +end subroutine check + +end module stdlib_error diff --git a/src/fpm/stdlib_io.f90 b/src/fpm/stdlib_io.f90 new file mode 100644 index 000000000..b119d8cd9 --- /dev/null +++ b/src/fpm/stdlib_io.f90 @@ -0,0 +1,991 @@ + + +module stdlib_io + !! Provides a support for file handling + !! ([Specification](../page/specs/stdlib_io.html)) + + use stdlib_kinds, only: sp, dp, qp, & + int8, int16, int32, int64 + use stdlib_error, only: error_stop + use stdlib_optval, only: optval + use stdlib_ascii, only: is_blank + implicit none + private + ! Public API + public :: loadtxt, savetxt, open + + ! Private API that is exposed so that we can test it in tests + public :: parse_mode + + interface loadtxt + !! version: experimental + !! + !! Loads a 2D array from a text file + !! ([Specification](../page/specs/stdlib_io.html#description)) + module procedure loadtxt_rsp + module procedure loadtxt_rdp + module procedure loadtxt_rqp + module procedure loadtxt_iint8 + module procedure loadtxt_iint16 + module procedure loadtxt_iint32 + module procedure loadtxt_iint64 + module procedure loadtxt_csp + module procedure loadtxt_cdp + module procedure loadtxt_cqp + end interface loadtxt + + interface savetxt + !! version: experimental + !! + !! Saves a 2D array into a text file + !! ([Specification](../page/specs/stdlib_io.html#description_2)) + module procedure savetxt_rsp + module procedure savetxt_rdp + module procedure savetxt_rqp + module procedure savetxt_iint8 + module procedure savetxt_iint16 + module procedure savetxt_iint32 + module procedure savetxt_iint64 + module procedure savetxt_csp + module procedure savetxt_cdp + module procedure savetxt_cqp + end interface + +contains + + subroutine loadtxt_rsp(filename, d) + !! version: experimental + !! + !! Loads a 2D array from a text file. + !! + !! Arguments + !! --------- + !! + !! Filename to load the array from + character(len=*), intent(in) :: filename + !! The array 'd' will be automatically allocated with the correct dimensions + real(sp), allocatable, intent(out) :: d(:,:) + !! + !! Example + !! ------- + !! + !!```fortran + !! real(sp), allocatable :: data(:, :) + !! call loadtxt("log.txt", data) ! 'data' will be automatically allocated + !!``` + !! + !! Where 'log.txt' contains for example:: + !! + !! 1 2 3 + !! 2 4 6 + !! 8 9 10 + !! 11 12 13 + !! ... + !! + integer :: s + integer :: nrow, ncol, i + + s = open(filename) + + ! determine number of columns + ncol = number_of_columns(s) + + ! determine number or rows + nrow = number_of_rows_numeric(s) + + allocate(d(nrow, ncol)) + do i = 1, nrow + read(s, *) d(i, :) + end do + close(s) + + end subroutine loadtxt_rsp + subroutine loadtxt_rdp(filename, d) + !! version: experimental + !! + !! Loads a 2D array from a text file. + !! + !! Arguments + !! --------- + !! + !! Filename to load the array from + character(len=*), intent(in) :: filename + !! The array 'd' will be automatically allocated with the correct dimensions + real(dp), allocatable, intent(out) :: d(:,:) + !! + !! Example + !! ------- + !! + !!```fortran + !! real(dp), allocatable :: data(:, :) + !! call loadtxt("log.txt", data) ! 'data' will be automatically allocated + !!``` + !! + !! Where 'log.txt' contains for example:: + !! + !! 1 2 3 + !! 2 4 6 + !! 8 9 10 + !! 11 12 13 + !! ... + !! + integer :: s + integer :: nrow, ncol, i + + s = open(filename) + + ! determine number of columns + ncol = number_of_columns(s) + + ! determine number or rows + nrow = number_of_rows_numeric(s) + + allocate(d(nrow, ncol)) + do i = 1, nrow + read(s, *) d(i, :) + end do + close(s) + + end subroutine loadtxt_rdp + subroutine loadtxt_rqp(filename, d) + !! version: experimental + !! + !! Loads a 2D array from a text file. + !! + !! Arguments + !! --------- + !! + !! Filename to load the array from + character(len=*), intent(in) :: filename + !! The array 'd' will be automatically allocated with the correct dimensions + real(qp), allocatable, intent(out) :: d(:,:) + !! + !! Example + !! ------- + !! + !!```fortran + !! real(qp), allocatable :: data(:, :) + !! call loadtxt("log.txt", data) ! 'data' will be automatically allocated + !!``` + !! + !! Where 'log.txt' contains for example:: + !! + !! 1 2 3 + !! 2 4 6 + !! 8 9 10 + !! 11 12 13 + !! ... + !! + integer :: s + integer :: nrow, ncol, i + + s = open(filename) + + ! determine number of columns + ncol = number_of_columns(s) + + ! determine number or rows + nrow = number_of_rows_numeric(s) + + allocate(d(nrow, ncol)) + do i = 1, nrow + read(s, *) d(i, :) + end do + close(s) + + end subroutine loadtxt_rqp + subroutine loadtxt_iint8(filename, d) + !! version: experimental + !! + !! Loads a 2D array from a text file. + !! + !! Arguments + !! --------- + !! + !! Filename to load the array from + character(len=*), intent(in) :: filename + !! The array 'd' will be automatically allocated with the correct dimensions + integer(int8), allocatable, intent(out) :: d(:,:) + !! + !! Example + !! ------- + !! + !!```fortran + !! integer(int8), allocatable :: data(:, :) + !! call loadtxt("log.txt", data) ! 'data' will be automatically allocated + !!``` + !! + !! Where 'log.txt' contains for example:: + !! + !! 1 2 3 + !! 2 4 6 + !! 8 9 10 + !! 11 12 13 + !! ... + !! + integer :: s + integer :: nrow, ncol, i + + s = open(filename) + + ! determine number of columns + ncol = number_of_columns(s) + + ! determine number or rows + nrow = number_of_rows_numeric(s) + + allocate(d(nrow, ncol)) + do i = 1, nrow + read(s, *) d(i, :) + end do + close(s) + + end subroutine loadtxt_iint8 + subroutine loadtxt_iint16(filename, d) + !! version: experimental + !! + !! Loads a 2D array from a text file. + !! + !! Arguments + !! --------- + !! + !! Filename to load the array from + character(len=*), intent(in) :: filename + !! The array 'd' will be automatically allocated with the correct dimensions + integer(int16), allocatable, intent(out) :: d(:,:) + !! + !! Example + !! ------- + !! + !!```fortran + !! integer(int16), allocatable :: data(:, :) + !! call loadtxt("log.txt", data) ! 'data' will be automatically allocated + !!``` + !! + !! Where 'log.txt' contains for example:: + !! + !! 1 2 3 + !! 2 4 6 + !! 8 9 10 + !! 11 12 13 + !! ... + !! + integer :: s + integer :: nrow, ncol, i + + s = open(filename) + + ! determine number of columns + ncol = number_of_columns(s) + + ! determine number or rows + nrow = number_of_rows_numeric(s) + + allocate(d(nrow, ncol)) + do i = 1, nrow + read(s, *) d(i, :) + end do + close(s) + + end subroutine loadtxt_iint16 + subroutine loadtxt_iint32(filename, d) + !! version: experimental + !! + !! Loads a 2D array from a text file. + !! + !! Arguments + !! --------- + !! + !! Filename to load the array from + character(len=*), intent(in) :: filename + !! The array 'd' will be automatically allocated with the correct dimensions + integer(int32), allocatable, intent(out) :: d(:,:) + !! + !! Example + !! ------- + !! + !!```fortran + !! integer(int32), allocatable :: data(:, :) + !! call loadtxt("log.txt", data) ! 'data' will be automatically allocated + !!``` + !! + !! Where 'log.txt' contains for example:: + !! + !! 1 2 3 + !! 2 4 6 + !! 8 9 10 + !! 11 12 13 + !! ... + !! + integer :: s + integer :: nrow, ncol, i + + s = open(filename) + + ! determine number of columns + ncol = number_of_columns(s) + + ! determine number or rows + nrow = number_of_rows_numeric(s) + + allocate(d(nrow, ncol)) + do i = 1, nrow + read(s, *) d(i, :) + end do + close(s) + + end subroutine loadtxt_iint32 + subroutine loadtxt_iint64(filename, d) + !! version: experimental + !! + !! Loads a 2D array from a text file. + !! + !! Arguments + !! --------- + !! + !! Filename to load the array from + character(len=*), intent(in) :: filename + !! The array 'd' will be automatically allocated with the correct dimensions + integer(int64), allocatable, intent(out) :: d(:,:) + !! + !! Example + !! ------- + !! + !!```fortran + !! integer(int64), allocatable :: data(:, :) + !! call loadtxt("log.txt", data) ! 'data' will be automatically allocated + !!``` + !! + !! Where 'log.txt' contains for example:: + !! + !! 1 2 3 + !! 2 4 6 + !! 8 9 10 + !! 11 12 13 + !! ... + !! + integer :: s + integer :: nrow, ncol, i + + s = open(filename) + + ! determine number of columns + ncol = number_of_columns(s) + + ! determine number or rows + nrow = number_of_rows_numeric(s) + + allocate(d(nrow, ncol)) + do i = 1, nrow + read(s, *) d(i, :) + end do + close(s) + + end subroutine loadtxt_iint64 + subroutine loadtxt_csp(filename, d) + !! version: experimental + !! + !! Loads a 2D array from a text file. + !! + !! Arguments + !! --------- + !! + !! Filename to load the array from + character(len=*), intent(in) :: filename + !! The array 'd' will be automatically allocated with the correct dimensions + complex(sp), allocatable, intent(out) :: d(:,:) + !! + !! Example + !! ------- + !! + !!```fortran + !! complex(sp), allocatable :: data(:, :) + !! call loadtxt("log.txt", data) ! 'data' will be automatically allocated + !!``` + !! + !! Where 'log.txt' contains for example:: + !! + !! 1 2 3 + !! 2 4 6 + !! 8 9 10 + !! 11 12 13 + !! ... + !! + integer :: s + integer :: nrow, ncol, i + + s = open(filename) + + ! determine number of columns + ncol = number_of_columns(s) + + ! determine number or rows + nrow = number_of_rows_numeric(s) + + allocate(d(nrow, ncol)) + do i = 1, nrow + read(s, *) d(i, :) + end do + close(s) + + end subroutine loadtxt_csp + subroutine loadtxt_cdp(filename, d) + !! version: experimental + !! + !! Loads a 2D array from a text file. + !! + !! Arguments + !! --------- + !! + !! Filename to load the array from + character(len=*), intent(in) :: filename + !! The array 'd' will be automatically allocated with the correct dimensions + complex(dp), allocatable, intent(out) :: d(:,:) + !! + !! Example + !! ------- + !! + !!```fortran + !! complex(dp), allocatable :: data(:, :) + !! call loadtxt("log.txt", data) ! 'data' will be automatically allocated + !!``` + !! + !! Where 'log.txt' contains for example:: + !! + !! 1 2 3 + !! 2 4 6 + !! 8 9 10 + !! 11 12 13 + !! ... + !! + integer :: s + integer :: nrow, ncol, i + + s = open(filename) + + ! determine number of columns + ncol = number_of_columns(s) + + ! determine number or rows + nrow = number_of_rows_numeric(s) + + allocate(d(nrow, ncol)) + do i = 1, nrow + read(s, *) d(i, :) + end do + close(s) + + end subroutine loadtxt_cdp + subroutine loadtxt_cqp(filename, d) + !! version: experimental + !! + !! Loads a 2D array from a text file. + !! + !! Arguments + !! --------- + !! + !! Filename to load the array from + character(len=*), intent(in) :: filename + !! The array 'd' will be automatically allocated with the correct dimensions + complex(qp), allocatable, intent(out) :: d(:,:) + !! + !! Example + !! ------- + !! + !!```fortran + !! complex(qp), allocatable :: data(:, :) + !! call loadtxt("log.txt", data) ! 'data' will be automatically allocated + !!``` + !! + !! Where 'log.txt' contains for example:: + !! + !! 1 2 3 + !! 2 4 6 + !! 8 9 10 + !! 11 12 13 + !! ... + !! + integer :: s + integer :: nrow, ncol, i + + s = open(filename) + + ! determine number of columns + ncol = number_of_columns(s) + + ! determine number or rows + nrow = number_of_rows_numeric(s) + + allocate(d(nrow, ncol)) + do i = 1, nrow + read(s, *) d(i, :) + end do + close(s) + + end subroutine loadtxt_cqp + + + subroutine savetxt_rsp(filename, d) + !! version: experimental + !! + !! Saves a 2D array into a text file. + !! + !! Arguments + !! --------- + !! + character(len=*), intent(in) :: filename ! File to save the array to + real(sp), intent(in) :: d(:,:) ! The 2D array to save + !! + !! Example + !! ------- + !! + !!```fortran + !! real(sp) :: data(3, 2) + !! call savetxt("log.txt", data) + !!``` + !! + + integer :: s, i + s = open(filename, "w") + do i = 1, size(d, 1) + write(s, *) d(i, :) + end do + close(s) + end subroutine savetxt_rsp + subroutine savetxt_rdp(filename, d) + !! version: experimental + !! + !! Saves a 2D array into a text file. + !! + !! Arguments + !! --------- + !! + character(len=*), intent(in) :: filename ! File to save the array to + real(dp), intent(in) :: d(:,:) ! The 2D array to save + !! + !! Example + !! ------- + !! + !!```fortran + !! real(dp) :: data(3, 2) + !! call savetxt("log.txt", data) + !!``` + !! + + integer :: s, i + s = open(filename, "w") + do i = 1, size(d, 1) + write(s, *) d(i, :) + end do + close(s) + end subroutine savetxt_rdp + subroutine savetxt_rqp(filename, d) + !! version: experimental + !! + !! Saves a 2D array into a text file. + !! + !! Arguments + !! --------- + !! + character(len=*), intent(in) :: filename ! File to save the array to + real(qp), intent(in) :: d(:,:) ! The 2D array to save + !! + !! Example + !! ------- + !! + !!```fortran + !! real(qp) :: data(3, 2) + !! call savetxt("log.txt", data) + !!``` + !! + + integer :: s, i + s = open(filename, "w") + do i = 1, size(d, 1) + write(s, *) d(i, :) + end do + close(s) + end subroutine savetxt_rqp + subroutine savetxt_iint8(filename, d) + !! version: experimental + !! + !! Saves a 2D array into a text file. + !! + !! Arguments + !! --------- + !! + character(len=*), intent(in) :: filename ! File to save the array to + integer(int8), intent(in) :: d(:,:) ! The 2D array to save + !! + !! Example + !! ------- + !! + !!```fortran + !! integer(int8) :: data(3, 2) + !! call savetxt("log.txt", data) + !!``` + !! + + integer :: s, i + s = open(filename, "w") + do i = 1, size(d, 1) + write(s, *) d(i, :) + end do + close(s) + end subroutine savetxt_iint8 + subroutine savetxt_iint16(filename, d) + !! version: experimental + !! + !! Saves a 2D array into a text file. + !! + !! Arguments + !! --------- + !! + character(len=*), intent(in) :: filename ! File to save the array to + integer(int16), intent(in) :: d(:,:) ! The 2D array to save + !! + !! Example + !! ------- + !! + !!```fortran + !! integer(int16) :: data(3, 2) + !! call savetxt("log.txt", data) + !!``` + !! + + integer :: s, i + s = open(filename, "w") + do i = 1, size(d, 1) + write(s, *) d(i, :) + end do + close(s) + end subroutine savetxt_iint16 + subroutine savetxt_iint32(filename, d) + !! version: experimental + !! + !! Saves a 2D array into a text file. + !! + !! Arguments + !! --------- + !! + character(len=*), intent(in) :: filename ! File to save the array to + integer(int32), intent(in) :: d(:,:) ! The 2D array to save + !! + !! Example + !! ------- + !! + !!```fortran + !! integer(int32) :: data(3, 2) + !! call savetxt("log.txt", data) + !!``` + !! + + integer :: s, i + s = open(filename, "w") + do i = 1, size(d, 1) + write(s, *) d(i, :) + end do + close(s) + end subroutine savetxt_iint32 + subroutine savetxt_iint64(filename, d) + !! version: experimental + !! + !! Saves a 2D array into a text file. + !! + !! Arguments + !! --------- + !! + character(len=*), intent(in) :: filename ! File to save the array to + integer(int64), intent(in) :: d(:,:) ! The 2D array to save + !! + !! Example + !! ------- + !! + !!```fortran + !! integer(int64) :: data(3, 2) + !! call savetxt("log.txt", data) + !!``` + !! + + integer :: s, i + s = open(filename, "w") + do i = 1, size(d, 1) + write(s, *) d(i, :) + end do + close(s) + end subroutine savetxt_iint64 + subroutine savetxt_csp(filename, d) + !! version: experimental + !! + !! Saves a 2D array into a text file. + !! + !! Arguments + !! --------- + !! + character(len=*), intent(in) :: filename ! File to save the array to + complex(sp), intent(in) :: d(:,:) ! The 2D array to save + !! + !! Example + !! ------- + !! + !!```fortran + !! complex(sp) :: data(3, 2) + !! call savetxt("log.txt", data) + !!``` + !! + + integer :: s, i + s = open(filename, "w") + do i = 1, size(d, 1) + write(s, *) d(i, :) + end do + close(s) + end subroutine savetxt_csp + subroutine savetxt_cdp(filename, d) + !! version: experimental + !! + !! Saves a 2D array into a text file. + !! + !! Arguments + !! --------- + !! + character(len=*), intent(in) :: filename ! File to save the array to + complex(dp), intent(in) :: d(:,:) ! The 2D array to save + !! + !! Example + !! ------- + !! + !!```fortran + !! complex(dp) :: data(3, 2) + !! call savetxt("log.txt", data) + !!``` + !! + + integer :: s, i + s = open(filename, "w") + do i = 1, size(d, 1) + write(s, *) d(i, :) + end do + close(s) + end subroutine savetxt_cdp + subroutine savetxt_cqp(filename, d) + !! version: experimental + !! + !! Saves a 2D array into a text file. + !! + !! Arguments + !! --------- + !! + character(len=*), intent(in) :: filename ! File to save the array to + complex(qp), intent(in) :: d(:,:) ! The 2D array to save + !! + !! Example + !! ------- + !! + !!```fortran + !! complex(qp) :: data(3, 2) + !! call savetxt("log.txt", data) + !!``` + !! + + integer :: s, i + s = open(filename, "w") + do i = 1, size(d, 1) + write(s, *) d(i, :) + end do + close(s) + end subroutine savetxt_cqp + + + integer function number_of_columns(s) + !! version: experimental + !! + !! determine number of columns + integer,intent(in) :: s + + integer :: ios + character :: c + logical :: lastblank + + rewind(s) + number_of_columns = 0 + lastblank = .true. + do + read(s, '(a)', advance='no', iostat=ios) c + if (ios /= 0) exit + if (lastblank .and. .not. is_blank(c)) number_of_columns = number_of_columns + 1 + lastblank = is_blank(c) + end do + rewind(s) + + end function number_of_columns + + + integer function number_of_rows_numeric(s) result(nrows) + !! version: experimental + !! + !! determine number or rows + integer,intent(in)::s + integer :: ios + + real :: r + complex :: z + + rewind(s) + nrows = 0 + do + read(s, *, iostat=ios) r + if (ios /= 0) exit + nrows = nrows + 1 + end do + + rewind(s) + + ! If there are no rows of real numbers, it may be that they are complex + if( nrows == 0) then + do + read(s, *, iostat=ios) z + if (ios /= 0) exit + nrows = nrows + 1 + end do + rewind(s) + end if + end function number_of_rows_numeric + + + integer function open(filename, mode, iostat) result(u) + !! version: experimental + !! + !! Opens a file + !! ([Specification](../page/specs/stdlib_io.html#description_1)) + !! + !!##### Behavior + !! + !! + !! To open a file to read: + !! + !!```fortran + !! u = open("somefile.txt") ! The default `mode` is "rt" + !! u = open("somefile.txt", "r") + !!``` + !! + !! To open a file to write: + !! + !!```fortran + !! u = open("somefile.txt", "w") + !!``` + !! + !! To append to the end of the file if it exists: + !! + !!```fortran + !! u = open("somefile.txt", "a") + !!``` + + character(*), intent(in) :: filename + character(*), intent(in), optional :: mode + integer, intent(out), optional :: iostat + + character(3) :: mode_ + character(:),allocatable :: action_, position_, status_, access_, form_ + + + mode_ = parse_mode(optval(mode, "")) + + select case (mode_(1:2)) + case('r') + action_='read' + position_='asis' + status_='old' + case('w') + action_='write' + position_='asis' + status_='replace' + case('a') + action_='write' + position_='append' + status_='old' + case('x') + action_='write' + position_='asis' + status_='new' + case('r+') + action_='readwrite' + position_='asis' + status_='old' + case('w+') + action_='readwrite' + position_='asis' + status_='replace' + case('a+') + action_='readwrite' + position_='append' + status_='old' + case('x+') + action_='readwrite' + position_='asis' + status_='new' + case default + call error_stop("Unsupported mode: "//mode_(1:2)) + end select + + select case (mode_(3:3)) + case('t') + form_='formatted' + case('b') + form_='unformatted' + case default + call error_stop("Unsupported mode: "//mode_(3:3)) + end select + + access_ = 'stream' + + if (present(iostat)) then + open(newunit=u, file=filename, & + action = action_, position = position_, status = status_, & + access = access_, form = form_, & + iostat = iostat) + else + open(newunit=u, file=filename, & + action = action_, position = position_, status = status_, & + access = access_, form = form_) + end if + + end function open + + character(3) function parse_mode(mode) result(mode_) + character(*), intent(in) :: mode + + integer :: i + character(:),allocatable :: a + logical :: lfirst(3) + + mode_ = 'r t' + + if (len_trim(mode) == 0) return + a=trim(adjustl(mode)) + + lfirst = .true. + do i=1,len(a) + if (lfirst(1) & + .and. (a(i:i) == 'r' .or. a(i:i) == 'w' .or. a(i:i) == 'a' .or. a(i:i) == 'x') & + ) then + mode_(1:1) = a(i:i) + lfirst(1)=.false. + else if (lfirst(2) .and. a(i:i) == '+') then + mode_(2:2) = a(i:i) + lfirst(2)=.false. + else if (lfirst(3) .and. (a(i:i) == 't' .or. a(i:i) == 'b')) then + mode_(3:3) = a(i:i) + lfirst(3)=.false. + else if (a(i:i) == ' ') then + cycle + else if(any(.not.lfirst)) then + call error_stop("Wrong mode: "//trim(a)) + else + call error_stop("Wrong character: "//a(i:i)) + endif + end do + + end function parse_mode + +end module diff --git a/src/fpm/stdlib_kinds.f90 b/src/fpm/stdlib_kinds.f90 new file mode 100644 index 000000000..0ef3bf899 --- /dev/null +++ b/src/fpm/stdlib_kinds.f90 @@ -0,0 +1,14 @@ +module stdlib_kinds +!! version: experimental +use iso_fortran_env, only: sp=>real32, dp=>real64, qp=>real128 +use iso_fortran_env, only: int8, int16, int32, int64 +use iso_c_binding, only: c_bool +! If we decide later to use iso_c_binding instead of iso_fortran_env: +!use iso_c_binding, only: sp=>c_float, dp=>c_double, qp=>c_float128 +!use iso_c_binding, only: int8=>c_int8_t, int16=>c_int16_t, int32=>c_int32_t, int64=>c_int64_t +implicit none +private +public sp, dp, qp, int8, int16, int32, int64, lk, c_bool + +integer, parameter :: lk = kind(.true.) +end module stdlib_kinds diff --git a/src/fpm/stdlib_linalg.f90 b/src/fpm/stdlib_linalg.f90 new file mode 100644 index 000000000..e632a5971 --- /dev/null +++ b/src/fpm/stdlib_linalg.f90 @@ -0,0 +1,332 @@ +module stdlib_linalg + !!Provides a support for various linear algebra procedures + !! ([Specification](../page/specs/stdlib_linalg.html)) + use stdlib_kinds, only: sp, dp, qp, & + int8, int16, int32, int64 + implicit none + private + + public :: diag + public :: eye + public :: trace + + interface diag + !! version: experimental + !! + !! Creates a diagonal array or extract the diagonal elements of an array + !! ([Specification](../page/specs/stdlib_linalg.html#description)) + ! + ! Vector to matrix + ! + module function diag_rsp(v) result(res) + real(sp), intent(in) :: v(:) + real(sp) :: res(size(v),size(v)) + end function diag_rsp + module function diag_rdp(v) result(res) + real(dp), intent(in) :: v(:) + real(dp) :: res(size(v),size(v)) + end function diag_rdp + module function diag_rqp(v) result(res) + real(qp), intent(in) :: v(:) + real(qp) :: res(size(v),size(v)) + end function diag_rqp + module function diag_csp(v) result(res) + complex(sp), intent(in) :: v(:) + complex(sp) :: res(size(v),size(v)) + end function diag_csp + module function diag_cdp(v) result(res) + complex(dp), intent(in) :: v(:) + complex(dp) :: res(size(v),size(v)) + end function diag_cdp + module function diag_cqp(v) result(res) + complex(qp), intent(in) :: v(:) + complex(qp) :: res(size(v),size(v)) + end function diag_cqp + module function diag_iint8(v) result(res) + integer(int8), intent(in) :: v(:) + integer(int8) :: res(size(v),size(v)) + end function diag_iint8 + module function diag_iint16(v) result(res) + integer(int16), intent(in) :: v(:) + integer(int16) :: res(size(v),size(v)) + end function diag_iint16 + module function diag_iint32(v) result(res) + integer(int32), intent(in) :: v(:) + integer(int32) :: res(size(v),size(v)) + end function diag_iint32 + module function diag_iint64(v) result(res) + integer(int64), intent(in) :: v(:) + integer(int64) :: res(size(v),size(v)) + end function diag_iint64 + module function diag_rsp_k(v,k) result(res) + real(sp), intent(in) :: v(:) + integer, intent(in) :: k + real(sp) :: res(size(v)+abs(k),size(v)+abs(k)) + end function diag_rsp_k + module function diag_rdp_k(v,k) result(res) + real(dp), intent(in) :: v(:) + integer, intent(in) :: k + real(dp) :: res(size(v)+abs(k),size(v)+abs(k)) + end function diag_rdp_k + module function diag_rqp_k(v,k) result(res) + real(qp), intent(in) :: v(:) + integer, intent(in) :: k + real(qp) :: res(size(v)+abs(k),size(v)+abs(k)) + end function diag_rqp_k + module function diag_csp_k(v,k) result(res) + complex(sp), intent(in) :: v(:) + integer, intent(in) :: k + complex(sp) :: res(size(v)+abs(k),size(v)+abs(k)) + end function diag_csp_k + module function diag_cdp_k(v,k) result(res) + complex(dp), intent(in) :: v(:) + integer, intent(in) :: k + complex(dp) :: res(size(v)+abs(k),size(v)+abs(k)) + end function diag_cdp_k + module function diag_cqp_k(v,k) result(res) + complex(qp), intent(in) :: v(:) + integer, intent(in) :: k + complex(qp) :: res(size(v)+abs(k),size(v)+abs(k)) + end function diag_cqp_k + module function diag_iint8_k(v,k) result(res) + integer(int8), intent(in) :: v(:) + integer, intent(in) :: k + integer(int8) :: res(size(v)+abs(k),size(v)+abs(k)) + end function diag_iint8_k + module function diag_iint16_k(v,k) result(res) + integer(int16), intent(in) :: v(:) + integer, intent(in) :: k + integer(int16) :: res(size(v)+abs(k),size(v)+abs(k)) + end function diag_iint16_k + module function diag_iint32_k(v,k) result(res) + integer(int32), intent(in) :: v(:) + integer, intent(in) :: k + integer(int32) :: res(size(v)+abs(k),size(v)+abs(k)) + end function diag_iint32_k + module function diag_iint64_k(v,k) result(res) + integer(int64), intent(in) :: v(:) + integer, intent(in) :: k + integer(int64) :: res(size(v)+abs(k),size(v)+abs(k)) + end function diag_iint64_k + + ! + ! Matrix to vector + ! + module function diag_rsp_mat(A) result(res) + real(sp), intent(in) :: A(:,:) + real(sp) :: res(minval(shape(A))) + end function diag_rsp_mat + module function diag_rdp_mat(A) result(res) + real(dp), intent(in) :: A(:,:) + real(dp) :: res(minval(shape(A))) + end function diag_rdp_mat + module function diag_rqp_mat(A) result(res) + real(qp), intent(in) :: A(:,:) + real(qp) :: res(minval(shape(A))) + end function diag_rqp_mat + module function diag_csp_mat(A) result(res) + complex(sp), intent(in) :: A(:,:) + complex(sp) :: res(minval(shape(A))) + end function diag_csp_mat + module function diag_cdp_mat(A) result(res) + complex(dp), intent(in) :: A(:,:) + complex(dp) :: res(minval(shape(A))) + end function diag_cdp_mat + module function diag_cqp_mat(A) result(res) + complex(qp), intent(in) :: A(:,:) + complex(qp) :: res(minval(shape(A))) + end function diag_cqp_mat + module function diag_iint8_mat(A) result(res) + integer(int8), intent(in) :: A(:,:) + integer(int8) :: res(minval(shape(A))) + end function diag_iint8_mat + module function diag_iint16_mat(A) result(res) + integer(int16), intent(in) :: A(:,:) + integer(int16) :: res(minval(shape(A))) + end function diag_iint16_mat + module function diag_iint32_mat(A) result(res) + integer(int32), intent(in) :: A(:,:) + integer(int32) :: res(minval(shape(A))) + end function diag_iint32_mat + module function diag_iint64_mat(A) result(res) + integer(int64), intent(in) :: A(:,:) + integer(int64) :: res(minval(shape(A))) + end function diag_iint64_mat + module function diag_rsp_mat_k(A,k) result(res) + real(sp), intent(in) :: A(:,:) + integer, intent(in) :: k + real(sp) :: res(minval(shape(A))-abs(k)) + end function diag_rsp_mat_k + module function diag_rdp_mat_k(A,k) result(res) + real(dp), intent(in) :: A(:,:) + integer, intent(in) :: k + real(dp) :: res(minval(shape(A))-abs(k)) + end function diag_rdp_mat_k + module function diag_rqp_mat_k(A,k) result(res) + real(qp), intent(in) :: A(:,:) + integer, intent(in) :: k + real(qp) :: res(minval(shape(A))-abs(k)) + end function diag_rqp_mat_k + module function diag_csp_mat_k(A,k) result(res) + complex(sp), intent(in) :: A(:,:) + integer, intent(in) :: k + complex(sp) :: res(minval(shape(A))-abs(k)) + end function diag_csp_mat_k + module function diag_cdp_mat_k(A,k) result(res) + complex(dp), intent(in) :: A(:,:) + integer, intent(in) :: k + complex(dp) :: res(minval(shape(A))-abs(k)) + end function diag_cdp_mat_k + module function diag_cqp_mat_k(A,k) result(res) + complex(qp), intent(in) :: A(:,:) + integer, intent(in) :: k + complex(qp) :: res(minval(shape(A))-abs(k)) + end function diag_cqp_mat_k + module function diag_iint8_mat_k(A,k) result(res) + integer(int8), intent(in) :: A(:,:) + integer, intent(in) :: k + integer(int8) :: res(minval(shape(A))-abs(k)) + end function diag_iint8_mat_k + module function diag_iint16_mat_k(A,k) result(res) + integer(int16), intent(in) :: A(:,:) + integer, intent(in) :: k + integer(int16) :: res(minval(shape(A))-abs(k)) + end function diag_iint16_mat_k + module function diag_iint32_mat_k(A,k) result(res) + integer(int32), intent(in) :: A(:,:) + integer, intent(in) :: k + integer(int32) :: res(minval(shape(A))-abs(k)) + end function diag_iint32_mat_k + module function diag_iint64_mat_k(A,k) result(res) + integer(int64), intent(in) :: A(:,:) + integer, intent(in) :: k + integer(int64) :: res(minval(shape(A))-abs(k)) + end function diag_iint64_mat_k + end interface + + ! Matrix trace + interface trace + !! version: experimental + !! + !! Computes the trace of a matrix + !! ([Specification](../page/specs/stdlib_linalg.html#description_2)) + module procedure trace_rsp + module procedure trace_rdp + module procedure trace_rqp + module procedure trace_csp + module procedure trace_cdp + module procedure trace_cqp + module procedure trace_iint8 + module procedure trace_iint16 + module procedure trace_iint32 + module procedure trace_iint64 + end interface + +contains + + function eye(n) result(res) + !! version: experimental + !! + !! Constructs the identity matrix + !! ([Specification](../page/specs/stdlib_linalg.html#description_1)) + integer, intent(in) :: n + integer(int8) :: res(n, n) + integer :: i + res = 0 + do i = 1, n + res(i, i) = 1 + end do + end function eye + + + function trace_rsp(A) result(res) + real(sp), intent(in) :: A(:,:) + real(sp) :: res + integer :: i + res = 0 + do i = 1, minval(shape(A)) + res = res + A(i,i) + end do + end function trace_rsp + function trace_rdp(A) result(res) + real(dp), intent(in) :: A(:,:) + real(dp) :: res + integer :: i + res = 0 + do i = 1, minval(shape(A)) + res = res + A(i,i) + end do + end function trace_rdp + function trace_rqp(A) result(res) + real(qp), intent(in) :: A(:,:) + real(qp) :: res + integer :: i + res = 0 + do i = 1, minval(shape(A)) + res = res + A(i,i) + end do + end function trace_rqp + function trace_csp(A) result(res) + complex(sp), intent(in) :: A(:,:) + complex(sp) :: res + integer :: i + res = 0 + do i = 1, minval(shape(A)) + res = res + A(i,i) + end do + end function trace_csp + function trace_cdp(A) result(res) + complex(dp), intent(in) :: A(:,:) + complex(dp) :: res + integer :: i + res = 0 + do i = 1, minval(shape(A)) + res = res + A(i,i) + end do + end function trace_cdp + function trace_cqp(A) result(res) + complex(qp), intent(in) :: A(:,:) + complex(qp) :: res + integer :: i + res = 0 + do i = 1, minval(shape(A)) + res = res + A(i,i) + end do + end function trace_cqp + function trace_iint8(A) result(res) + integer(int8), intent(in) :: A(:,:) + integer(int8) :: res + integer :: i + res = 0 + do i = 1, minval(shape(A)) + res = res + A(i,i) + end do + end function trace_iint8 + function trace_iint16(A) result(res) + integer(int16), intent(in) :: A(:,:) + integer(int16) :: res + integer :: i + res = 0 + do i = 1, minval(shape(A)) + res = res + A(i,i) + end do + end function trace_iint16 + function trace_iint32(A) result(res) + integer(int32), intent(in) :: A(:,:) + integer(int32) :: res + integer :: i + res = 0 + do i = 1, minval(shape(A)) + res = res + A(i,i) + end do + end function trace_iint32 + function trace_iint64(A) result(res) + integer(int64), intent(in) :: A(:,:) + integer(int64) :: res + integer :: i + res = 0 + do i = 1, minval(shape(A)) + res = res + A(i,i) + end do + end function trace_iint64 +end module diff --git a/src/fpm/stdlib_linalg_diag.f90 b/src/fpm/stdlib_linalg_diag.f90 new file mode 100644 index 000000000..2be323b9d --- /dev/null +++ b/src/fpm/stdlib_linalg_diag.f90 @@ -0,0 +1,592 @@ +submodule (stdlib_linalg) stdlib_linalg_diag + + implicit none + +contains + + module function diag_rsp(v) result(res) + real(sp), intent(in) :: v(:) + real(sp) :: res(size(v),size(v)) + integer :: i + res = 0 + do i = 1, size(v) + res(i,i) = v(i) + end do + end function diag_rsp + module function diag_rdp(v) result(res) + real(dp), intent(in) :: v(:) + real(dp) :: res(size(v),size(v)) + integer :: i + res = 0 + do i = 1, size(v) + res(i,i) = v(i) + end do + end function diag_rdp + module function diag_rqp(v) result(res) + real(qp), intent(in) :: v(:) + real(qp) :: res(size(v),size(v)) + integer :: i + res = 0 + do i = 1, size(v) + res(i,i) = v(i) + end do + end function diag_rqp + module function diag_csp(v) result(res) + complex(sp), intent(in) :: v(:) + complex(sp) :: res(size(v),size(v)) + integer :: i + res = 0 + do i = 1, size(v) + res(i,i) = v(i) + end do + end function diag_csp + module function diag_cdp(v) result(res) + complex(dp), intent(in) :: v(:) + complex(dp) :: res(size(v),size(v)) + integer :: i + res = 0 + do i = 1, size(v) + res(i,i) = v(i) + end do + end function diag_cdp + module function diag_cqp(v) result(res) + complex(qp), intent(in) :: v(:) + complex(qp) :: res(size(v),size(v)) + integer :: i + res = 0 + do i = 1, size(v) + res(i,i) = v(i) + end do + end function diag_cqp + module function diag_iint8(v) result(res) + integer(int8), intent(in) :: v(:) + integer(int8) :: res(size(v),size(v)) + integer :: i + res = 0 + do i = 1, size(v) + res(i,i) = v(i) + end do + end function diag_iint8 + module function diag_iint16(v) result(res) + integer(int16), intent(in) :: v(:) + integer(int16) :: res(size(v),size(v)) + integer :: i + res = 0 + do i = 1, size(v) + res(i,i) = v(i) + end do + end function diag_iint16 + module function diag_iint32(v) result(res) + integer(int32), intent(in) :: v(:) + integer(int32) :: res(size(v),size(v)) + integer :: i + res = 0 + do i = 1, size(v) + res(i,i) = v(i) + end do + end function diag_iint32 + module function diag_iint64(v) result(res) + integer(int64), intent(in) :: v(:) + integer(int64) :: res(size(v),size(v)) + integer :: i + res = 0 + do i = 1, size(v) + res(i,i) = v(i) + end do + end function diag_iint64 + + + module function diag_rsp_k(v,k) result(res) + real(sp), intent(in) :: v(:) + integer, intent(in) :: k + real(sp) :: res(size(v)+abs(k),size(v)+abs(k)) + integer :: i, sz + sz = size(v) + res = 0 + if (k > 0) then + do i = 1, sz + res(i,k+i) = v(i) + end do + else if (k < 0) then + do i = 1, sz + res(i+abs(k),i) = v(i) + end do + else + do i = 1, sz + res(i,i) = v(i) + end do + end if + end function diag_rsp_k + module function diag_rdp_k(v,k) result(res) + real(dp), intent(in) :: v(:) + integer, intent(in) :: k + real(dp) :: res(size(v)+abs(k),size(v)+abs(k)) + integer :: i, sz + sz = size(v) + res = 0 + if (k > 0) then + do i = 1, sz + res(i,k+i) = v(i) + end do + else if (k < 0) then + do i = 1, sz + res(i+abs(k),i) = v(i) + end do + else + do i = 1, sz + res(i,i) = v(i) + end do + end if + end function diag_rdp_k + module function diag_rqp_k(v,k) result(res) + real(qp), intent(in) :: v(:) + integer, intent(in) :: k + real(qp) :: res(size(v)+abs(k),size(v)+abs(k)) + integer :: i, sz + sz = size(v) + res = 0 + if (k > 0) then + do i = 1, sz + res(i,k+i) = v(i) + end do + else if (k < 0) then + do i = 1, sz + res(i+abs(k),i) = v(i) + end do + else + do i = 1, sz + res(i,i) = v(i) + end do + end if + end function diag_rqp_k + module function diag_csp_k(v,k) result(res) + complex(sp), intent(in) :: v(:) + integer, intent(in) :: k + complex(sp) :: res(size(v)+abs(k),size(v)+abs(k)) + integer :: i, sz + sz = size(v) + res = 0 + if (k > 0) then + do i = 1, sz + res(i,k+i) = v(i) + end do + else if (k < 0) then + do i = 1, sz + res(i+abs(k),i) = v(i) + end do + else + do i = 1, sz + res(i,i) = v(i) + end do + end if + end function diag_csp_k + module function diag_cdp_k(v,k) result(res) + complex(dp), intent(in) :: v(:) + integer, intent(in) :: k + complex(dp) :: res(size(v)+abs(k),size(v)+abs(k)) + integer :: i, sz + sz = size(v) + res = 0 + if (k > 0) then + do i = 1, sz + res(i,k+i) = v(i) + end do + else if (k < 0) then + do i = 1, sz + res(i+abs(k),i) = v(i) + end do + else + do i = 1, sz + res(i,i) = v(i) + end do + end if + end function diag_cdp_k + module function diag_cqp_k(v,k) result(res) + complex(qp), intent(in) :: v(:) + integer, intent(in) :: k + complex(qp) :: res(size(v)+abs(k),size(v)+abs(k)) + integer :: i, sz + sz = size(v) + res = 0 + if (k > 0) then + do i = 1, sz + res(i,k+i) = v(i) + end do + else if (k < 0) then + do i = 1, sz + res(i+abs(k),i) = v(i) + end do + else + do i = 1, sz + res(i,i) = v(i) + end do + end if + end function diag_cqp_k + module function diag_iint8_k(v,k) result(res) + integer(int8), intent(in) :: v(:) + integer, intent(in) :: k + integer(int8) :: res(size(v)+abs(k),size(v)+abs(k)) + integer :: i, sz + sz = size(v) + res = 0 + if (k > 0) then + do i = 1, sz + res(i,k+i) = v(i) + end do + else if (k < 0) then + do i = 1, sz + res(i+abs(k),i) = v(i) + end do + else + do i = 1, sz + res(i,i) = v(i) + end do + end if + end function diag_iint8_k + module function diag_iint16_k(v,k) result(res) + integer(int16), intent(in) :: v(:) + integer, intent(in) :: k + integer(int16) :: res(size(v)+abs(k),size(v)+abs(k)) + integer :: i, sz + sz = size(v) + res = 0 + if (k > 0) then + do i = 1, sz + res(i,k+i) = v(i) + end do + else if (k < 0) then + do i = 1, sz + res(i+abs(k),i) = v(i) + end do + else + do i = 1, sz + res(i,i) = v(i) + end do + end if + end function diag_iint16_k + module function diag_iint32_k(v,k) result(res) + integer(int32), intent(in) :: v(:) + integer, intent(in) :: k + integer(int32) :: res(size(v)+abs(k),size(v)+abs(k)) + integer :: i, sz + sz = size(v) + res = 0 + if (k > 0) then + do i = 1, sz + res(i,k+i) = v(i) + end do + else if (k < 0) then + do i = 1, sz + res(i+abs(k),i) = v(i) + end do + else + do i = 1, sz + res(i,i) = v(i) + end do + end if + end function diag_iint32_k + module function diag_iint64_k(v,k) result(res) + integer(int64), intent(in) :: v(:) + integer, intent(in) :: k + integer(int64) :: res(size(v)+abs(k),size(v)+abs(k)) + integer :: i, sz + sz = size(v) + res = 0 + if (k > 0) then + do i = 1, sz + res(i,k+i) = v(i) + end do + else if (k < 0) then + do i = 1, sz + res(i+abs(k),i) = v(i) + end do + else + do i = 1, sz + res(i,i) = v(i) + end do + end if + end function diag_iint64_k + + module function diag_rsp_mat(A) result(res) + real(sp), intent(in) :: A(:,:) + real(sp) :: res(minval(shape(A))) + integer :: i + do i = 1, minval(shape(A)) + res(i) = A(i,i) + end do + end function diag_rsp_mat + module function diag_rdp_mat(A) result(res) + real(dp), intent(in) :: A(:,:) + real(dp) :: res(minval(shape(A))) + integer :: i + do i = 1, minval(shape(A)) + res(i) = A(i,i) + end do + end function diag_rdp_mat + module function diag_rqp_mat(A) result(res) + real(qp), intent(in) :: A(:,:) + real(qp) :: res(minval(shape(A))) + integer :: i + do i = 1, minval(shape(A)) + res(i) = A(i,i) + end do + end function diag_rqp_mat + module function diag_csp_mat(A) result(res) + complex(sp), intent(in) :: A(:,:) + complex(sp) :: res(minval(shape(A))) + integer :: i + do i = 1, minval(shape(A)) + res(i) = A(i,i) + end do + end function diag_csp_mat + module function diag_cdp_mat(A) result(res) + complex(dp), intent(in) :: A(:,:) + complex(dp) :: res(minval(shape(A))) + integer :: i + do i = 1, minval(shape(A)) + res(i) = A(i,i) + end do + end function diag_cdp_mat + module function diag_cqp_mat(A) result(res) + complex(qp), intent(in) :: A(:,:) + complex(qp) :: res(minval(shape(A))) + integer :: i + do i = 1, minval(shape(A)) + res(i) = A(i,i) + end do + end function diag_cqp_mat + module function diag_iint8_mat(A) result(res) + integer(int8), intent(in) :: A(:,:) + integer(int8) :: res(minval(shape(A))) + integer :: i + do i = 1, minval(shape(A)) + res(i) = A(i,i) + end do + end function diag_iint8_mat + module function diag_iint16_mat(A) result(res) + integer(int16), intent(in) :: A(:,:) + integer(int16) :: res(minval(shape(A))) + integer :: i + do i = 1, minval(shape(A)) + res(i) = A(i,i) + end do + end function diag_iint16_mat + module function diag_iint32_mat(A) result(res) + integer(int32), intent(in) :: A(:,:) + integer(int32) :: res(minval(shape(A))) + integer :: i + do i = 1, minval(shape(A)) + res(i) = A(i,i) + end do + end function diag_iint32_mat + module function diag_iint64_mat(A) result(res) + integer(int64), intent(in) :: A(:,:) + integer(int64) :: res(minval(shape(A))) + integer :: i + do i = 1, minval(shape(A)) + res(i) = A(i,i) + end do + end function diag_iint64_mat + + module function diag_rsp_mat_k(A,k) result(res) + real(sp), intent(in) :: A(:,:) + integer, intent(in) :: k + real(sp) :: res(minval(shape(A))-abs(k)) + integer :: i, sz + sz = minval(shape(A))-abs(k) + if (k > 0) then + do i = 1, sz + res(i) = A(i,k+i) + end do + else if (k < 0) then + do i = 1, sz + res(i) = A(i+abs(k),i) + end do + else + do i = 1, sz + res(i) = A(i,i) + end do + end if + end function diag_rsp_mat_k + module function diag_rdp_mat_k(A,k) result(res) + real(dp), intent(in) :: A(:,:) + integer, intent(in) :: k + real(dp) :: res(minval(shape(A))-abs(k)) + integer :: i, sz + sz = minval(shape(A))-abs(k) + if (k > 0) then + do i = 1, sz + res(i) = A(i,k+i) + end do + else if (k < 0) then + do i = 1, sz + res(i) = A(i+abs(k),i) + end do + else + do i = 1, sz + res(i) = A(i,i) + end do + end if + end function diag_rdp_mat_k + module function diag_rqp_mat_k(A,k) result(res) + real(qp), intent(in) :: A(:,:) + integer, intent(in) :: k + real(qp) :: res(minval(shape(A))-abs(k)) + integer :: i, sz + sz = minval(shape(A))-abs(k) + if (k > 0) then + do i = 1, sz + res(i) = A(i,k+i) + end do + else if (k < 0) then + do i = 1, sz + res(i) = A(i+abs(k),i) + end do + else + do i = 1, sz + res(i) = A(i,i) + end do + end if + end function diag_rqp_mat_k + module function diag_csp_mat_k(A,k) result(res) + complex(sp), intent(in) :: A(:,:) + integer, intent(in) :: k + complex(sp) :: res(minval(shape(A))-abs(k)) + integer :: i, sz + sz = minval(shape(A))-abs(k) + if (k > 0) then + do i = 1, sz + res(i) = A(i,k+i) + end do + else if (k < 0) then + do i = 1, sz + res(i) = A(i+abs(k),i) + end do + else + do i = 1, sz + res(i) = A(i,i) + end do + end if + end function diag_csp_mat_k + module function diag_cdp_mat_k(A,k) result(res) + complex(dp), intent(in) :: A(:,:) + integer, intent(in) :: k + complex(dp) :: res(minval(shape(A))-abs(k)) + integer :: i, sz + sz = minval(shape(A))-abs(k) + if (k > 0) then + do i = 1, sz + res(i) = A(i,k+i) + end do + else if (k < 0) then + do i = 1, sz + res(i) = A(i+abs(k),i) + end do + else + do i = 1, sz + res(i) = A(i,i) + end do + end if + end function diag_cdp_mat_k + module function diag_cqp_mat_k(A,k) result(res) + complex(qp), intent(in) :: A(:,:) + integer, intent(in) :: k + complex(qp) :: res(minval(shape(A))-abs(k)) + integer :: i, sz + sz = minval(shape(A))-abs(k) + if (k > 0) then + do i = 1, sz + res(i) = A(i,k+i) + end do + else if (k < 0) then + do i = 1, sz + res(i) = A(i+abs(k),i) + end do + else + do i = 1, sz + res(i) = A(i,i) + end do + end if + end function diag_cqp_mat_k + module function diag_iint8_mat_k(A,k) result(res) + integer(int8), intent(in) :: A(:,:) + integer, intent(in) :: k + integer(int8) :: res(minval(shape(A))-abs(k)) + integer :: i, sz + sz = minval(shape(A))-abs(k) + if (k > 0) then + do i = 1, sz + res(i) = A(i,k+i) + end do + else if (k < 0) then + do i = 1, sz + res(i) = A(i+abs(k),i) + end do + else + do i = 1, sz + res(i) = A(i,i) + end do + end if + end function diag_iint8_mat_k + module function diag_iint16_mat_k(A,k) result(res) + integer(int16), intent(in) :: A(:,:) + integer, intent(in) :: k + integer(int16) :: res(minval(shape(A))-abs(k)) + integer :: i, sz + sz = minval(shape(A))-abs(k) + if (k > 0) then + do i = 1, sz + res(i) = A(i,k+i) + end do + else if (k < 0) then + do i = 1, sz + res(i) = A(i+abs(k),i) + end do + else + do i = 1, sz + res(i) = A(i,i) + end do + end if + end function diag_iint16_mat_k + module function diag_iint32_mat_k(A,k) result(res) + integer(int32), intent(in) :: A(:,:) + integer, intent(in) :: k + integer(int32) :: res(minval(shape(A))-abs(k)) + integer :: i, sz + sz = minval(shape(A))-abs(k) + if (k > 0) then + do i = 1, sz + res(i) = A(i,k+i) + end do + else if (k < 0) then + do i = 1, sz + res(i) = A(i+abs(k),i) + end do + else + do i = 1, sz + res(i) = A(i,i) + end do + end if + end function diag_iint32_mat_k + module function diag_iint64_mat_k(A,k) result(res) + integer(int64), intent(in) :: A(:,:) + integer, intent(in) :: k + integer(int64) :: res(minval(shape(A))-abs(k)) + integer :: i, sz + sz = minval(shape(A))-abs(k) + if (k > 0) then + do i = 1, sz + res(i) = A(i,k+i) + end do + else if (k < 0) then + do i = 1, sz + res(i) = A(i+abs(k),i) + end do + else + do i = 1, sz + res(i) = A(i,i) + end do + end if + end function diag_iint64_mat_k + +end submodule diff --git a/src/fpm/stdlib_logger.f90 b/src/fpm/stdlib_logger.f90 new file mode 100644 index 000000000..7951ae643 --- /dev/null +++ b/src/fpm/stdlib_logger.f90 @@ -0,0 +1,1584 @@ +module stdlib_logger +!!### Module stdlib_logger +!! +!! This module defines a derived type, procedures, a variable, and +!! constants to be used for logging information and reporting errors +!! in Fortran applications. +!!([Specification](../page/specs/stdlib_logger.html)) + +!! The derived type, `logger_type`, is to be used to define variables to +!! serve as both local and global loggers. A logger directs its messages +!! to selected I/O units so the user has a record (a log) of major events. +!! For each entity of `logger_type` the reports go to a list of I/O units +!! represented by the private internal array, `log_units`. If `log_units` is +!! empty then output by default goes to `output_unit`. Otherwise reports +!! go to `output_unit` only if it has been explicitly added to `log_units`. +!! Each entity of type `logger_type` also maintains an internal state +!! controlling the formatting of output. +!! +!! The procedures are as follows. The logical function +!! `log_units_assigned` returns the number of I/O units in `log_units`. The +!! subroutines `add_log_file` and `add_log_unit` include the specified file +!! in `log_units`. `remove_log_units` removes the specified logical unit from +!! the `log_units` array and optionally closes the file. `configure` +!! configures the details of the logging process. `configuration` +!! reports the details of that configuration. The subroutines +!! `log_error`, `log_information`, `log_io_error`, `log_message`, +!! `log_text_error`, and `log_warning` send messages to the log units. +!! +!! The variable `global_logger` of type `logger_type` can be used +!! as a default global logger anywhere in the source code. +!! +!! The constants are used to report errors by some of the subroutines +!! in their optional `stat` arguments. The constants are as follows. +!! `success` indicates that no error has occurred. `close_failure` +!! indicates that a `close` statement for an I/O unit failed. +!! `index_invalid_error` indicates that `column` was invalid for +!! the given `line`. `open_failure` indicates that an `open` statement +!! failed. `read_only_error` indicates that an output unit did not have a +!! `"write"` or `"readwrite"` action. `non_sequential_error` indicates +!! that the unit did not have `sequential` access. `unformatted_in_error` +!! indicates that the unit did not have a `form` of `"formatted"`. +!! `unopened_in_error` indicates that the unit was not opened. `write_failure` +!! indicates that at least one of the writes to `log_units` failed. + + use, intrinsic :: & + iso_fortran_env, only : & + error_unit, & + input_unit, & + output_unit + + use stdlib_ascii, only : to_lower + use stdlib_optval, only : optval + + implicit none + + private + public :: global_logger, logger_type + + !! public constants used as error flags + integer, parameter, public :: & + success = 0, & + close_failure = 1, & + index_invalid_error = 2, & + non_sequential_error = 3, & + open_failure = 4, & + read_only_error = 5, & + unformatted_in_error = 6, & + unopened_in_error = 7, & + write_failure = 8 + + integer, parameter, public :: & + debug_level = 10, & + information_level = 20, & + warning_level = 30, & + error_level = 40, & + io_error_level = 40, & + text_error_level = 50, & + all_level = -10 + min( & + debug_level, & + information_level, & + warning_level, & + error_level, & + io_error_level, & + text_error_level), & + none_level = 10 + max( & + debug_level, & + information_level, & + warning_level, & + error_level, & + io_error_level, & + text_error_level) + + character(*), parameter :: module_name = 'stdlib_logger' + + type :: logger_type + !! version: experimental + + !! Public derived type ([Specification](../page/specs/stdlib_logger.html#the-derived-type-logger_type)) + private + + logical :: add_blank_line = .false. + logical :: indent_lines = .true. + integer :: level = information_level + integer, allocatable :: log_units(:) + integer :: max_width = 0 + logical :: time_stamp = .true. + integer :: units = 0 + + contains + + private + + procedure, public, pass(self) :: add_log_file + procedure, public, pass(self) :: add_log_unit + procedure, public, pass(self) :: configuration + procedure, public, pass(self) :: configure + procedure, public, pass(self) :: log_debug + procedure, public, pass(self) :: log_error + procedure, public, pass(self) :: log_information + procedure, public, pass(self) :: log_io_error + procedure, public, pass(self) :: log_message + procedure, public, pass(self) :: log_text_error + procedure, public, pass(self) :: log_units_assigned + procedure, public, pass(self) :: log_warning + procedure, public, pass(self) :: remove_log_unit + + final :: final_logger + + end type logger_type + + !! Variable of type `logger_type` to be used as a global logger + type(logger_type) :: global_logger + + character(*), parameter :: & + invalid_column = 'column is not a valid index to line.' + +contains + + subroutine add_log_file( self, filename, unit, action, position, status, & + stat ) +!! version: experimental + +!! Opens a formatted sequential access output file, `filename` using +!! `newunit` and adds the resulting unit number to `self`'s `log_units` +!! array. `action`, if present, is the `action` specifier of the `open` +!! statement, and has the default value of `"write"`. `position`, if present, +!! is the `position` specifier, and has the default value of `"REWIND"`. +!! `status`, if present, is the `status` specifier of the `open` statement, +!! and has the default value of `"REPLACE"`. `stat`, if present, has the value +!! `success` if `filename` could be opened, `read_only_error` if `action` is +!! `"read"`, and `open_failure` otherwise. +!!([Specification](../page/specs/stdlib_logger.html#add_log_file-open-a-file-and-add-its-unit-to-self-log_units)) + class(logger_type), intent(inout) :: self +!! The logger variable to which the file is to be added + character(*), intent(in) :: filename +!! The name of the file to be added to the logger + integer, intent(out), optional :: unit +!! The resulting I/O unit number + character(*), intent(in), optional :: action +!! The `action` specifier for the `open`` statement + character(*), intent(in), optional :: position +!! The `position` specifier for the `open` statement + character(*), intent(in), optional :: status +!! The `status` specifier for the `open` statement + integer, intent(out), optional :: stat +!! The error status on exit with the possible values +!! * `success` - no errors found +!! * `read_only_error` - file unopened as `action1 was `"read"` for an output +!! file +!! * `open_failure` - the `open` statement failed + + +!!##### Example +!! +!! program main +!! use stdlib_logger +!! ... +!! integer :: unit, stat +!! ... +!! call global_logger % add_log_file( 'error_log.txt', unit, & +!! position='asis', stat=stat ) +!! if ( stat /= success ) then +!! error stop 'Unable to open "error_log.txt".' +!! end if +!! ... +!! end program main + + character(16) :: aaction, aposition, astatus + integer :: aunit + character(128) :: iomsg + integer :: iostat + character(*), parameter :: procedure_name = 'add_log_file' + integer, allocatable :: dummy(:) + integer :: lun + integer :: i + + aaction = optval(action, 'write') + aposition = optval(position, 'rewind') + astatus = optval(status, 'replace') + + if ( len_trim(aaction) == 4 ) then + + do i=1, 4 + aaction(i:i) = to_lower(aaction(i:i)) + end do + + if ( aaction == 'read' ) then + if ( present( stat ) ) then + stat = read_only_error + return + else + error stop 'In ' // module_name // ' % ' // & + procedure_name // ' action is "read" which ' // & + 'does not allow writes to the file.' + end if + end if + + end if + + open( newunit=aunit, file=filename, form='formatted', action=aaction, & + position=aposition, status=astatus, iostat=iostat, iomsg=iomsg, & + err=999 ) + + if ( allocated( self % log_units ) ) then + if ( size(self % log_units) == self % units ) then + allocate( dummy(2*self % units) ) + do lun=1, self % units + dummy(lun) = self % log_units(lun) + end do + dummy(self % units+1:) = 0 + call move_alloc( dummy, self % log_units ) + end if + else + allocate( self % log_units(16) ) + end if + + self % log_units(self % units + 1 ) = aunit + self % units = self % units + 1 + if ( present(unit) ) unit = aunit + if ( present(stat) ) stat = success + + return + +999 if (present(stat) ) then + stat = open_failure + return + else + call self % log_io_error( 'Unable to open ' // trim(filename), & + module = module_name, & + procedure = procedure_name, & + iostat = iostat, & + iomsg = iomsg ) + error stop module_name // ' % ' // procedure_name // & + ': Unable to open file' + end if + + end subroutine add_log_file + + + subroutine add_log_unit( self, unit, stat ) +!! version: experimental + +!! Adds `unit` to the log file units in `log_units`. `unit` must be an `open` +!! file, of `form` `"formatted"`, with `"sequential"` `access`, and an `action` +!! of `"write"` or `"readwrite"`, otherwise either `stat`, if present, has a +!! value other than `success` and `unit` is not entered into `log_units`, +!! or, if `stat` is not presecn, processing stops. +!!([Specification](../page/specs/stdlib_logger.html#add_log_unit-add-a-unit-to-the-array-self-log_units)) + + class(logger_type), intent(inout) :: self +!! The logger variable to which the I/O unit is to be added + integer, intent(in) :: unit +!! The input logical unit number + integer, intent(out), optional :: stat +!! An error code with the possible values +!! * `success` - no problems were found +!! * `non_sequential_error` - `unit` did not have sequential access +!! * `read_only_error` - `unit` was not writeable +!! * `unformatted_in_error` - `unit` was an `'unformatted'` file +!! * `unopened_in_error` - `unit` was not opened + +!!##### Example +!! +!! program main +!! use stdlib_logger +!! ... +!! character(256) :: iomsg +!! integer :: iostat, unit, stat +!! ... +!! open( newunit=unit, 'error_log.txt', form='formatted', & +!! status='replace', position='rewind', err=999, & +!! action='read', iostat=iostat, iomsg=iomsg ) +!! ... +!! call global_logger % add_log_unit( unit, stat ) +!! select case ( stat ) +!! ... +!! case ( read_only_error ) +!! error stop 'Unable to write to "error_log.txt".' +!! ... +!! end select +!! ... +!! 999 error stop 'Unable to open "error_log.txt". +!! ... +!! end program main + + integer, allocatable :: dummy(:) + character(*), parameter :: procedure_name = 'set_log_unit' + integer :: lun + character(12) :: specifier + logical :: question + integer :: istat + + call validate_unit() + if ( present(stat) ) then + if ( stat /= success ) return + end if + + do lun = 1, self % units +! Check that unit is not already registered + if (self % log_units(lun) == unit ) return + end do + + if ( allocated( self % log_units ) ) then + if ( size(self % log_units) == self % units ) then + allocate( dummy(2*self % units) ) + do lun=1, self % units + dummy(lun) = self % log_units(lun) + end do + call move_alloc( dummy, self % log_units ) + end if + else + allocate( self % log_units(16) ) + end if + + self % log_units(self % units + 1 ) = unit + self % units = self % units + 1 + + contains + + subroutine validate_unit() + +! Check that unit is not input_unit + if ( unit == input_unit ) then + if ( present(stat) ) then + stat = read_only_error + return + else + error stop 'unit in ' // module_name // ' % ' // & + procedure_name // ' must not be input_unit.' + end if + end if + +! Check that unit is opened + inquire( unit, opened=question, iostat=istat ) + if(istat /= 0) question = .false. + if ( .not. question ) then + if ( present(stat) ) then + stat = unopened_in_error + return + else + error stop 'unit in ' // module_name // ' % ' // & + procedure_name // ' is not open.' + end if + end if + +! Check that unit is writeable + inquire( unit, write=specifier ) + if ( specifier(1:1) /= 'Y' .and. specifier(1:1) /= 'y' ) then + if ( present(stat) ) then + stat = read_only_error + return + else + error stop 'unit in ' // module_name // ' % ' // & + procedure_name // ' is not writeable.' + end if + end if + + inquire( unit, sequential=specifier ) + if ( specifier(1:1) /= 'Y' .and. specifier(1:1) /= 'y' ) then + if ( present(stat) ) then + stat = non_sequential_error + return + else + error stop 'unit in ' // module_name // ' % ' // & + procedure_name // ' is not "sequential".' + end if + end if + + inquire( unit, formatted=specifier ) + if ( specifier(1:1) /= 'Y' .and. specifier(1:1) /= 'y' ) then + if ( present(stat) ) then + stat = unformatted_in_error + return + else + error stop 'unit in ' // module_name // ' % ' // & + procedure_name // ' is not "formatted".' + end if + end if + + if ( present(stat) ) stat = success + + end subroutine validate_unit + + end subroutine add_log_unit + + + pure subroutine configuration( self, add_blank_line, indent, level, & + max_width, time_stamp, log_units ) +!! version: experimental + +!! Reports the logging configuration of `self`. The following attributes are +!! reported: +!! 1. `add_blank_line` is a logical flag with `.true.` implying that output +!! starts with a blank line, and `.false.` implying no blank line. +!! 2. `indent` is a logical flag with `.true.` implying that subsequent columns +!! will be indented 4 spaces and `.false.` implying no indentation. +!! 3. `level` is the lowest level for printing a message +!! 4. `max_width` is the maximum number of columns of output text with +!! `max_width` == 0 => no bounds on output width. +!! 5. `time_stamp` is a logical flag with `.true.` implying that the output +!! will have a time stamp, and `.false.` implying that there will be no +!! time stamp. +!! 6. `log_units` is an array of the I/O unit numbers to which log output +!! will be written. +!!([Specification](../page/specs/stdlib_logger.html#configuration-report-a-loggers-configuration)) + + class(logger_type), intent(in) :: self +!! The logger variable whose configuration is being reported + logical, intent(out), optional :: add_blank_line +!! A logical flag to add a preceding blank line + logical, intent(out), optional :: indent +!! A logical flag to indent subsequent lines + integer, intent(out), optional :: level +!! The minimum level for printing a message + integer, intent(out), optional :: max_width +!! The maximum number of columns for most outputs + logical, intent(out), optional :: time_stamp +!! A logical flag to add a time stamp + integer, intent(out), allocatable, optional :: log_units(:) +!! The I/O units used in output + +!!##### Example +!! +!! module example_mod +!! use stdlib_logger +!! ... +!! contains +!! ... +!! subroutine example_sub(unit, ...) +!! integer, intent(in) :: unit +!! ... +!! integer, allocatable :: log_units(:) +!! ... +!! call global_logger % configuration( log_units=log_units ) +!! if ( size(log_units) == 0 ) then +!! call add_logger_unit( unit ) +!! end if +!! .. +!! end subroutine example_sub +!! ... +!! end module example_mod + + if ( present(add_blank_line) ) add_blank_line = self % add_blank_line + if ( present(indent) ) indent = self % indent_lines + if ( present(level) ) level = self % level + if ( present(max_width) ) max_width = self % max_width + if ( present(time_stamp) ) time_stamp = self % time_stamp + if ( present(log_units) ) then + if ( self % units .gt. 0 ) then + log_units = self % log_units(1:self % units) + else + allocate(log_units(0)) + end if + end if + + end subroutine configuration + + + pure subroutine configure( self, add_blank_line, indent, level, max_width, & + time_stamp ) +!! version: experimental + +!! Configures the logging process for SELF. The following attributes are +!! configured: +!! 1. `add_blank_line` is a logical flag with `.true.` implying that output +!! starts with a blank line, and `.false.` implying no blank line. +!! `add_blank_line` has a startup value of `.false.`. +!! 2. `indent` is a logical flag with `.true.` implying that subsequent lines +!! will be indented 4 spaces and `.false.` implying no indentation. `indent` +!! has a startup value of `.true.`. +!! 3. `level` is the lowest level for printing a message +!! 4. `max_width` is the maximum number of columns of output text with +!! `max_width == 0` => no bounds on output width. `max_width` has a startup +!! value of 0. +!! 5. `time_stamp` is a logical flag with `.true.` implying that the output +!! will have a time stamp, and `.false.` implying that there will be no +!! time stamp. `time_stamp` has a startup value of `.true.`. +!!([Specification](../page/specs/stdlib_logger.html#configure-configure-the-logging-process)) +!!##### Example +!! +!! program main +!! use stdlib_logger +!! ... +!! call global_logger % configure( indent=.false., max_width=72 ) +!! ... + + class(logger_type), intent(inout) :: self + logical, intent(in), optional :: add_blank_line + logical, intent(in), optional :: indent + integer, intent(in), optional :: level + integer, intent(in), optional :: max_width + logical, intent(in), optional :: time_stamp + + if ( present(add_blank_line) ) self % add_blank_line = add_blank_line + if ( present(level) ) self % level = level + if ( present(indent) ) self % indent_lines = indent + if ( present(max_width) ) then + if ( max_width <= 4 ) then + self % max_width = 0 + else + self % max_width = max_width + end if + end if + if ( present(time_stamp) ) self % time_stamp = time_stamp + + end subroutine configure + + + subroutine final_logger( self ) +!! version: experimental + +!! Finalizes the `logger_type` entity `self` by flushing the units + type(logger_type), intent(in) :: self + + integer :: iostat + character(256) :: message + integer :: unit + + do unit=1, self % units + flush( self % log_units(unit), iomsg=message, iostat=iostat ) + if ( iostat /= 0 ) then + write(error_unit, '(a, i0)' ) 'In the logger_type ' // & + 'finalizer an error occurred in flushing unit = ', & + self % log_units(unit) + write(error_unit, '(a, i0)') 'With iostat = ', iostat + write(error_unit, '(a)') 'With iomsg = ' // trim(message) + end if + end do + + end subroutine final_logger + + + subroutine format_output_string( self, string, col_indent, len_buffer, buffer ) +!! version: experimental + +!! Writes the STRING to UNIT ensuring that the number of characters +!! does not exceed MAX_WIDTH and that the lines after the first +!! one are indented four characters. + class(logger_type), intent(in) :: self + character(*), intent(in) :: string + character(*), intent(in) :: col_indent + integer, intent(out) :: len_buffer + character(len=:), allocatable, intent(out) :: buffer + + integer :: count, indent_len, index_, length, remain + integer, parameter :: new_len = len(new_line('a')) + + length = len_trim(string) + allocate( character(2*length) :: buffer ) + len_buffer = 0 + indent_len = len(col_indent) + call format_first_line() + + if ( self % indent_lines ) then + do while( remain > 0 ) + call indent_format_subsequent_line() + end do + else + do while( remain > 0 ) + call format_subsequent_line() + end do + end if + + contains + + subroutine format_first_line() + + if ( self % max_width == 0 .or. & + ( length <= self % max_width .and. & + index( string(1:length), new_line('a')) == 0 ) ) then + buffer(1:length) = string(1:length) + len_buffer = length + remain = 0 + return + else + + index_ = index( string(1:min(length, self % max_width)), & + new_line('a') ) + if ( index_ == 0 ) then + do index_=self % max_width, 1, -1 + if ( string(index_:index_) == ' ' ) exit + end do + end if + + if ( index_ == 0 ) then + buffer(1:self % max_width) = & + string(1:self % max_width) + len_buffer = self % max_width + count = self % max_width + remain = length - count + return + else + buffer(1:index_-1) = string(1:index_-1) + len_buffer = index_-1 + count = index_ + remain = length - count + return + end if + + end if + + end subroutine format_first_line + + subroutine format_subsequent_line() + integer :: new_len_buffer + character(:), allocatable :: dummy + + if ( remain <= self % max_width ) then + new_len_buffer = len_buffer + length - count + new_len + if ( new_len_buffer > len( buffer ) ) then + allocate( character( 2*len( buffer ) ) :: dummy ) + dummy = buffer + call move_alloc( dummy, buffer ) + end if + buffer( len_buffer+1:new_len_buffer ) = & + new_line('a') // string(count+1:length) + len_buffer = new_len_buffer + count = length + remain = 0 + return + else + + index_ = count + index(string(count+1:count+self % max_width),& + new_line('a')) + if(index_ == count) then + do index_=count+self % max_width, count+1, -1 + if ( string(index_:index_) == ' ' ) exit + end do + end if + + if ( index_ == count ) then + new_len_buffer = len_buffer + self % max_width + & + new_len + if ( new_len_buffer > len( buffer ) ) then + allocate( character( 2*len( buffer ) ) :: dummy ) + dummy = buffer + call move_alloc( dummy, buffer ) + end if + buffer( len_buffer+1:new_len_buffer ) = & + new_line('a') // string(count+1:count+self % max_width) + len_buffer = new_len_buffer + count = count + self % max_width + remain = length - count + return + else + new_len_buffer = len_buffer + index_ - 1 & + - count + new_len + if ( new_len_buffer > len( buffer ) ) then + allocate( character( 2*len( buffer ) ) :: dummy ) + dummy = buffer + call move_alloc( dummy, buffer ) + end if + buffer( len_buffer+1:new_len_buffer ) = & + new_line('a') // string(count+1:index_-1) + len_buffer = new_len_buffer + count = index_ + remain = length - count + return + end if + + end if + + end subroutine format_subsequent_line + + subroutine indent_format_subsequent_line() + integer :: new_len_buffer + character(:), allocatable :: dummy + + if ( index( string(count+1:length), new_line('a')) == 0 .and. & + remain <= self % max_width - indent_len ) then + new_len_buffer = len_buffer + length & + - count + new_len + indent_len + if ( new_len_buffer > len( buffer ) ) then + allocate( character( 2*len( buffer ) ) :: dummy ) + dummy = buffer + call move_alloc( dummy, buffer ) + end if + buffer( len_buffer+1:new_len_buffer ) = & + new_line('a') // col_indent // string(count+1:length) + len_buffer = new_len_buffer + count = length + remain = 0 + return + else + + index_ = count + index( string(count+1: & + min ( length, count+self % max_width - indent_len) ), & + new_line('a')) + if(index_ == count) then + do index_=count+self % max_width-indent_len, count+1, -1 + if ( string(index_:index_) == ' ' ) exit + end do + end if + + if ( index_ == count ) then + new_len_buffer = len_buffer + self % max_width & + + new_len + if ( new_len_buffer > len( buffer ) ) then + allocate( character( 2*len( buffer ) ) :: dummy ) + dummy = buffer + call move_alloc( dummy, buffer ) + end if + buffer( len_buffer+1: new_len_buffer ) = & + new_line('a') // col_indent // & + string(count+1:count+self % max_width-indent_len) + len_buffer = new_len_buffer + count = count + self % max_width - indent_len + remain = length - count + return + else + new_len_buffer = len_buffer + index_ - count - 1 & + + new_len + indent_len + if ( new_len_buffer > len( buffer ) ) then + allocate( character( 2*len( buffer ) ) :: dummy ) + dummy = buffer + call move_alloc( dummy, buffer ) + end if + buffer( len_buffer+1: new_len_buffer ) = & + new_line('a') // col_indent // string(count+1:index_-1) + len_buffer = new_len_buffer + count = index_ + remain = length - count + return + end if + + end if + + end subroutine indent_format_subsequent_line + + end subroutine format_output_string + + + subroutine handle_write_failure( unit, procedure_name, iostat, iomsg ) +!! version: experimental + +!! Handles a failure to write to `unit` in `procedure_name` with `iostat` and +!! `iomsg` by writing a description of the failure to `output_unit` and +!! stopping. + integer, intent(in) :: unit + character(*), intent(in) :: procedure_name + integer, intent(in) :: iostat + character(*), intent(in) :: iomsg + + character(256) :: name + logical :: named + character(10) :: action + + write( output_unit, '(a)' ) 'write failure in ' // module_name // & + ' % ' // trim(procedure_name) // '.' + if ( unit == -999 ) then + write( output_unit, '(a, i0)' ) 'unit = internal file' + else + write( output_unit, '(a, i0)' ) 'unit = ', unit + inquire( unit, named=named ) + + if ( named ) then + inquire( unit, name=name ) + write( output_unit, '(a, a)' ) 'name = ', trim(name) + else + write( output_unit, '(a)' ) 'unit is unnamed' + end if + inquire( unit, action=action ) + write( output_unit, '(a, a)' ) 'action = ', trim(action) + end if + + write( output_unit, '(a, i0)' ) 'iostat = ', iostat + write( output_unit, '(a, a )' ) 'iomsg = ', trim(iomsg) + error stop 'write failure in ' // module_name // '.' + + end subroutine handle_write_failure + + + subroutine log_debug( self, message, module, procedure ) +!! version: experimental + +!! Writes the string `message` to `self % log_units` with optional additional +!! text. +!!([Specification](../page/specs/stdlib_logger.html#log_debug-writes-the-string-message-to-self-log_units)) +!! +!!##### Behavior +!! +!! If time stamps are active, a time stamp is written, followed by +!! `module` and `procedure` if present, and then `message` is +!! written with the prefix 'DEBUG: '. +!! +!!##### Example +!! +!! module example_mod +!! use stdlib_logger +!! ... +!! real, allocatable :: a(:) +!! ... +!! type(logger_type) :: alogger +!! ... +!! contains +!! ... +!! subroutine example_sub( selection ) +!! integer, intent(out) :: selection +!! integer :: stat +!! write(*,'(a)') "Enter an integer to select a widget" +!! read(*,'(i0)') selection +!! write( message, `(a, i0)' ) & +!! "The user selected ", selection +!! call alogger % log_debug( message, & +!! module = 'EXAMPLE_MOD', & +!! procedure = 'EXAMPLE_SUB' ) +!! ... +!! end subroutine example_sub +!! ... +!! end module example_mod +!! + + class(logger_type), intent(in) :: self +!! The logger used to send the message + character(len=*), intent(in) :: message +!! A string to be written to log_unit + character(len=*), intent(in), optional :: module +!! The name of the module containing the current invocation of `log_information` + character(len=*), intent(in), optional :: procedure +!! The name of the procedure containing the current invocation of +!! `log_information` + + if ( self % level > debug_level ) return + + call self % log_message( message, & + module = module, & + procedure = procedure, & + prefix = 'DEBUG' ) + + end subroutine log_debug + + + subroutine log_error( self, message, module, procedure, stat, errmsg ) +!! version: experimental + +!! Writes the string `message` to `self % log_units` with optional additional +!! text. +!! ([Specification](../specs/stdlib_logger.html#log_error-writes-the-string-message-to-self-log_units)) + +!!##### Behavior +!! +!! If time stamps are active, a time stamp is written, followed by +!! `module` and `procedure` if present, then `message` is +!! written with the prefix 'ERROR: ', and then if `stat` or `errmsg` +!! are present they are written. +!! +!!##### Example +!! +!! module example_mod +!! use stdlib_logger +!! ... +!! real, allocatable :: a(:) +!! ... +!! type(logger_type) :: alogger +!! ... +!! contains +!! ... +!! subroutine example_sub( size ) +!! integer, intent(in) :: size +!! character(128) :: errmsg, message +!! integer :: stat +!! allocate( a(size), stat=stat, errmsg=errmsg ) +!! if ( stat /= 0 ) then +!! write( message, `(a, i0)' ) & +!! "Allocation of A failed with SIZE = ", size +!! alogger % call log_error( message, & +!! module = 'EXAMPLE_MOD', & +!! procedure = 'EXAMPLE_SUB', & +!! stat = stat, & +!! errmsg = errmsg ) +!! end if +!! end subroutine example_sub +!! ... +!! end module example_mod +!! + + class(logger_type), intent(in) :: self +!! The logger to be used in logging the message + character(len=*), intent(in) :: message +!! A string to be written to log_unit + character(len=*), intent(in), optional :: module +!! The name of the module containing the current invocation of `log_error` + character(len=*), intent(in), optional :: procedure +!! The name of the procedure containing the current invocation of `log_error` + integer, intent(in), optional :: stat +!! The value of the `stat` specifier returned by a Fortran statement + character(len=*), intent(in), optional :: errmsg +!! The value of the `errmsg` specifier returned by a Fortran statement + + integer :: iostat + character(28) :: dummy + character(256) :: iomsg + character(*), parameter :: procedure_name = 'log_error' + character(:), allocatable :: suffix + + if ( self % level > error_level ) return + + if ( present(stat) ) then + write( dummy, '(a, i0)', err=999, iostat=iostat, iomsg=iomsg ) & + new_line('a') // "With stat = ", stat + else + dummy = ' ' + end if + + if ( present(errmsg) ) then + if ( len_trim(errmsg) > 0 ) then + suffix = trim(dummy) // & + new_line('a') // 'With errmsg = "' // trim(errmsg) // '"' + else + suffix = dummy + end if + else + suffix = dummy + end if + + call self % log_message( trim(message) // suffix, & + module = module, & + procedure = procedure, & + prefix = 'ERROR') + + return + +999 call handle_write_failure( -999, procedure_name, iostat, iomsg ) + + end subroutine log_error + + + subroutine log_information( self, message, module, procedure ) +!! version: experimental + +!! Writes the string `message` to `self % log_units` with optional additional +!! text. +!!([Specification](../page/specs/stdlib_logger.html#log_information-writes-the-string-message-to-self-log_units)) +!! +!!##### Behavior +!! +!! If time stamps are active, a time stamp is written, followed by +!! `module` and `procedure` if present, and then `message` is +!! written with the prefix 'INFO: '. +!! +!!##### Example +!! +!! module example_mod +!! use stdlib_logger +!! ... +!! real, allocatable :: a(:) +!! ... +!! type(logger_type) :: alogger +!! ... +!! contains +!! ... +!! subroutine example_sub( selection ) +!! integer, intent(out) :: selection +!! integer :: stat +!! write(*,'(a)') "Enter an integer to select a widget" +!! read(*,'(i0)') selection +!! write( message, `(a, i0)' ) & +!! "The user selected ", selection +!! call alogger % log_information( message, & +!! module = 'EXAMPLE_MOD', & +!! procedure = 'EXAMPLE_SUB' ) +!! ... +!! end subroutine example_sub +!! ... +!! end module example_mod +!! + + class(logger_type), intent(in) :: self +!! The logger used to send the message + character(len=*), intent(in) :: message +!! A string to be written to log_unit + character(len=*), intent(in), optional :: module +!! The name of the module containing the current invocation of `log_information` + character(len=*), intent(in), optional :: procedure +!! The name of the procedure containing the current invocation of +!! `log_information` + + if ( self % level > information_level ) return + + call self % log_message( message, & + module = module, & + procedure = procedure, & + prefix = 'INFO' ) + + end subroutine log_information + + + subroutine log_io_error( self, message, module, procedure, iostat, & + iomsg ) +!! version: experimental + +!! Writes the string `message` to the `self % log_units` with optional +!! additional text. +!!([Specification](../page/specs/stdlib_logger.html#log_io_error-write-the-string-message-to-self-log_units)) +!! +!!##### Behavior +!! +!! If time stamps are active, a time stamp is written, followed by +!! `module` and `procedure` if present, then `message` is +!! written with a prefix 'I/O ERROR: ', and then if `iostat` or `iomsg` +!! are present they are also written. +!! +!!##### Example +!! +!! program example +!! use stdlib_logger +!! ... +!! character(*), parameter :: filename = 'dummy.txt' +!! integer :: iostat, lun +!! character(128) :: iomsg +!! character(*), parameter :: message = 'Failure in opening "dummy.txt".' +!! +!! open( newunit=lun, file = filename, form='formatted', & +!! status='old', iostat=iostat, iomsg=iomsg ) +!! if ( iostat /= 0 ) then +!! call global_logger % log_io_error( message, procedure = 'EXAMPLE', & +!! iostat=iostat, iomsg = iomsg ) +!! error stop 'Error on opening ' // filename +!! end if +!! ... +!! end program example + + class(logger_type), intent(in) :: self +!! The logger variable to receivee the message + character(len=*), intent(in) :: message +!! A string to be written to LOG_UNIT + character(len=*), intent(in), optional :: module +!! The name of the module containing the current invocation of REPORT_ERROR + character(len=*), intent(in), optional :: procedure +!! The name of the procedure containing the current invocation of REPORT_ERROR + integer, intent(in), optional :: iostat +!! The value of the IOSTAT specifier returned by a Fortran I/O statement + character(len=*), intent(in), optional :: iomsg +!! The value of the IOMSG specifier returned by a Fortran I/O statement + + character(28) :: dummy + character(256) :: iomsg2 + integer :: iostat2 + character(*), parameter :: procedure_name = 'log_io_error' + character(:), allocatable :: suffix + + if ( self % level > io_error_level ) return + + if ( present(iostat) ) then + write( dummy, '(a, i0)', err=999, iostat=iostat2, iomsg=iomsg2 ) & + new_line('a') // "With iostat = ", iostat + else + dummy = ' ' + end if + + if ( present(iomsg) ) then + if ( len_trim(iomsg) > 0 ) then + suffix = trim(dummy) // & + new_line('a') // 'With iomsg = "' // trim(iomsg) // '"' + else + suffix = trim(dummy) + end if + else + suffix = trim(dummy) + end if + + call self % log_message( trim(message) // suffix, & + module = module, & + procedure = procedure, & + prefix = 'I/O ERROR' ) + + return + +999 call handle_write_failure( -999, procedure_name, iostat2, iomsg2 ) + + end subroutine log_io_error + + subroutine log_message( self, message, module, procedure, prefix ) +!! version: experimental + +!! Writes the string `message` to the `self % log_units` with optional +!! additional text. +!!([Specification](../page/specs/stdlib_logger.html#log_message-write-the-string-message-to-self-log_units)) +!! +!!##### Behavior +!! +!! If time stamps are active, a time stamp is written, followed by `module` +!! and `procedure` if present, followed by `prefix // ': '` if present, +!! and then `message`. +!! +!!##### Example +!! +!! module example_mod +!! use stdlib_logger +!! ... +!! real, allocatable :: a(:) +!! ... +!! contains +!! ... +!! subroutine example_sub( selection ) +!! integer, intent(out) :: selection +!! integer :: stat +!! write(*,'(a)') "Enter an integer to select a widget" +!! read(*,'(i0)') selection +!! write( message, `(a, i0)' ) & +!! "The user selected ", selection +!! call global_logger % log_message( message, & +!! module = 'example_mod', & +!! procedure = 'example_sub', & +!! prefix = 'info' ) +!! end subroutine example_sub +!! ... +!! end module example_mod +!! + + class(logger_type), intent(in) :: self +!! The logger variable to receive the message + character(len=*), intent(in) :: message +!! A string to be written to log_unit + character(len=*), intent(in), optional :: module +!! The name of the module containing the current invocation of `log_message` + character(len=*), intent(in), optional :: procedure +!! The name of the procedure containing the current invocation of `log_message` + character(len=*), intent(in), optional :: prefix +!! To be prepended to message as `prefix // ': ' // message`. + + integer :: unit + integer :: iostat + integer :: len_buffer + character(*), parameter :: procedure_name = 'log_message' + character(256) :: iomsg + character(:), allocatable :: d_and_t, m_and_p, pref + character(:), allocatable :: buffer + + if ( present(prefix) ) then + pref = prefix // ': ' + else + pref = '' + end if + + if ( self % time_stamp ) then + d_and_t = time_stamp() // ': ' + else + d_and_t = '' + end if + + if ( present(module) ) then + if ( present(procedure) ) then + m_and_p = trim(module) // ' % ' // trim(procedure) // ': ' + else + m_and_p = trim(module) // ': ' + end if + else if ( present(procedure) ) then + m_and_p = trim(procedure) // ': ' + else + m_and_p = '' + end if + + call format_output_string( self, & + d_and_t // m_and_p // pref // & + trim( message ), & + ' ', & + len_buffer, & + buffer) + + if ( self % units == 0 ) then + if ( self % add_blank_line ) then + write( output_unit, '(a)', err=999, iostat=iostat, & + iomsg=iomsg) & + new_line('a') // buffer(1:len_buffer) + else + write( output_unit, '(a)', err=999, iostat=iostat, & + iomsg=iomsg ) & + buffer(1:len_buffer) + end if + else + if ( self % add_blank_line ) then + do unit=1, self % units + write( self % log_units(unit), '(a)', err=999, iostat=iostat, & + iomsg=iomsg ) new_line('a') // & + buffer(1:len_buffer) + end do + else + do unit=1, self % units + write( self % log_units(unit), '(a)', err=999, iostat=iostat, & + iomsg=iomsg ) & + buffer(1:len_buffer) + end do + end if + end if + + + return + +999 call handle_write_failure( unit, procedure_name, iostat, iomsg ) + + end subroutine log_message + + subroutine log_text_error( self, line, column, summary, filename, & + line_number, caret, stat ) +!! version: experimental + +!! Sends a message to `self % log_units` describing an error found +!! in a line of text. +!!([Specification](../page/specs/stdlib_logger.html#log_text_error-send-a-message-to-self-log_units-describing-an-error)) + +!!##### Behavior +!! +!! If time stamps are active first a time stamp is written. Then if +!! `filename` or `line_number` or `column` are present they are written. +!! Then `line` is written. Then the symbol `caret` is written below `line` +!! at the column indicated by `column`. Then `summary` is written. +! +!!##### Example +!! +!! program example +!! ... +!! character(*), parameter :: filename = 'dummy.txt' +!! integer :: col_num, line_num, lun +!! character(128) :: line +!! character(*), parameter :: message = 'Bad text found.' +!! +!! open( newunit=lun, file = filename, statu='old', form='formatted' ) +!! line_num = 0 +!! do +!! read( lun, fmt='(a)', end=900 ) line +!! line_num = line_num + 1 +!! call check_line( line, status, col_num ) +!! if ( status /= 0 ) +!! call global_logger % log_text_error( line, col_num, message, & +!! filename, line_num ) +!! error stop 'Error in reading ' // filename +!! end if +!! ... +!! end do +!!900 continue +!! ... +!! end program example +!! + class(logger_type), intent(in) :: self +!! The logger variable to receive the message + character(*), intent(in) :: line +!! The line of text in which the error was found. + integer, intent(in) :: column +!! The one's based column in LINE at which the error starts. + character(*), intent(in) :: summary +!! A brief description of the error. + character(*), intent(in), optional :: filename +!! The name of the file, if any, in which the error was found. + integer, intent(in), optional :: line_number +!! The one's based line number in the file where `line` was found. + character(1), intent(in), optional :: caret +!! The symbol used to mark the column wher the error was first detected + integer, intent(out), optional :: stat +!! Integer flag that an error has occurred. Has the value `success` if no +!! error hass occurred, `index_invalid_error` if `column` is less than zero or +!! greater than `len(line)`, and `write_failure` if any of the `write` +!! statements has failed. + + character(1) :: acaret + character(128) :: iomsg + integer :: iostat + integer :: lun + character(*), parameter :: procedure_name = 'LOG_TEXT_ERROR' + character(len=:), allocatable :: buffer + + if ( self % level > text_error_level ) return + + acaret = optval(caret, '^') + + if ( column < 0 .or. column > len( line ) + 1 ) then + if ( present(stat) ) then + stat = index_invalid_error + return + else + call self % log_error( invalid_column, & + module = module_name, & + procedure = procedure_name ) + error stop module_name // ' % ' // procedure_name // ': ' // & + invalid_column + end if + end if + + call write_log_text_error_buffer( ) + if ( self % units == 0 ) then + write( output_unit, '(a)' ) buffer + else + do lun=1, self % units + write( self % log_units(lun), '(a)' ) buffer + end do + end if + + contains + + subroutine write_log_text_error_buffer( ) + integer :: i + character(:), allocatable :: location, marker + + if ( present(filename) ) then + if ( present(line_number) ) then + allocate( character(len_trim(filename)+15) :: location ) + write( location, fmt='(a, ":", i0, ":", i0)', err=999, & + iomsg=iomsg, iostat=iostat ) & + trim(filename) , line_number, column + else + allocate( character(len_trim(filename)+45) :: location ) + write( location, fmt='(a, i0)', err=999, iomsg=iomsg, & + iostat=iostat ) & + "Error found in file: '" // trim(filename) // & + "', at column: ", column + end if + + else + if ( present(line_number) ) then + allocate( character(54) :: location ) + write( location, fmt='(a, i0, a, i0)', err=999, & + iomsg=iomsg, iostat=iostat ) & + 'Error found at line number: ', line_number, & + ', and column: ', column + else + allocate( character(36) :: location ) + write( location, & + fmt='("Error found in line at column:", i0)' ) & + column + end if + end if + + allocate( character(column) :: marker ) + do i=1, column-1 + marker(i:i) = ' ' + end do + marker(column:column) = acaret + if ( self % add_blank_line ) then + if ( self % time_stamp ) then + buffer = new_line('a') // time_stamp() // & + new_line('a') // trim(location) // & + new_line('a') // new_line('a') // trim(line) // & + new_line('a') // marker // & + new_line('a') // 'Error: ' // trim(summary) + else + buffer = new_line('a') // trim(location) // & + new_line('a') // new_line('a') // trim(line) // & + new_line('a') // marker // & + new_line('a') // 'Error: ' // trim(summary) + end if + else + if ( self % time_stamp ) then + buffer = time_stamp() // & + new_line('a') // trim(location) // & + new_line('a') // new_line('a') // trim(line) // & + new_line('a') // marker // & + new_line('a') // 'Error: ' // trim(summary) + else + buffer = trim(location) // & + new_line('a') // new_line('a') // trim(line) // & + new_line('a') // marker // & + new_line('a') // 'Error: ' // trim(summary) + end if + end if + + if ( present(stat) ) stat = success + + return + +999 if ( present( stat ) ) then + stat = write_failure + return + else + call handle_write_failure( -999, procedure_name, iostat, & + iomsg ) + end if + + end subroutine write_log_text_error_buffer + + end subroutine log_text_error + + + elemental function log_units_assigned(self) +!! version: experimental + +!! Returns the number of units assigned to `self % log_units` +!!([Specification](../page/specs/stdlib_logger.html#log_units_assigned-returns-the-number-of-active-io-units)) + + class(logger_type), intent(in) :: self +!! The logger subject to the inquiry + integer :: log_units_assigned +!!##### Example +!! +!! module example_mod +!! use stdlib_logger +!! ... +!! type(logger_type) :: alogger +!! ... +!! contains +!! ... +!! subroutine example_sub(unit, ...) +!! integer, intent(in) :: unit +!! ... +!! integer, allocatable :: log_units(:) +!! ... +!! if ( alogger % log_units_assigned() == 0 ) then +!! call alogger % add_log_unit( unit ) +!! end if +!! ... +!! end subroutine example_sub +!! ... +!! end module example_mod + + log_units_assigned = self % units + + end function log_units_assigned + + + subroutine log_warning( self, message, module, procedure ) +!! version: experimental + +!! Writes the string `message` to `self % log_units` with optional additional +!! text. +!!([Specification](../page/specs/stdlib_logger.html#log_warning-write-the-string-message-to-log_units)) + +!!##### Behavior +!! +!! If time stamps are active, a time stamp is written, followed by +!! `module` and `procedure` if present, then `message` is +!! written with the prefix 'WARN: '. +!! +!!##### Example +!! +!! module example_mod +!! use stdlib_logger +!! ... +!! real, allocatable :: a(:) +!! ... +!! type(logger_type) :: alogger +!! ... +!! contains +!! ... +!! subroutine example_sub( size, stat ) +!! integer, intent(in) :: size +!! integer, intent(out) :: stat +!! allocate( a(size) ) +!! if ( stat /= 0 ) then +!! write( message, `(a, i0)' ) & +!! "Allocation of A failed with SIZE = ", size +!! call alogger % log_warning( message, & +!! module = 'EXAMPLE_MOD', & +!! procedure = 'EXAMPLE_SUB' ) +!! end if +!! end subroutine example_sub +!! ... +!! end module example_mod +!! + class(logger_type), intent(in) :: self +!! The logger to which the message is written + character(len=*), intent(in) :: message +!! A string to be written to LOG_UNIT + character(len=*), intent(in), optional :: module +!! The name of the module containing the current invocation of `log_warning` + character(len=*), intent(in), optional :: procedure +!! The name of the procedure containing the current invocation of `log_warning` + + if ( self % level > warning_level ) return + + call self % log_message( message, & + module = module, & + procedure = procedure, & + prefix = 'WARN' ) + + end subroutine log_warning + + + subroutine remove_log_unit( self, unit, close_unit, stat ) +!! version: experimental + +!! Remove the I/O unit from the self % log_units list. If `close_unit` is +!! present and `.true.` then the corresponding file is closed. If `unit` is +!! not in `log_units` then nothing is done. If `stat` is present it, by +!! default, has the value `success`. If closing the `unit` fails, then if +!! `stat` is present it has the value `close_failure`, otherwise processing +!! stops with an informative message. +!!([Specification](../page/specs/stdlib_logger.html#remove_log_unit-remove-unit-from-self-log_units)) + + class(logger_type), intent(inout) :: self +!! The logger variable whose unit is to be removed + integer, intent(in) :: unit +!! The I/O unit to be removed from self + logical, intent(in), optional :: close_unit +!! A logical flag to close the unit while removing it from the SELF list + integer, intent(out), optional :: stat +!! An error status with the values +!! * success - no problems found +!! * close_failure - the close statement for unit failed +!! +!!##### Example +!! +!! module example_mod +!! use stdlib_logger +!! ... +!! type(logger_type) :: alogger +!! contains +!! ... +!! subroutine example_sub(unit, ...) +!! integer, intent(in) :: unit +!! ... +!! call alogger % remove_log_unit( unit ) +!! ... +!! end subroutine example_sub +!! ... +!! end module example_mod + + character(128) :: errmsg + integer :: lun, lun_old + character(*), parameter :: procedure_name = 'REMOVE_LOG_UNIT' + + if ( present(stat) ) stat = success + do lun=1, self % units + if ( unit == self % log_units(lun) ) exit + end do + + if ( lun == self % units + 1 ) return + + if ( present(close_unit) ) then + if ( close_unit ) close( unit, err=999, iomsg=errmsg ) + end if + + do lun_old=lun+1, self % units + self % log_units(lun_old-1) = self % log_units(lun_old) + end do + self % units = self % units - 1 + + return + +999 if ( present(stat) ) then + stat = close_failure + return + else + write(*, '(a, i0)') 'In ' // module_name // ' % ' // & + procedure_name // ' close_unit failed for unit = ', unit + write(*, '(a)' ) 'With iomsg = ' // trim(errmsg) + error stop 'close_unit failed in ' // module_name // ' % ' // & + procedure_name // '.' + end if + + end subroutine remove_log_unit + + + function time_stamp() +!! Creates a time stamp in the format 'yyyy-mm-dd hh:mm:ss.sss' + character(23) :: time_stamp + character(8) :: date + character(10) :: time + + call date_and_time( date, time ) + + time_stamp(1:4) = date(1:4) + time_stamp(5:5) = '-' + time_stamp(6:7) = date(5:6) + time_stamp(8:8) = '-' + time_stamp(9:10) = date(7:8) + time_stamp(11:11) = ' ' + time_stamp(12:13) = time(1:2) + time_stamp(14:14) = ':' + time_stamp(15:16) = time(3:4) + time_stamp(17:17) = ':' + time_stamp(18:23) = time(5:10) + + end function time_stamp + +end module stdlib_logger diff --git a/src/fpm/stdlib_math.f90 b/src/fpm/stdlib_math.f90 new file mode 100644 index 000000000..7f21488ce --- /dev/null +++ b/src/fpm/stdlib_math.f90 @@ -0,0 +1,84 @@ + +module stdlib_math + use stdlib_kinds, only: int8, int16, int32, int64, sp, dp, qp + + implicit none + private + public :: clip + + interface clip + module procedure clip_int8 + module procedure clip_int16 + module procedure clip_int32 + module procedure clip_int64 + module procedure clip_sp + module procedure clip_dp + module procedure clip_qp + end interface clip + +contains + + elemental function clip_int8(x, xmin, xmax) result(res) + integer(int8), intent(in) :: x + integer(int8), intent(in) :: xmin + integer(int8), intent(in) :: xmax + integer(int8) :: res + + res = max(min(x, xmax), xmin) + end function clip_int8 + + elemental function clip_int16(x, xmin, xmax) result(res) + integer(int16), intent(in) :: x + integer(int16), intent(in) :: xmin + integer(int16), intent(in) :: xmax + integer(int16) :: res + + res = max(min(x, xmax), xmin) + end function clip_int16 + + elemental function clip_int32(x, xmin, xmax) result(res) + integer(int32), intent(in) :: x + integer(int32), intent(in) :: xmin + integer(int32), intent(in) :: xmax + integer(int32) :: res + + res = max(min(x, xmax), xmin) + end function clip_int32 + + elemental function clip_int64(x, xmin, xmax) result(res) + integer(int64), intent(in) :: x + integer(int64), intent(in) :: xmin + integer(int64), intent(in) :: xmax + integer(int64) :: res + + res = max(min(x, xmax), xmin) + end function clip_int64 + + elemental function clip_sp(x, xmin, xmax) result(res) + real(sp), intent(in) :: x + real(sp), intent(in) :: xmin + real(sp), intent(in) :: xmax + real(sp) :: res + + res = max(min(x, xmax), xmin) + end function clip_sp + + elemental function clip_dp(x, xmin, xmax) result(res) + real(dp), intent(in) :: x + real(dp), intent(in) :: xmin + real(dp), intent(in) :: xmax + real(dp) :: res + + res = max(min(x, xmax), xmin) + end function clip_dp + + elemental function clip_qp(x, xmin, xmax) result(res) + real(qp), intent(in) :: x + real(qp), intent(in) :: xmin + real(qp), intent(in) :: xmax + real(qp) :: res + + res = max(min(x, xmax), xmin) + end function clip_qp + +end module stdlib_math diff --git a/src/fpm/stdlib_optval.f90 b/src/fpm/stdlib_optval.f90 new file mode 100644 index 000000000..1d0105bb3 --- /dev/null +++ b/src/fpm/stdlib_optval.f90 @@ -0,0 +1,182 @@ + + +module stdlib_optval + !! + !! Provides a generic function `optval`, which can be used to + !! conveniently implement fallback values for optional arguments + !! to subprograms + !! ([Specification](../page/specs/stdlib_optval.html)) + !! + !! If `x` is an `optional` parameter of a + !! subprogram, then the expression `optval(x, default)` inside that + !! subprogram evaluates to `x` if it is present, otherwise `default`. + !! + !! It is an error to call `optval` with a single actual argument. + !! + use stdlib_kinds, only: sp, dp, qp, int8, int16, int32, int64 + implicit none + + + private + public :: optval + + + interface optval + !! version: experimental + !! + !! Fallback value for optional arguments + !! ([Specification](../page/specs/stdlib_optval.html#description)) + module procedure optval_rsp + module procedure optval_rdp + module procedure optval_rqp + module procedure optval_iint8 + module procedure optval_iint16 + module procedure optval_iint32 + module procedure optval_iint64 + module procedure optval_csp + module procedure optval_cdp + module procedure optval_cqp + module procedure optval_ll1 + module procedure optval_character + ! TODO: differentiate ascii & ucs char kinds + end interface optval + + +contains + + pure elemental function optval_rsp(x, default) result(y) + real(sp), intent(in), optional :: x + real(sp), intent(in) :: default + real(sp) :: y + + if (present(x)) then + y = x + else + y = default + end if + end function optval_rsp + pure elemental function optval_rdp(x, default) result(y) + real(dp), intent(in), optional :: x + real(dp), intent(in) :: default + real(dp) :: y + + if (present(x)) then + y = x + else + y = default + end if + end function optval_rdp + pure elemental function optval_rqp(x, default) result(y) + real(qp), intent(in), optional :: x + real(qp), intent(in) :: default + real(qp) :: y + + if (present(x)) then + y = x + else + y = default + end if + end function optval_rqp + pure elemental function optval_iint8(x, default) result(y) + integer(int8), intent(in), optional :: x + integer(int8), intent(in) :: default + integer(int8) :: y + + if (present(x)) then + y = x + else + y = default + end if + end function optval_iint8 + pure elemental function optval_iint16(x, default) result(y) + integer(int16), intent(in), optional :: x + integer(int16), intent(in) :: default + integer(int16) :: y + + if (present(x)) then + y = x + else + y = default + end if + end function optval_iint16 + pure elemental function optval_iint32(x, default) result(y) + integer(int32), intent(in), optional :: x + integer(int32), intent(in) :: default + integer(int32) :: y + + if (present(x)) then + y = x + else + y = default + end if + end function optval_iint32 + pure elemental function optval_iint64(x, default) result(y) + integer(int64), intent(in), optional :: x + integer(int64), intent(in) :: default + integer(int64) :: y + + if (present(x)) then + y = x + else + y = default + end if + end function optval_iint64 + pure elemental function optval_csp(x, default) result(y) + complex(sp), intent(in), optional :: x + complex(sp), intent(in) :: default + complex(sp) :: y + + if (present(x)) then + y = x + else + y = default + end if + end function optval_csp + pure elemental function optval_cdp(x, default) result(y) + complex(dp), intent(in), optional :: x + complex(dp), intent(in) :: default + complex(dp) :: y + + if (present(x)) then + y = x + else + y = default + end if + end function optval_cdp + pure elemental function optval_cqp(x, default) result(y) + complex(qp), intent(in), optional :: x + complex(qp), intent(in) :: default + complex(qp) :: y + + if (present(x)) then + y = x + else + y = default + end if + end function optval_cqp + pure elemental function optval_ll1(x, default) result(y) + logical, intent(in), optional :: x + logical, intent(in) :: default + logical :: y + + if (present(x)) then + y = x + else + y = default + end if + end function optval_ll1 + + ! Cannot be made elemental + pure function optval_character(x, default) result(y) + character(len=*), intent(in), optional :: x + character(len=*), intent(in) :: default + character(len=:), allocatable :: y + + if (present(x)) then + y = x + else + y = default + end if + end function optval_character + +end module stdlib_optval diff --git a/src/fpm/stdlib_quadrature.f90 b/src/fpm/stdlib_quadrature.f90 new file mode 100644 index 000000000..54570ca08 --- /dev/null +++ b/src/fpm/stdlib_quadrature.f90 @@ -0,0 +1,163 @@ +module stdlib_quadrature + !! ([Specification](../page/specs/stdlib_quadrature.html#description)) + use stdlib_kinds, only: sp, dp, qp + + implicit none + + private + + ! array integration + public :: trapz + public :: trapz_weights + public :: simps + public :: simps_weights + + + interface trapz + !! version: experimental + !! + !! Integrates sampled values using trapezoidal rule + !! ([Specification](../page/specs/stdlib_quadrature.html#description)) + pure module function trapz_dx_sp(y, dx) result(integral) + real(sp), dimension(:), intent(in) :: y + real(sp), intent(in) :: dx + real(sp) :: integral + end function trapz_dx_sp + pure module function trapz_dx_dp(y, dx) result(integral) + real(dp), dimension(:), intent(in) :: y + real(dp), intent(in) :: dx + real(dp) :: integral + end function trapz_dx_dp + pure module function trapz_dx_qp(y, dx) result(integral) + real(qp), dimension(:), intent(in) :: y + real(qp), intent(in) :: dx + real(qp) :: integral + end function trapz_dx_qp + module function trapz_x_sp(y, x) result(integral) + real(sp), dimension(:), intent(in) :: y + real(sp), dimension(:), intent(in) :: x + real(sp) :: integral + end function trapz_x_sp + module function trapz_x_dp(y, x) result(integral) + real(dp), dimension(:), intent(in) :: y + real(dp), dimension(:), intent(in) :: x + real(dp) :: integral + end function trapz_x_dp + module function trapz_x_qp(y, x) result(integral) + real(qp), dimension(:), intent(in) :: y + real(qp), dimension(:), intent(in) :: x + real(qp) :: integral + end function trapz_x_qp + end interface trapz + + + interface trapz_weights + !! version: experimental + !! + !! Integrates sampled values using trapezoidal rule weights for given abscissas + !! ([Specification](../page/specs/stdlib_quadrature.html#description_1)) + pure module function trapz_weights_sp(x) result(w) + real(sp), dimension(:), intent(in) :: x + real(sp), dimension(size(x)) :: w + end function trapz_weights_sp + pure module function trapz_weights_dp(x) result(w) + real(dp), dimension(:), intent(in) :: x + real(dp), dimension(size(x)) :: w + end function trapz_weights_dp + pure module function trapz_weights_qp(x) result(w) + real(qp), dimension(:), intent(in) :: x + real(qp), dimension(size(x)) :: w + end function trapz_weights_qp + end interface trapz_weights + + + interface simps + !! version: experimental + !! + !! Integrates sampled values using Simpson's rule + !! ([Specification](../page/specs/stdlib_quadrature.html#description_3)) + ! "recursive" is an implementation detail + pure recursive module function simps_dx_sp(y, dx, even) result(integral) + real(sp), dimension(:), intent(in) :: y + real(sp), intent(in) :: dx + integer, intent(in), optional :: even + real(sp) :: integral + end function simps_dx_sp + pure recursive module function simps_dx_dp(y, dx, even) result(integral) + real(dp), dimension(:), intent(in) :: y + real(dp), intent(in) :: dx + integer, intent(in), optional :: even + real(dp) :: integral + end function simps_dx_dp + pure recursive module function simps_dx_qp(y, dx, even) result(integral) + real(qp), dimension(:), intent(in) :: y + real(qp), intent(in) :: dx + integer, intent(in), optional :: even + real(qp) :: integral + end function simps_dx_qp + recursive module function simps_x_sp(y, x, even) result(integral) + real(sp), dimension(:), intent(in) :: y + real(sp), dimension(:), intent(in) :: x + integer, intent(in), optional :: even + real(sp) :: integral + end function simps_x_sp + recursive module function simps_x_dp(y, x, even) result(integral) + real(dp), dimension(:), intent(in) :: y + real(dp), dimension(:), intent(in) :: x + integer, intent(in), optional :: even + real(dp) :: integral + end function simps_x_dp + recursive module function simps_x_qp(y, x, even) result(integral) + real(qp), dimension(:), intent(in) :: y + real(qp), dimension(:), intent(in) :: x + integer, intent(in), optional :: even + real(qp) :: integral + end function simps_x_qp + end interface simps + + + interface simps_weights + !! version: experimental + !! + !! Integrates sampled values using trapezoidal rule weights for given abscissas + !! ([Specification](../page/specs/stdlib_quadrature.html#description_3)) + pure recursive module function simps_weights_sp(x, even) result(w) + real(sp), dimension(:), intent(in) :: x + integer, intent(in), optional :: even + real(sp), dimension(size(x)) :: w + end function simps_weights_sp + pure recursive module function simps_weights_dp(x, even) result(w) + real(dp), dimension(:), intent(in) :: x + integer, intent(in), optional :: even + real(dp), dimension(size(x)) :: w + end function simps_weights_dp + pure recursive module function simps_weights_qp(x, even) result(w) + real(qp), dimension(:), intent(in) :: x + integer, intent(in), optional :: even + real(qp), dimension(size(x)) :: w + end function simps_weights_qp + end interface simps_weights + + + ! Interface for a simple f(x)-style integrand function. + ! Could become fancier as we learn about the performance + ! ramifications of different ways to do callbacks. + abstract interface + pure function integrand_sp(x) result(f) + import :: sp + real(sp), intent(in) :: x + real(sp) :: f + end function integrand_sp + pure function integrand_dp(x) result(f) + import :: dp + real(dp), intent(in) :: x + real(dp) :: f + end function integrand_dp + pure function integrand_qp(x) result(f) + import :: qp + real(qp), intent(in) :: x + real(qp) :: f + end function integrand_qp + end interface + +end module stdlib_quadrature diff --git a/src/fpm/stdlib_quadrature_simps.f90 b/src/fpm/stdlib_quadrature_simps.f90 new file mode 100644 index 000000000..dc0d651b1 --- /dev/null +++ b/src/fpm/stdlib_quadrature_simps.f90 @@ -0,0 +1,749 @@ + +submodule (stdlib_quadrature) stdlib_quadrature_simps + use stdlib_error, only: check + implicit none + + ! internal use only + interface simps38 + module procedure simps38_dx_sp + module procedure simps38_x_sp + module procedure simps38_dx_dp + module procedure simps38_x_dp + module procedure simps38_dx_qp + module procedure simps38_x_qp + end interface simps38 + + ! internal use only + interface simps38_weights + module procedure simps38_weights_sp + module procedure simps38_weights_dp + module procedure simps38_weights_qp + end interface simps38_weights + +contains + + + pure recursive module function simps_dx_sp(y, dx, even) result(integral) + real(sp), dimension(:), intent(in) :: y + real(sp), intent(in) :: dx + integer, intent(in), optional :: even + real(sp) :: integral + + integer :: n + + n = size(y) + + select case (n) + case (0:1) + integral = 0.0_sp + case (2) + integral = 0.5_sp*dx*(y(1) + y(2)) + case (3) + integral = dx/3.0_sp*(y(1) + 4*y(2) + y(3)) + case (4) + integral = simps38(y, dx) + ! case (5) not needed; handled by default + case (6) ! needs special handling because of averaged 3/8's rule case + if (present(even)) then + if (even < 0) then + ! 3/8 rule on left + integral = simps38(y(1:4), dx) + simps(y(4:6), dx) + return + else if (even > 0) then + ! 3/8 rule on right + integral = simps(y(1:3), dx) + simps38(y(3:6), dx) + return + else + ! fall through + end if + end if + ! either `even` not present or is zero + ! equivalent to averaging left and right + integral = dx/48.0_sp * (17*(y(1) + y(6)) + 59*(y(2) + y(5)) + 44*(y(3) + y(4))) + case default + if (mod(n, 2) == 1) then + integral = dx/3.0_sp*(y(1) + 4*sum(y(2:n-1:2)) + 2*sum(y(3:n-2:2)) + y(n)) + else + if (present(even)) then + if (even < 0) then + ! 3/8th rule on left + integral = simps38(y(1:4), dx) + simps(y(4:n), dx) + return + else if (even > 0) then + ! 3/8 rule on right + integral = simps(y(1:n-3), dx) + simps38(y(n-3:n), dx) + return + else + ! fall through + end if + end if + ! either `even` not present or is zero + ! equivalent to averaging left and right + integral = dx/48.0_sp * (17*(y(1) + y(n)) + 59*(y(2) + y(n-1)) & + + 43*(y(3) + y(n-2)) + 49*(y(4) + y(n-3)) + 48*sum(y(5:n-4))) + end if + end select + end function simps_dx_sp + + + pure recursive module function simps_dx_dp(y, dx, even) result(integral) + real(dp), dimension(:), intent(in) :: y + real(dp), intent(in) :: dx + integer, intent(in), optional :: even + real(dp) :: integral + + integer :: n + + n = size(y) + + select case (n) + case (0:1) + integral = 0.0_dp + case (2) + integral = 0.5_dp*dx*(y(1) + y(2)) + case (3) + integral = dx/3.0_dp*(y(1) + 4*y(2) + y(3)) + case (4) + integral = simps38(y, dx) + ! case (5) not needed; handled by default + case (6) ! needs special handling because of averaged 3/8's rule case + if (present(even)) then + if (even < 0) then + ! 3/8 rule on left + integral = simps38(y(1:4), dx) + simps(y(4:6), dx) + return + else if (even > 0) then + ! 3/8 rule on right + integral = simps(y(1:3), dx) + simps38(y(3:6), dx) + return + else + ! fall through + end if + end if + ! either `even` not present or is zero + ! equivalent to averaging left and right + integral = dx/48.0_dp * (17*(y(1) + y(6)) + 59*(y(2) + y(5)) + 44*(y(3) + y(4))) + case default + if (mod(n, 2) == 1) then + integral = dx/3.0_dp*(y(1) + 4*sum(y(2:n-1:2)) + 2*sum(y(3:n-2:2)) + y(n)) + else + if (present(even)) then + if (even < 0) then + ! 3/8th rule on left + integral = simps38(y(1:4), dx) + simps(y(4:n), dx) + return + else if (even > 0) then + ! 3/8 rule on right + integral = simps(y(1:n-3), dx) + simps38(y(n-3:n), dx) + return + else + ! fall through + end if + end if + ! either `even` not present or is zero + ! equivalent to averaging left and right + integral = dx/48.0_dp * (17*(y(1) + y(n)) + 59*(y(2) + y(n-1)) & + + 43*(y(3) + y(n-2)) + 49*(y(4) + y(n-3)) + 48*sum(y(5:n-4))) + end if + end select + end function simps_dx_dp + + + pure recursive module function simps_dx_qp(y, dx, even) result(integral) + real(qp), dimension(:), intent(in) :: y + real(qp), intent(in) :: dx + integer, intent(in), optional :: even + real(qp) :: integral + + integer :: n + + n = size(y) + + select case (n) + case (0:1) + integral = 0.0_qp + case (2) + integral = 0.5_qp*dx*(y(1) + y(2)) + case (3) + integral = dx/3.0_qp*(y(1) + 4*y(2) + y(3)) + case (4) + integral = simps38(y, dx) + ! case (5) not needed; handled by default + case (6) ! needs special handling because of averaged 3/8's rule case + if (present(even)) then + if (even < 0) then + ! 3/8 rule on left + integral = simps38(y(1:4), dx) + simps(y(4:6), dx) + return + else if (even > 0) then + ! 3/8 rule on right + integral = simps(y(1:3), dx) + simps38(y(3:6), dx) + return + else + ! fall through + end if + end if + ! either `even` not present or is zero + ! equivalent to averaging left and right + integral = dx/48.0_qp * (17*(y(1) + y(6)) + 59*(y(2) + y(5)) + 44*(y(3) + y(4))) + case default + if (mod(n, 2) == 1) then + integral = dx/3.0_qp*(y(1) + 4*sum(y(2:n-1:2)) + 2*sum(y(3:n-2:2)) + y(n)) + else + if (present(even)) then + if (even < 0) then + ! 3/8th rule on left + integral = simps38(y(1:4), dx) + simps(y(4:n), dx) + return + else if (even > 0) then + ! 3/8 rule on right + integral = simps(y(1:n-3), dx) + simps38(y(n-3:n), dx) + return + else + ! fall through + end if + end if + ! either `even` not present or is zero + ! equivalent to averaging left and right + integral = dx/48.0_qp * (17*(y(1) + y(n)) + 59*(y(2) + y(n-1)) & + + 43*(y(3) + y(n-2)) + 49*(y(4) + y(n-3)) + 48*sum(y(5:n-4))) + end if + end select + end function simps_dx_qp + + + recursive module function simps_x_sp(y, x, even) result(integral) + real(sp), dimension(:), intent(in) :: y + real(sp), dimension(:), intent(in) :: x + integer, intent(in), optional :: even + real(sp) :: integral + + integer :: i + integer :: n + + real(sp) :: h1, h2 + real(sp) :: a, b, c + + n = size(y) + call check(size(x) == n, "simps: Arguments `x` and `y` must be the same size.") + + select case (n) + case (0:1) + integral = 0.0_sp + case (2) + integral = 0.5_sp*(x(2) - x(1))*(y(1) + y(2)) + case (3) + h1 = x(2) - x(1) + h2 = x(3) - x(2) + a = (2*h1**2 + h1*h2 - h2**2)/(6*h1) + b = (h1+h2)**3/(6*h1*h2) + c = (2*h2**2 + h1*h2 - h1**2)/(6*h2) + integral = a*y(1) + b*y(2) + c*y(3) + case (4) + integral = simps38(y, x) + ! case (6) unneeded; handled by default + case default + if (mod(n, 2) == 1) then + integral = 0.0_sp + do i = 1, n-2, 2 + h1 = x(i+1) - x(i) + h2 = x(i+2) - x(i+1) + a = (2*h1**2 + h1*h2 - h2**2)/(6*h1) + b = (h1+h2)**3/(6*h1*h2) + c = (2*h2**2 + h1*h2 - h1**2)/(6*h2) + integral = integral + a*y(i) + b*y(i+1) + c*y(i+2) + end do + else + if (present(even)) then + if (even < 0) then + ! 3/8 rule on left + integral = simps38(y(1:4), x(1:4)) + simps(y(4:n), x(4:n)) + return + else if (even > 0) then + ! 3/8 rule on right + integral = simps(y(1:n-3), x(1:n-3)) + simps38(y(n-3:n), x(n-3:n)) + return + else + ! fall through + end if + end if + ! either `even` not present or is zero + integral = 0.5_sp * ( simps38(y(1:4), x(1:4)) + simps(y(4:n), x(4:n)) & + + simps(y(1:n-3), x(1:n-3)) + simps38(y(n-3:n), x(n-3:n)) ) + end if + end select + end function simps_x_sp + + + recursive module function simps_x_dp(y, x, even) result(integral) + real(dp), dimension(:), intent(in) :: y + real(dp), dimension(:), intent(in) :: x + integer, intent(in), optional :: even + real(dp) :: integral + + integer :: i + integer :: n + + real(dp) :: h1, h2 + real(dp) :: a, b, c + + n = size(y) + call check(size(x) == n, "simps: Arguments `x` and `y` must be the same size.") + + select case (n) + case (0:1) + integral = 0.0_dp + case (2) + integral = 0.5_dp*(x(2) - x(1))*(y(1) + y(2)) + case (3) + h1 = x(2) - x(1) + h2 = x(3) - x(2) + a = (2*h1**2 + h1*h2 - h2**2)/(6*h1) + b = (h1+h2)**3/(6*h1*h2) + c = (2*h2**2 + h1*h2 - h1**2)/(6*h2) + integral = a*y(1) + b*y(2) + c*y(3) + case (4) + integral = simps38(y, x) + ! case (6) unneeded; handled by default + case default + if (mod(n, 2) == 1) then + integral = 0.0_dp + do i = 1, n-2, 2 + h1 = x(i+1) - x(i) + h2 = x(i+2) - x(i+1) + a = (2*h1**2 + h1*h2 - h2**2)/(6*h1) + b = (h1+h2)**3/(6*h1*h2) + c = (2*h2**2 + h1*h2 - h1**2)/(6*h2) + integral = integral + a*y(i) + b*y(i+1) + c*y(i+2) + end do + else + if (present(even)) then + if (even < 0) then + ! 3/8 rule on left + integral = simps38(y(1:4), x(1:4)) + simps(y(4:n), x(4:n)) + return + else if (even > 0) then + ! 3/8 rule on right + integral = simps(y(1:n-3), x(1:n-3)) + simps38(y(n-3:n), x(n-3:n)) + return + else + ! fall through + end if + end if + ! either `even` not present or is zero + integral = 0.5_dp * ( simps38(y(1:4), x(1:4)) + simps(y(4:n), x(4:n)) & + + simps(y(1:n-3), x(1:n-3)) + simps38(y(n-3:n), x(n-3:n)) ) + end if + end select + end function simps_x_dp + + + recursive module function simps_x_qp(y, x, even) result(integral) + real(qp), dimension(:), intent(in) :: y + real(qp), dimension(:), intent(in) :: x + integer, intent(in), optional :: even + real(qp) :: integral + + integer :: i + integer :: n + + real(qp) :: h1, h2 + real(qp) :: a, b, c + + n = size(y) + call check(size(x) == n, "simps: Arguments `x` and `y` must be the same size.") + + select case (n) + case (0:1) + integral = 0.0_qp + case (2) + integral = 0.5_qp*(x(2) - x(1))*(y(1) + y(2)) + case (3) + h1 = x(2) - x(1) + h2 = x(3) - x(2) + a = (2*h1**2 + h1*h2 - h2**2)/(6*h1) + b = (h1+h2)**3/(6*h1*h2) + c = (2*h2**2 + h1*h2 - h1**2)/(6*h2) + integral = a*y(1) + b*y(2) + c*y(3) + case (4) + integral = simps38(y, x) + ! case (6) unneeded; handled by default + case default + if (mod(n, 2) == 1) then + integral = 0.0_qp + do i = 1, n-2, 2 + h1 = x(i+1) - x(i) + h2 = x(i+2) - x(i+1) + a = (2*h1**2 + h1*h2 - h2**2)/(6*h1) + b = (h1+h2)**3/(6*h1*h2) + c = (2*h2**2 + h1*h2 - h1**2)/(6*h2) + integral = integral + a*y(i) + b*y(i+1) + c*y(i+2) + end do + else + if (present(even)) then + if (even < 0) then + ! 3/8 rule on left + integral = simps38(y(1:4), x(1:4)) + simps(y(4:n), x(4:n)) + return + else if (even > 0) then + ! 3/8 rule on right + integral = simps(y(1:n-3), x(1:n-3)) + simps38(y(n-3:n), x(n-3:n)) + return + else + ! fall through + end if + end if + ! either `even` not present or is zero + integral = 0.5_qp * ( simps38(y(1:4), x(1:4)) + simps(y(4:n), x(4:n)) & + + simps(y(1:n-3), x(1:n-3)) + simps38(y(n-3:n), x(n-3:n)) ) + end if + end select + end function simps_x_qp + + + pure recursive module function simps_weights_sp(x, even) result(w) + real(sp), dimension(:), intent(in) :: x + integer, intent(in), optional :: even + real(sp), dimension(size(x)) :: w + + integer :: i, n + real(sp) :: h1, h2 + + n = size(x) + + select case (n) + case (0) + ! no action needed + case (1) + w(1) = 0.0_sp + case (2) + w = 0.5_sp*(x(2) - x(1)) + case (3) + h1 = x(2) - x(1) + h2 = x(3) - x(2) + w(1) = (2*h1**2 + h1*h2 - h2**2)/(6*h1) + w(2) = (h1+h2)**3/(6*h1*h2) + w(3) = (2*h2**2 + h1*h2 - h1**2)/(6*h2) + case (4) + w = simps38_weights(x) + case default + if (mod(n, 2) == 1) then + w = 0.0_sp + do i = 1, n-2, 2 + h1 = x(i+1) - x(i) + h2 = x(i+2) - x(i+1) + w(i) = w(i) + (2*h1**2 + h1*h2 - h2**2)/(6*h1) + w(i+1) = w(i+1) + (h1+h2)**3/(6*h1*h2) + w(i+2) = w(i+2) + (2*h2**2 + h1*h2 - h1**2)/(6*h2) + end do + else + if (present(even)) then + if (even < 0) then + ! 3/8 rule on left + w = 0.0_sp + w(1:4) = simps38_weights(x(1:4)) + w(4:n) = w(4:n) + simps_weights(x(4:n)) ! position 4 needs both rules + return + else if (even > 0) then + ! 3/8 rule on right + w = 0.0_sp + w(1:n-3) = simps_weights(x(1:n-3)) + w(n-3:n) = w(n-3:n) + simps38_weights(x(n-3:n)) ! position n-3 needs both rules + return + else + ! fall through + end if + end if + ! either `even` not present or is zero + w = 0.0_sp + ! 3/8 rule on left + w(1:4) = simps38_weights(x(1:4)) + w(4:n) = w(4:n) + simps_weights(x(4:n)) + ! 3/8 rule on right + w(1:n-3) = w(1:n-3) + simps_weights(x(1:n-3)) + w(n-3:n) = w(n-3:n) + simps38_weights(x(n-3:n)) + ! average + w = 0.5_sp * w + end if + end select + end function simps_weights_sp + + + pure recursive module function simps_weights_dp(x, even) result(w) + real(dp), dimension(:), intent(in) :: x + integer, intent(in), optional :: even + real(dp), dimension(size(x)) :: w + + integer :: i, n + real(dp) :: h1, h2 + + n = size(x) + + select case (n) + case (0) + ! no action needed + case (1) + w(1) = 0.0_dp + case (2) + w = 0.5_dp*(x(2) - x(1)) + case (3) + h1 = x(2) - x(1) + h2 = x(3) - x(2) + w(1) = (2*h1**2 + h1*h2 - h2**2)/(6*h1) + w(2) = (h1+h2)**3/(6*h1*h2) + w(3) = (2*h2**2 + h1*h2 - h1**2)/(6*h2) + case (4) + w = simps38_weights(x) + case default + if (mod(n, 2) == 1) then + w = 0.0_dp + do i = 1, n-2, 2 + h1 = x(i+1) - x(i) + h2 = x(i+2) - x(i+1) + w(i) = w(i) + (2*h1**2 + h1*h2 - h2**2)/(6*h1) + w(i+1) = w(i+1) + (h1+h2)**3/(6*h1*h2) + w(i+2) = w(i+2) + (2*h2**2 + h1*h2 - h1**2)/(6*h2) + end do + else + if (present(even)) then + if (even < 0) then + ! 3/8 rule on left + w = 0.0_dp + w(1:4) = simps38_weights(x(1:4)) + w(4:n) = w(4:n) + simps_weights(x(4:n)) ! position 4 needs both rules + return + else if (even > 0) then + ! 3/8 rule on right + w = 0.0_dp + w(1:n-3) = simps_weights(x(1:n-3)) + w(n-3:n) = w(n-3:n) + simps38_weights(x(n-3:n)) ! position n-3 needs both rules + return + else + ! fall through + end if + end if + ! either `even` not present or is zero + w = 0.0_dp + ! 3/8 rule on left + w(1:4) = simps38_weights(x(1:4)) + w(4:n) = w(4:n) + simps_weights(x(4:n)) + ! 3/8 rule on right + w(1:n-3) = w(1:n-3) + simps_weights(x(1:n-3)) + w(n-3:n) = w(n-3:n) + simps38_weights(x(n-3:n)) + ! average + w = 0.5_dp * w + end if + end select + end function simps_weights_dp + + + pure recursive module function simps_weights_qp(x, even) result(w) + real(qp), dimension(:), intent(in) :: x + integer, intent(in), optional :: even + real(qp), dimension(size(x)) :: w + + integer :: i, n + real(qp) :: h1, h2 + + n = size(x) + + select case (n) + case (0) + ! no action needed + case (1) + w(1) = 0.0_qp + case (2) + w = 0.5_qp*(x(2) - x(1)) + case (3) + h1 = x(2) - x(1) + h2 = x(3) - x(2) + w(1) = (2*h1**2 + h1*h2 - h2**2)/(6*h1) + w(2) = (h1+h2)**3/(6*h1*h2) + w(3) = (2*h2**2 + h1*h2 - h1**2)/(6*h2) + case (4) + w = simps38_weights(x) + case default + if (mod(n, 2) == 1) then + w = 0.0_qp + do i = 1, n-2, 2 + h1 = x(i+1) - x(i) + h2 = x(i+2) - x(i+1) + w(i) = w(i) + (2*h1**2 + h1*h2 - h2**2)/(6*h1) + w(i+1) = w(i+1) + (h1+h2)**3/(6*h1*h2) + w(i+2) = w(i+2) + (2*h2**2 + h1*h2 - h1**2)/(6*h2) + end do + else + if (present(even)) then + if (even < 0) then + ! 3/8 rule on left + w = 0.0_qp + w(1:4) = simps38_weights(x(1:4)) + w(4:n) = w(4:n) + simps_weights(x(4:n)) ! position 4 needs both rules + return + else if (even > 0) then + ! 3/8 rule on right + w = 0.0_qp + w(1:n-3) = simps_weights(x(1:n-3)) + w(n-3:n) = w(n-3:n) + simps38_weights(x(n-3:n)) ! position n-3 needs both rules + return + else + ! fall through + end if + end if + ! either `even` not present or is zero + w = 0.0_qp + ! 3/8 rule on left + w(1:4) = simps38_weights(x(1:4)) + w(4:n) = w(4:n) + simps_weights(x(4:n)) + ! 3/8 rule on right + w(1:n-3) = w(1:n-3) + simps_weights(x(1:n-3)) + w(n-3:n) = w(n-3:n) + simps38_weights(x(n-3:n)) + ! average + w = 0.5_qp * w + end if + end select + end function simps_weights_qp + + + pure function simps38_dx_sp(y, dx) result (integral) + real(sp), dimension(4), intent(in) :: y + real(sp), intent(in) :: dx + real(sp) :: integral + + integral = 3.0_sp*dx/8.0_sp * (y(1) + y(4) + 3*(y(2) + y(3))) + end function simps38_dx_sp + + + pure function simps38_dx_dp(y, dx) result (integral) + real(dp), dimension(4), intent(in) :: y + real(dp), intent(in) :: dx + real(dp) :: integral + + integral = 3.0_dp*dx/8.0_dp * (y(1) + y(4) + 3*(y(2) + y(3))) + end function simps38_dx_dp + + + pure function simps38_dx_qp(y, dx) result (integral) + real(qp), dimension(4), intent(in) :: y + real(qp), intent(in) :: dx + real(qp) :: integral + + integral = 3.0_qp*dx/8.0_qp * (y(1) + y(4) + 3*(y(2) + y(3))) + end function simps38_dx_qp + + + pure function simps38_x_sp(y, x) result(integral) + real(sp), dimension(4), intent(in) :: y + real(sp), dimension(4), intent(in) :: x + real(sp) :: integral + + real(sp) :: h1, h2, h3 + real(sp) :: a, b, c, d + + h1 = x(2) - x(1) + h2 = x(3) - x(2) + h3 = x(4) - x(3) + + a = (h1+h2+h3)*(3*h1**2 + 2*h1*h2 - 2*h1*h3 - h2**2 + h3**2)/(12*h1*(h1+h2)) + b = (h1+h2-h3)*(h1+h2+h3)**3/(12*h1*h2*(h2+h3)) + c = (h2+h3-h1)*(h1+h2+h3)**3/(12*h2*h3*(h1+h2)) + d = (h1+h2+h3)*(3*h3**2 + 2*h2*h3 - 2*h1*h3 - h2**2 + h1**2)/(12*h3*(h2+h3)) + + integral = a*y(1) + b*y(2) + c*y(3) + d*y(4) + end function simps38_x_sp + + + pure function simps38_x_dp(y, x) result(integral) + real(dp), dimension(4), intent(in) :: y + real(dp), dimension(4), intent(in) :: x + real(dp) :: integral + + real(dp) :: h1, h2, h3 + real(dp) :: a, b, c, d + + h1 = x(2) - x(1) + h2 = x(3) - x(2) + h3 = x(4) - x(3) + + a = (h1+h2+h3)*(3*h1**2 + 2*h1*h2 - 2*h1*h3 - h2**2 + h3**2)/(12*h1*(h1+h2)) + b = (h1+h2-h3)*(h1+h2+h3)**3/(12*h1*h2*(h2+h3)) + c = (h2+h3-h1)*(h1+h2+h3)**3/(12*h2*h3*(h1+h2)) + d = (h1+h2+h3)*(3*h3**2 + 2*h2*h3 - 2*h1*h3 - h2**2 + h1**2)/(12*h3*(h2+h3)) + + integral = a*y(1) + b*y(2) + c*y(3) + d*y(4) + end function simps38_x_dp + + + pure function simps38_x_qp(y, x) result(integral) + real(qp), dimension(4), intent(in) :: y + real(qp), dimension(4), intent(in) :: x + real(qp) :: integral + + real(qp) :: h1, h2, h3 + real(qp) :: a, b, c, d + + h1 = x(2) - x(1) + h2 = x(3) - x(2) + h3 = x(4) - x(3) + + a = (h1+h2+h3)*(3*h1**2 + 2*h1*h2 - 2*h1*h3 - h2**2 + h3**2)/(12*h1*(h1+h2)) + b = (h1+h2-h3)*(h1+h2+h3)**3/(12*h1*h2*(h2+h3)) + c = (h2+h3-h1)*(h1+h2+h3)**3/(12*h2*h3*(h1+h2)) + d = (h1+h2+h3)*(3*h3**2 + 2*h2*h3 - 2*h1*h3 - h2**2 + h1**2)/(12*h3*(h2+h3)) + + integral = a*y(1) + b*y(2) + c*y(3) + d*y(4) + end function simps38_x_qp + + + pure function simps38_weights_sp(x) result(w) + real(sp), intent(in) :: x(4) + real(sp) :: w(size(x)) + + real(sp) :: h1, h2, h3 + + h1 = x(2) - x(1) + h2 = x(3) - x(2) + h3 = x(4) - x(3) + + w(1) = (h1+h2+h3)*(3*h1**2 + 2*h1*h2 - 2*h1*h3 - h2**2 + h3**2)/(12*h1*(h1+h2)) + w(2) = (h1+h2-h3)*(h1+h2+h3)**3/(12*h1*h2*(h2+h3)) + w(3) = (h2+h3-h1)*(h1+h2+h3)**3/(12*h2*h3*(h1+h2)) + w(4) = (h1+h2+h3)*(3*h3**2 + 2*h2*h3 - 2*h1*h3 - h2**2 + h1**2)/(12*h3*(h2+h3)) + end function simps38_weights_sp + + + pure function simps38_weights_dp(x) result(w) + real(dp), intent(in) :: x(4) + real(dp) :: w(size(x)) + + real(dp) :: h1, h2, h3 + + h1 = x(2) - x(1) + h2 = x(3) - x(2) + h3 = x(4) - x(3) + + w(1) = (h1+h2+h3)*(3*h1**2 + 2*h1*h2 - 2*h1*h3 - h2**2 + h3**2)/(12*h1*(h1+h2)) + w(2) = (h1+h2-h3)*(h1+h2+h3)**3/(12*h1*h2*(h2+h3)) + w(3) = (h2+h3-h1)*(h1+h2+h3)**3/(12*h2*h3*(h1+h2)) + w(4) = (h1+h2+h3)*(3*h3**2 + 2*h2*h3 - 2*h1*h3 - h2**2 + h1**2)/(12*h3*(h2+h3)) + end function simps38_weights_dp + + + pure function simps38_weights_qp(x) result(w) + real(qp), intent(in) :: x(4) + real(qp) :: w(size(x)) + + real(qp) :: h1, h2, h3 + + h1 = x(2) - x(1) + h2 = x(3) - x(2) + h3 = x(4) - x(3) + + w(1) = (h1+h2+h3)*(3*h1**2 + 2*h1*h2 - 2*h1*h3 - h2**2 + h3**2)/(12*h1*(h1+h2)) + w(2) = (h1+h2-h3)*(h1+h2+h3)**3/(12*h1*h2*(h2+h3)) + w(3) = (h2+h3-h1)*(h1+h2+h3)**3/(12*h2*h3*(h1+h2)) + w(4) = (h1+h2+h3)*(3*h3**2 + 2*h2*h3 - 2*h1*h3 - h2**2 + h1**2)/(12*h3*(h2+h3)) + end function simps38_weights_qp + + +end submodule stdlib_quadrature_simps diff --git a/src/fpm/stdlib_quadrature_trapz.f90 b/src/fpm/stdlib_quadrature_trapz.f90 new file mode 100644 index 000000000..17bbbc9e5 --- /dev/null +++ b/src/fpm/stdlib_quadrature_trapz.f90 @@ -0,0 +1,224 @@ + +submodule (stdlib_quadrature) stdlib_quadrature_trapz + use stdlib_error, only: check + implicit none + +contains + + + pure module function trapz_dx_sp(y, dx) result(integral) + real(sp), dimension(:), intent(in) :: y + real(sp), intent(in) :: dx + real(sp) :: integral + + integer :: n + + n = size(y) + + select case (n) + case (0:1) + integral = 0.0_sp + case (2) + integral = 0.5_sp*dx*(y(1) + y(2)) + case default + integral = dx*(sum(y(2:n-1)) + 0.5_sp*(y(1) + y(n))) + end select + end function trapz_dx_sp + + + pure module function trapz_dx_dp(y, dx) result(integral) + real(dp), dimension(:), intent(in) :: y + real(dp), intent(in) :: dx + real(dp) :: integral + + integer :: n + + n = size(y) + + select case (n) + case (0:1) + integral = 0.0_dp + case (2) + integral = 0.5_dp*dx*(y(1) + y(2)) + case default + integral = dx*(sum(y(2:n-1)) + 0.5_dp*(y(1) + y(n))) + end select + end function trapz_dx_dp + + + pure module function trapz_dx_qp(y, dx) result(integral) + real(qp), dimension(:), intent(in) :: y + real(qp), intent(in) :: dx + real(qp) :: integral + + integer :: n + + n = size(y) + + select case (n) + case (0:1) + integral = 0.0_qp + case (2) + integral = 0.5_qp*dx*(y(1) + y(2)) + case default + integral = dx*(sum(y(2:n-1)) + 0.5_qp*(y(1) + y(n))) + end select + end function trapz_dx_qp + + + module function trapz_x_sp(y, x) result(integral) + real(sp), dimension(:), intent(in) :: y + real(sp), dimension(:), intent(in) :: x + real(sp) :: integral + + integer :: i + integer :: n + + n = size(y) + call check(size(x) == n, "trapz: Arguments `x` and `y` must be the same size.") + + select case (n) + case (0:1) + integral = 0.0_sp + case (2) + integral = 0.5_sp*(x(2) - x(1))*(y(1) + y(2)) + case default + integral = 0.0_sp + do i = 2, n + integral = integral + (x(i) - x(i-1))*(y(i) + y(i-1)) + end do + integral = 0.5_sp*integral + end select + end function trapz_x_sp + + + module function trapz_x_dp(y, x) result(integral) + real(dp), dimension(:), intent(in) :: y + real(dp), dimension(:), intent(in) :: x + real(dp) :: integral + + integer :: i + integer :: n + + n = size(y) + call check(size(x) == n, "trapz: Arguments `x` and `y` must be the same size.") + + select case (n) + case (0:1) + integral = 0.0_dp + case (2) + integral = 0.5_dp*(x(2) - x(1))*(y(1) + y(2)) + case default + integral = 0.0_dp + do i = 2, n + integral = integral + (x(i) - x(i-1))*(y(i) + y(i-1)) + end do + integral = 0.5_dp*integral + end select + end function trapz_x_dp + + + module function trapz_x_qp(y, x) result(integral) + real(qp), dimension(:), intent(in) :: y + real(qp), dimension(:), intent(in) :: x + real(qp) :: integral + + integer :: i + integer :: n + + n = size(y) + call check(size(x) == n, "trapz: Arguments `x` and `y` must be the same size.") + + select case (n) + case (0:1) + integral = 0.0_qp + case (2) + integral = 0.5_qp*(x(2) - x(1))*(y(1) + y(2)) + case default + integral = 0.0_qp + do i = 2, n + integral = integral + (x(i) - x(i-1))*(y(i) + y(i-1)) + end do + integral = 0.5_qp*integral + end select + end function trapz_x_qp + + + pure module function trapz_weights_sp(x) result(w) + real(sp), dimension(:), intent(in) :: x + real(sp), dimension(size(x)) :: w + + integer :: i + integer :: n + + n = size(x) + + select case (n) + case (0) + ! no action needed + case (1) + w(1) = 0.0_sp + case (2) + w = 0.5_sp*(x(2) - x(1)) + case default + w(1) = 0.5_sp*(x(2) - x(1)) + w(n) = 0.5_sp*(x(n) - x(n-1)) + do i = 2, size(x)-1 + w(i) = 0.5_sp*(x(i+1) - x(i-1)) + end do + end select + end function trapz_weights_sp + + + pure module function trapz_weights_dp(x) result(w) + real(dp), dimension(:), intent(in) :: x + real(dp), dimension(size(x)) :: w + + integer :: i + integer :: n + + n = size(x) + + select case (n) + case (0) + ! no action needed + case (1) + w(1) = 0.0_dp + case (2) + w = 0.5_dp*(x(2) - x(1)) + case default + w(1) = 0.5_dp*(x(2) - x(1)) + w(n) = 0.5_dp*(x(n) - x(n-1)) + do i = 2, size(x)-1 + w(i) = 0.5_dp*(x(i+1) - x(i-1)) + end do + end select + end function trapz_weights_dp + + + pure module function trapz_weights_qp(x) result(w) + real(qp), dimension(:), intent(in) :: x + real(qp), dimension(size(x)) :: w + + integer :: i + integer :: n + + n = size(x) + + select case (n) + case (0) + ! no action needed + case (1) + w(1) = 0.0_qp + case (2) + w = 0.5_qp*(x(2) - x(1)) + case default + w(1) = 0.5_qp*(x(2) - x(1)) + w(n) = 0.5_qp*(x(n) - x(n-1)) + do i = 2, size(x)-1 + w(i) = 0.5_qp*(x(i+1) - x(i-1)) + end do + end select + end function trapz_weights_qp + +end submodule stdlib_quadrature_trapz diff --git a/src/fpm/stdlib_sorting.f90 b/src/fpm/stdlib_sorting.f90 new file mode 100644 index 000000000..9f2ad6ed3 --- /dev/null +++ b/src/fpm/stdlib_sorting.f90 @@ -0,0 +1,727 @@ + +!! Licensing: +!! +!! This file is subject both to the Fortran Standard Library license, and +!! to additional licensing requirements as it contains translations of +!! other software. +!! +!! The Fortran Standard Library, including this file, is distributed under +!! the MIT license that should be included with the library's distribution. +!! +!! Copyright (c) 2021 Fortran stdlib developers +!! +!! Permission is hereby granted, free of charge, to any person obtaining a +!! copy of this software and associated documentation files (the +!! "Software"), to deal in the Software without restriction, including +!! without limitation the rights to use, copy, modify, merge, publish, +!! distribute, sublicense, and/or sellcopies of the Software, and to permit +!! persons to whom the Software is furnished to do so, subject to the +!! following conditions: +!! +!! The above copyright notice and this permission notice shall be included +!! in all copies or substantial portions of the Software. +!! +!! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS +!! OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +!! MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +!! IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +!! CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +!! TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +!! SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +!! +!! Two of the generic subroutines, `ORD_SORT` and `SORT_INDEX`, are +!! substantially translations to Fortran 2008 of the `"Rust" sort` sorting +!! routines in +!! [`slice.rs`](https://github.com/rust-lang/rust/blob/90eb44a5897c39e3dff9c7e48e3973671dcd9496/src/liballoc/slice.rs) +!! The `rust sort` implementation is distributed with the header: +!! +!! Copyright 2012-2015 The Rust Project Developers. See the COPYRIGHT +!! file at the top-level directory of this distribution and at +!! http://rust-lang.org/COPYRIGHT. +!! +!! Licensed under the Apache License, Version 2.0 or the MIT license +!! , at your +!! option. This file may not be copied, modified, or distributed +!! except according to those terms. +!! +!! so the license for the original`slice.rs` code is compatible with the use +!! of modified versions of the code in the Fortran Standard Library under +!! the MIT license. +!! +!! One of the generic subroutines, `SORT`, is substantially a +!! translation to Fortran 2008, of the `introsort` of David Musser. +!! David Musser has given permission to include a variant of `introsort` +!! in the Fortran Standard Library under the MIT license provided +!! we cite: +!! +!! Musser, D.R., “Introspective Sorting and Selection Algorithms,” +!! Software—Practice and Experience, Vol. 27(8), 983–993 (August 1997). +!! +!! as the official source of the algorithm. + +module stdlib_sorting +!! This module implements overloaded sorting subroutines named `ORD_SORT`, +!! `SORT_INDEX`, and `SORT`, that each can be used to sort four kinds +!! of `INTEGER` arrays, three kinds of `REAL` arrays, `character(len=*)` arrays, +!! and arrays of `type(string_type)`. +!! ([Specification](../page/specs/stdlib_sorting.html)) +!! +!! By default sorting is in order of +!! increasing value, but there is an option to sort in decreasing order. +!! All the subroutines have worst case run time performance of `O(N Ln(N))`, +!! but on largely sorted data `ORD_SORT` and `SORT_INDEX` can have a run time +!! performance of `O(N)`. +!! +!! `ORD_SORT` is a translation of the `"Rust" sort` sorting algorithm in +!! `slice.rs`: +!! https://github.com/rust-lang/rust/blob/90eb44a5897c39e3dff9c7e48e3973671dcd9496/src/liballoc/slice.rs +!! which in turn is inspired by the `timsort` algorithm of Tim Peters, +!! http://svn.python.org/projects/python/trunk/Objects/listsort.txt. +!! `ORD_SORT` is a hybrid stable comparison algorithm combining `merge sort`, +!! and `insertion sort`. It is always at worst O(N Ln(N)) in sorting random +!! data, having a performance about 25% slower than `SORT` on such +!! data, but has much better performance than `SORT` on partially +!! sorted data, having O(N) performance on uniformly non-increasing or +!! non-decreasing data. +!! +!! `SORT_INDEX` is a modification of `ORD_SORT` so that in addition to +!! sorting the input array, it returns the indices that map to a +!! stable sort of the original array. These indices are +!! intended to be used to sort data that is correlated with the input +!! array, e.g., different arrays in a database, different columns of a +!! rank 2 array, different elements of a derived type. It is less +!! efficient than `ORD_SORT` at sorting a simple array. +!! +!! `SORT` uses the `INTROSORT` sorting algorithm of David Musser, +!! http://www.cs.rpi.edu/~musser/gp/introsort.ps. `introsort` is a hybrid +!! unstable comparison algorithm combining `quicksort`, `insertion sort`, and +!! `heap sort`. While this algorithm is always O(N Ln(N)) it is relatively +!! fast on randomly ordered data, but inconsistent in performance on partly +!! sorted data, sometimes having `merge sort` performance, sometimes having +!! better than `quicksort` performance. `UNORD_SOORT` is about 25% +!! more efficient than `ORD_SORT` at sorting purely random data, but af an +!! order of `Ln(N)` less efficient at sorting partially sorted data. + + use stdlib_kinds, only: & + int8, & + int16, & + int32, & + int64, & + sp, & + dp, & + qp + + use stdlib_string_type, only: string_type, assignment(=), operator(>), & + operator(>=), operator(<), operator(<=) + + implicit none + private + + integer, parameter, public :: int_size = int64 !! Integer kind for indexing + +! Constants for use by tim_sort + integer, parameter :: & +! The maximum number of entries in a run stack, good for an array of +! 2**64 elements see +! https://svn.python.org/projects/python/trunk/Objects/listsort.txt + max_merge_stack = int( ceiling( log( 2._dp**64 ) / & + log(1.6180339887_dp) ) ) + + type run_type +!! Version: experimental +!! +!! Used to pass state around in a stack among helper functions for the +!! `ORD_SORT` and `SORT_INDEX` algorithms + integer(int_size) :: base = 0 + integer(int_size) :: len = 0 + end type run_type + + public ord_sort +!! Version: experimental +!! +!! The generic subroutine implementing the `ORD_SORT` algorithm to return +!! an input array with its elements sorted in order of (non-)decreasing +!! value. Its use has the syntax: +!! +!! call ord_sort( array[, work, reverse] ) +!! +!! with the arguments: +!! +!! * array: the rank 1 array to be sorted. It is an `intent(inout)` +!! argument of any of the types `integer(int8)`, `integer(int16)`, +!! `integer(int32)`, `integer(int64)`, `real(real32)`, `real(real64)`, +!! `real(real128)`, `character(*)`, `type(string_type)`. If both the +!! type of `array` is real and at least one of the elements is a +!! `NaN`, then the ordering of the result is undefined. Otherwise it +!! is defined to be the original elements in non-decreasing order. +!! +!! * work (optional): shall be a rank 1 array of the same type as +!! `array`, and shall have at least `size(array)/2` elements. It is an +!! `intent(out)` argument to be used as "scratch" memory +!! for internal record keeping. If associated with an array in static +!! storage, its use can significantly reduce the stack memory requirements +!! for the code. Its value on return is undefined. +!! +!! * `reverse` (optional): shall be a scalar of type default logical. It +!! is an `intent(in)` argument. If present with a value of `.true.` then +!! `array` will be sorted in order of non-increasing values in stable +!! order. Otherwise index will sort `array` in order of non-decreasing +!! values in stable order. +!! +!!#### Example +!! +!!```fortran +!! ... +!! ! Read arrays from sorted files +!! call read_sorted_file( 'dummy_file1', array1 ) +!! call read_sorted_file( 'dummy_file2', array2 ) +!! ! Concatenate the arrays +!! allocate( array( size(array1) + size(array2) ) ) +!! array( 1:size(array1) ) = array1(:) +!! array( size(array1)+1:size(array1)+size(array2) ) = array2(:) +!! ! Sort the resulting array +!! call ord_sort( array, work ) +!! ! Process the sorted array +!! call array_search( array, values ) +!! ... +!!``` + + public sort +!! Version: experimental +!! +!! The generic subroutine implementing the `SORT` algorithm to return +!! an input array with its elements sorted in order of (non-)decreasing +!! value. Its use has the syntax: +!! +!! call sort( array[, reverse] ) +!! +!! with the arguments: +!! +!! * array: the rank 1 array to be sorted. It is an `intent(inout)` +!! argument of any of the types `integer(int8)`, `integer(int16)`, +!! `integer(int32)`, `integer(int64)`, `real(real32)`, `real(real64)`, +!! `real(real128)`, `character(*)`, `type(string_type)`. If both the type +!! of `array` is real and at least one of the elements is a `NaN`, then +!! the ordering of the result is undefined. Otherwise it is defined to be the +!! original elements in non-decreasing order. +!! * `reverse` (optional): shall be a scalar of type default logical. It +!! is an `intent(in)` argument. If present with a value of `.true.` then +!! `array` will be sorted in order of non-increasing values in unstable +!! order. Otherwise index will sort `array` in order of non-decreasing +!! values in unstable order. +!! +!!#### Example +!! +!!```fortran +!! ... +!! ! Read random data from a file +!! call read_file( 'dummy_file', array ) +!! ! Sort the random data +!! call sort( array ) +!! ! Process the sorted data +!! call array_search( array, values ) +!! ... +!!``` + + public sort_index +!! Version: experimental +!! +!! The generic subroutine implementing the `SORT_INDEX` algorithm to +!! return an index array whose elements would sort the input array in the +!! desired direction. It is primarily intended to be used to sort a +!! derived type array based on the values of a component of the array. +!! Its use has the syntax: +!! +!! call sort_index( array, index[, work, iwork, reverse ] ) +!! +!! with the arguments: +!! +!! * array: the rank 1 array to be sorted. It is an `intent(inout)` +!! argument of any of the types `integer(int8)`, `integer(int16)`, +!! `integer(int32)`, `integer(int64)`, `real(real32)`, `real(real64)`, +!! `real(real128)`, `character(*)`, `type(string_type)`. If both the +!! type of `array` is real and at least one of the elements is a `NaN`, +!! then the ordering of the `array` and `index` results is undefined. +!! Otherwise it is defined to be as specified by reverse. +!! +!! * index: a rank 1 array of sorting indices. It is an `intent(out)` +!! argument of the type `integer(int_size)`. Its size shall be the +!! same as `array`. On return, if defined, its elements would +!! sort the input `array` in the direction specified by `reverse`. +!! +!! * work (optional): shall be a rank 1 array of the same type as +!! `array`, and shall have at least `size(array)/2` elements. It is an +!! `intent(out)` argument to be used as "scratch" memory +!! for internal record keeping. If associated with an array in static +!! storage, its use can significantly reduce the stack memory requirements +!! for the code. Its value on return is undefined. +!! +!! * iwork (optional): shall be a rank 1 integer array of kind `int_size`, +!! and shall have at least `size(array)/2` elements. It is an +!! `intent(out)` argument to be used as "scratch" memory +!! for internal record keeping. If associated with an array in static +!! storage, its use can significantly reduce the stack memory requirements +!! for the code. Its value on return is undefined. +!! +!! * `reverse` (optional): shall be a scalar of type default logical. It +!! is an `intent(in)` argument. If present with a value of `.true.` then +!! `index` will sort `array` in order of non-increasing values in stable +!! order. Otherwise index will sort `array` in order of non-decreasing +!! values in stable order. +!! +!!#### Examples +!! +!! Sorting a related rank one array: +!! +!!```Fortran +!! subroutine sort_related_data( a, b, work, index, iwork ) +!! ! Sort `b` in terms or its related array `a` +!! integer, intent(inout) :: a(:) +!! integer(int32), intent(inout) :: b(:) ! The same size as a +!! integer(int32), intent(out) :: work(:) +!! integer(int_size), intent(out) :: index(:) +!! integer(int_size), intent(out) :: iwork(:) +!! ! Find the indices to sort a +!! call sort_index(a, index(1:size(a)),& +!! work(1:size(a)/2), iwork(1:size(a)/2)) +!! ! Sort b based on the sorting of a +!! b(:) = b( index(1:size(a)) ) +!! end subroutine sort_related_data +!!``` +!! +!! Sorting a rank 2 array based on the data in a column +!! +!!```Fortran +!! subroutine sort_related_data( array, column, work, index, iwork ) +!! ! Sort `a_data` in terms or its component `a` +!! integer, intent(inout) :: a(:,:) +!! integer(int32), intent(in) :: column +!! integer(int32), intent(out) :: work(:) +!! integer(int_size), intent(out) :: index(:) +!! integer(int_size), intent(out) :: iwork(:) +!! integer, allocatable :: dummy(:) +!! integer :: i +!! allocate(dummy(size(a, dim=1))) +!! ! Extract a component of `a_data` +!! dummy(:) = a(:, column) +!! ! Find the indices to sort the column +!! call sort_index(dummy, index(1:size(dummy)),& +!! work(1:size(dummy)/2), iwork(1:size(dummy)/2)) +!! ! Sort a based on the sorting of its column +!! do i=1, size(a, dim=2) +!! a(:, i) = a(index(1:size(a, dim=1)), i) +!! end do +!! end subroutine sort_related_data +!!``` +!! +!! Sorting an array of a derived type based on the dsta in one component +!!```fortran +!! subroutine sort_a_data( a_data, a, work, index, iwork ) +!! ! Sort `a_data` in terms or its component `a` +!! type(a_type), intent(inout) :: a_data(:) +!! integer(int32), intent(inout) :: a(:) +!! integer(int32), intent(out) :: work(:) +!! integer(int_size), intent(out) :: index(:) +!! integer(int_size), intent(out) :: iwork(:) +!! ! Extract a component of `a_data` +!! a(1:size(a_data)) = a_data(:) % a +!! ! Find the indices to sort the component +!! call sort_index(a(1:size(a_data)), index(1:size(a_data)),& +!! work(1:size(a_data)/2), iwork(1:size(a_data)/2)) +!! ! Sort a_data based on the sorting of that component +!! a_data(:) = a_data( index(1:size(a_data)) ) +!! end subroutine sort_a_data +!!``` + + interface ord_sort +!! Version: experimental +!! +!! The generic subroutine interface implementing the `ORD_SORT` algorithm, +!! a translation to Fortran 2008, of the `"Rust" sort` algorithm found in +!! `slice.rs` +!! https://github.com/rust-lang/rust/blob/90eb44a5897c39e3dff9c7e48e3973671dcd9496/src/liballoc/slice.rs#L2159 +!! `ORD_SORT` is a hybrid stable comparison algorithm combining `merge sort`, +!! and `insertion sort`. +!! ([Specification](../page/specs/stdlib_sorting.html#ord_sort-sorts-an-input-array)) +!! +!! It is always at worst O(N Ln(N)) in sorting random +!! data, having a performance about 25% slower than `SORT` on such +!! data, but has much better performance than `SORT` on partially +!! sorted data, having O(N) performance on uniformly non-increasing or +!! non-decreasing data. + + module subroutine int8_ord_sort( array, work, reverse ) +!! Version: experimental +!! +!! `int8_ord_sort( array )` sorts the input `ARRAY` of type `integer(int8)` +!! using a hybrid sort based on the `'Rust" sort` algorithm found in `slice.rs` + integer(int8), intent(inout) :: array(0:) + integer(int8), intent(out), optional :: work(0:) + logical, intent(in), optional :: reverse + end subroutine int8_ord_sort + + module subroutine int16_ord_sort( array, work, reverse ) +!! Version: experimental +!! +!! `int16_ord_sort( array )` sorts the input `ARRAY` of type `integer(int16)` +!! using a hybrid sort based on the `'Rust" sort` algorithm found in `slice.rs` + integer(int16), intent(inout) :: array(0:) + integer(int16), intent(out), optional :: work(0:) + logical, intent(in), optional :: reverse + end subroutine int16_ord_sort + + module subroutine int32_ord_sort( array, work, reverse ) +!! Version: experimental +!! +!! `int32_ord_sort( array )` sorts the input `ARRAY` of type `integer(int32)` +!! using a hybrid sort based on the `'Rust" sort` algorithm found in `slice.rs` + integer(int32), intent(inout) :: array(0:) + integer(int32), intent(out), optional :: work(0:) + logical, intent(in), optional :: reverse + end subroutine int32_ord_sort + + module subroutine int64_ord_sort( array, work, reverse ) +!! Version: experimental +!! +!! `int64_ord_sort( array )` sorts the input `ARRAY` of type `integer(int64)` +!! using a hybrid sort based on the `'Rust" sort` algorithm found in `slice.rs` + integer(int64), intent(inout) :: array(0:) + integer(int64), intent(out), optional :: work(0:) + logical, intent(in), optional :: reverse + end subroutine int64_ord_sort + + module subroutine sp_ord_sort( array, work, reverse ) +!! Version: experimental +!! +!! `sp_ord_sort( array )` sorts the input `ARRAY` of type `real(sp)` +!! using a hybrid sort based on the `'Rust" sort` algorithm found in `slice.rs` + real(sp), intent(inout) :: array(0:) + real(sp), intent(out), optional :: work(0:) + logical, intent(in), optional :: reverse + end subroutine sp_ord_sort + + module subroutine dp_ord_sort( array, work, reverse ) +!! Version: experimental +!! +!! `dp_ord_sort( array )` sorts the input `ARRAY` of type `real(dp)` +!! using a hybrid sort based on the `'Rust" sort` algorithm found in `slice.rs` + real(dp), intent(inout) :: array(0:) + real(dp), intent(out), optional :: work(0:) + logical, intent(in), optional :: reverse + end subroutine dp_ord_sort + + module subroutine qp_ord_sort( array, work, reverse ) +!! Version: experimental +!! +!! `qp_ord_sort( array )` sorts the input `ARRAY` of type `real(qp)` +!! using a hybrid sort based on the `'Rust" sort` algorithm found in `slice.rs` + real(qp), intent(inout) :: array(0:) + real(qp), intent(out), optional :: work(0:) + logical, intent(in), optional :: reverse + end subroutine qp_ord_sort + + module subroutine string_type_ord_sort( array, work, reverse ) +!! Version: experimental +!! +!! `string_type_ord_sort( array )` sorts the input `ARRAY` of type `type(string_type)` +!! using a hybrid sort based on the `'Rust" sort` algorithm found in `slice.rs` + type(string_type), intent(inout) :: array(0:) + type(string_type), intent(out), optional :: work(0:) + logical, intent(in), optional :: reverse + end subroutine string_type_ord_sort + + + module subroutine char_ord_sort( array, work, reverse ) +!! Version: experimental +!! +!! `char_ord_sort( array[, work, reverse] )` sorts the input `ARRAY` of type `CHARACTER(*)` +!! using a hybrid sort based on the `'Rust" sort` algorithm found in `slice.rs` + character(len=*), intent(inout) :: array(0:) + character(len=len(array)), intent(out), optional :: work(0:) + logical, intent(in), optional :: reverse + end subroutine char_ord_sort + + end interface ord_sort + + interface sort +!! Version: experimental +!! +!! The generic subroutine interface implementing the `SORT` algorithm, based +!! on the `introsort` of David Musser. +!! ([Specification](../page/specs/stdlib_sorting.html#sort-sorts-an-input-array)) + + pure module subroutine int8_sort( array, reverse ) +!! Version: experimental +!! +!! `int8_sort( array[, reverse] )` sorts the input `ARRAY` of type `integer(int8)` +!! using a hybrid sort based on the `introsort` of David Musser. +!! The algorithm is of order O(N Ln(N)) for all inputs. +!! Because it relies on `quicksort`, the coefficient of the O(N Ln(N)) +!! behavior is small for random data compared to other sorting algorithms. + integer(int8), intent(inout) :: array(0:) + logical, intent(in), optional :: reverse + end subroutine int8_sort + + pure module subroutine int16_sort( array, reverse ) +!! Version: experimental +!! +!! `int16_sort( array[, reverse] )` sorts the input `ARRAY` of type `integer(int16)` +!! using a hybrid sort based on the `introsort` of David Musser. +!! The algorithm is of order O(N Ln(N)) for all inputs. +!! Because it relies on `quicksort`, the coefficient of the O(N Ln(N)) +!! behavior is small for random data compared to other sorting algorithms. + integer(int16), intent(inout) :: array(0:) + logical, intent(in), optional :: reverse + end subroutine int16_sort + + pure module subroutine int32_sort( array, reverse ) +!! Version: experimental +!! +!! `int32_sort( array[, reverse] )` sorts the input `ARRAY` of type `integer(int32)` +!! using a hybrid sort based on the `introsort` of David Musser. +!! The algorithm is of order O(N Ln(N)) for all inputs. +!! Because it relies on `quicksort`, the coefficient of the O(N Ln(N)) +!! behavior is small for random data compared to other sorting algorithms. + integer(int32), intent(inout) :: array(0:) + logical, intent(in), optional :: reverse + end subroutine int32_sort + + pure module subroutine int64_sort( array, reverse ) +!! Version: experimental +!! +!! `int64_sort( array[, reverse] )` sorts the input `ARRAY` of type `integer(int64)` +!! using a hybrid sort based on the `introsort` of David Musser. +!! The algorithm is of order O(N Ln(N)) for all inputs. +!! Because it relies on `quicksort`, the coefficient of the O(N Ln(N)) +!! behavior is small for random data compared to other sorting algorithms. + integer(int64), intent(inout) :: array(0:) + logical, intent(in), optional :: reverse + end subroutine int64_sort + + pure module subroutine sp_sort( array, reverse ) +!! Version: experimental +!! +!! `sp_sort( array[, reverse] )` sorts the input `ARRAY` of type `real(sp)` +!! using a hybrid sort based on the `introsort` of David Musser. +!! The algorithm is of order O(N Ln(N)) for all inputs. +!! Because it relies on `quicksort`, the coefficient of the O(N Ln(N)) +!! behavior is small for random data compared to other sorting algorithms. + real(sp), intent(inout) :: array(0:) + logical, intent(in), optional :: reverse + end subroutine sp_sort + + pure module subroutine dp_sort( array, reverse ) +!! Version: experimental +!! +!! `dp_sort( array[, reverse] )` sorts the input `ARRAY` of type `real(dp)` +!! using a hybrid sort based on the `introsort` of David Musser. +!! The algorithm is of order O(N Ln(N)) for all inputs. +!! Because it relies on `quicksort`, the coefficient of the O(N Ln(N)) +!! behavior is small for random data compared to other sorting algorithms. + real(dp), intent(inout) :: array(0:) + logical, intent(in), optional :: reverse + end subroutine dp_sort + + pure module subroutine qp_sort( array, reverse ) +!! Version: experimental +!! +!! `qp_sort( array[, reverse] )` sorts the input `ARRAY` of type `real(qp)` +!! using a hybrid sort based on the `introsort` of David Musser. +!! The algorithm is of order O(N Ln(N)) for all inputs. +!! Because it relies on `quicksort`, the coefficient of the O(N Ln(N)) +!! behavior is small for random data compared to other sorting algorithms. + real(qp), intent(inout) :: array(0:) + logical, intent(in), optional :: reverse + end subroutine qp_sort + + pure module subroutine string_type_sort( array, reverse ) +!! Version: experimental +!! +!! `string_type_sort( array[, reverse] )` sorts the input `ARRAY` of type `type(string_type)` +!! using a hybrid sort based on the `introsort` of David Musser. +!! The algorithm is of order O(N Ln(N)) for all inputs. +!! Because it relies on `quicksort`, the coefficient of the O(N Ln(N)) +!! behavior is small for random data compared to other sorting algorithms. + type(string_type), intent(inout) :: array(0:) + logical, intent(in), optional :: reverse + end subroutine string_type_sort + + + pure module subroutine char_sort( array, reverse ) +!! Version: experimental +!! +!! `char_sort( array[, reverse] )` sorts the input `ARRAY` of type `CHARACTER(*)` +!! using a hybrid sort based on the `introsort` of David Musser. +!! The algorithm is of order O(N Ln(N)) for all inputs. +!! Because it relies on `quicksort`, the coefficient of the O(N Ln(N)) +!! behavior is small for random data compared to other sorting algorithms. + character(len=*), intent(inout) :: array(0:) + logical, intent(in), optional :: reverse + end subroutine char_sort + + end interface sort + + interface sort_index +!! Version: experimental +!! +!! The generic subroutine interface implementing the `SORT_INDEX` algorithm, +!! based on the `"Rust" sort` algorithm found in `slice.rs` +!! https://github.com/rust-lang/rust/blob/90eb44a5897c39e3dff9c7e48e3973671dcd9496/src/liballoc/slice.rs#L2159 +!! but modified to return an array of indices that would provide a stable +!! sort of the rank one `ARRAY` input. +!! ([Specification](../page/specs/stdlib_sorting.html#sort_index-creates-an-array-of-sorting-indices-for-an-input-array-while-also-sorting-the-array)) +!! +!! The indices by default correspond to a +!! non-decreasing sort, but if the optional argument `REVERSE` is present +!! with a value of `.TRUE.` the indices correspond to a non-increasing sort. + + module subroutine int8_sort_index( array, index, work, iwork, & + reverse ) +!! Version: experimental +!! +!! `int8_sort_index( array, index[, work, iwork, reverse] )` sorts +!! an input `ARRAY` of type `integer(int8)` +!! using a hybrid sort based on the `'Rust" sort` algorithm found in `slice.rs` +!! and returns the sorted `ARRAY` and an array `INDEX of indices in the +!! order that would sort the input `ARRAY` in the desired direction. + integer(int8), intent(inout) :: array(0:) + integer(int_size), intent(out) :: index(0:) + integer(int8), intent(out), optional :: work(0:) + integer(int_size), intent(out), optional :: iwork(0:) + logical, intent(in), optional :: reverse + end subroutine int8_sort_index + + module subroutine int16_sort_index( array, index, work, iwork, & + reverse ) +!! Version: experimental +!! +!! `int16_sort_index( array, index[, work, iwork, reverse] )` sorts +!! an input `ARRAY` of type `integer(int16)` +!! using a hybrid sort based on the `'Rust" sort` algorithm found in `slice.rs` +!! and returns the sorted `ARRAY` and an array `INDEX of indices in the +!! order that would sort the input `ARRAY` in the desired direction. + integer(int16), intent(inout) :: array(0:) + integer(int_size), intent(out) :: index(0:) + integer(int16), intent(out), optional :: work(0:) + integer(int_size), intent(out), optional :: iwork(0:) + logical, intent(in), optional :: reverse + end subroutine int16_sort_index + + module subroutine int32_sort_index( array, index, work, iwork, & + reverse ) +!! Version: experimental +!! +!! `int32_sort_index( array, index[, work, iwork, reverse] )` sorts +!! an input `ARRAY` of type `integer(int32)` +!! using a hybrid sort based on the `'Rust" sort` algorithm found in `slice.rs` +!! and returns the sorted `ARRAY` and an array `INDEX of indices in the +!! order that would sort the input `ARRAY` in the desired direction. + integer(int32), intent(inout) :: array(0:) + integer(int_size), intent(out) :: index(0:) + integer(int32), intent(out), optional :: work(0:) + integer(int_size), intent(out), optional :: iwork(0:) + logical, intent(in), optional :: reverse + end subroutine int32_sort_index + + module subroutine int64_sort_index( array, index, work, iwork, & + reverse ) +!! Version: experimental +!! +!! `int64_sort_index( array, index[, work, iwork, reverse] )` sorts +!! an input `ARRAY` of type `integer(int64)` +!! using a hybrid sort based on the `'Rust" sort` algorithm found in `slice.rs` +!! and returns the sorted `ARRAY` and an array `INDEX of indices in the +!! order that would sort the input `ARRAY` in the desired direction. + integer(int64), intent(inout) :: array(0:) + integer(int_size), intent(out) :: index(0:) + integer(int64), intent(out), optional :: work(0:) + integer(int_size), intent(out), optional :: iwork(0:) + logical, intent(in), optional :: reverse + end subroutine int64_sort_index + + module subroutine sp_sort_index( array, index, work, iwork, & + reverse ) +!! Version: experimental +!! +!! `sp_sort_index( array, index[, work, iwork, reverse] )` sorts +!! an input `ARRAY` of type `real(sp)` +!! using a hybrid sort based on the `'Rust" sort` algorithm found in `slice.rs` +!! and returns the sorted `ARRAY` and an array `INDEX of indices in the +!! order that would sort the input `ARRAY` in the desired direction. + real(sp), intent(inout) :: array(0:) + integer(int_size), intent(out) :: index(0:) + real(sp), intent(out), optional :: work(0:) + integer(int_size), intent(out), optional :: iwork(0:) + logical, intent(in), optional :: reverse + end subroutine sp_sort_index + + module subroutine dp_sort_index( array, index, work, iwork, & + reverse ) +!! Version: experimental +!! +!! `dp_sort_index( array, index[, work, iwork, reverse] )` sorts +!! an input `ARRAY` of type `real(dp)` +!! using a hybrid sort based on the `'Rust" sort` algorithm found in `slice.rs` +!! and returns the sorted `ARRAY` and an array `INDEX of indices in the +!! order that would sort the input `ARRAY` in the desired direction. + real(dp), intent(inout) :: array(0:) + integer(int_size), intent(out) :: index(0:) + real(dp), intent(out), optional :: work(0:) + integer(int_size), intent(out), optional :: iwork(0:) + logical, intent(in), optional :: reverse + end subroutine dp_sort_index + + module subroutine qp_sort_index( array, index, work, iwork, & + reverse ) +!! Version: experimental +!! +!! `qp_sort_index( array, index[, work, iwork, reverse] )` sorts +!! an input `ARRAY` of type `real(qp)` +!! using a hybrid sort based on the `'Rust" sort` algorithm found in `slice.rs` +!! and returns the sorted `ARRAY` and an array `INDEX of indices in the +!! order that would sort the input `ARRAY` in the desired direction. + real(qp), intent(inout) :: array(0:) + integer(int_size), intent(out) :: index(0:) + real(qp), intent(out), optional :: work(0:) + integer(int_size), intent(out), optional :: iwork(0:) + logical, intent(in), optional :: reverse + end subroutine qp_sort_index + + module subroutine string_type_sort_index( array, index, work, iwork, & + reverse ) +!! Version: experimental +!! +!! `string_type_sort_index( array, index[, work, iwork, reverse] )` sorts +!! an input `ARRAY` of type `type(string_type)` +!! using a hybrid sort based on the `'Rust" sort` algorithm found in `slice.rs` +!! and returns the sorted `ARRAY` and an array `INDEX of indices in the +!! order that would sort the input `ARRAY` in the desired direction. + type(string_type), intent(inout) :: array(0:) + integer(int_size), intent(out) :: index(0:) + type(string_type), intent(out), optional :: work(0:) + integer(int_size), intent(out), optional :: iwork(0:) + logical, intent(in), optional :: reverse + end subroutine string_type_sort_index + + + module subroutine char_sort_index( array, index, work, iwork, & + reverse ) +!! Version: experimental +!! +!! `char_sort_index( array, index[, work, iwork, reverse] )` sorts +!! an input `ARRAY` of type `CHARACTER(*)` +!! using a hybrid sort based on the `'Rust" sort` algorithm found in `slice.rs` +!! and returns the sorted `ARRAY` and an array `INDEX of indices in the +!! order that would sort the input `ARRAY` in the desired direction. + character(len=*), intent(inout) :: array(0:) + integer(int_size), intent(out) :: index(0:) + character(len=len(array)), intent(out), optional :: work(0:) + integer(int_size), intent(out), optional :: iwork(0:) + logical, intent(in), optional :: reverse + end subroutine char_sort_index + + end interface sort_index + + +end module stdlib_sorting diff --git a/src/fpm/stdlib_sorting_ord_sort.f90 b/src/fpm/stdlib_sorting_ord_sort.f90 new file mode 100644 index 000000000..30284ad0d --- /dev/null +++ b/src/fpm/stdlib_sorting_ord_sort.f90 @@ -0,0 +1,6347 @@ + + +!! Licensing: +!! +!! This file is subjec† both to the Fortran Standard Library license, and +!! to additional licensing requirements as it contains translations of +!! other software. +!! +!! The Fortran Standard Library, including this file, is distributed under +!! the MIT license that should be included with the library's distribution. +!! +!! Copyright (c) 2021 Fortran stdlib developers +!! +!! Permission is hereby granted, free of charge, to any person obtaining a +!! copy of this software and associated documentation files (the +!! "Software"), to deal in the Software without restriction, including +!! without limitation the rights to use, copy, modify, merge, publish, +!! distribute, sublicense, and/or sellcopies of the Software, and to permit +!! persons to whom the Software is furnished to do so, subject to the +!! following conditions: +!! +!! The above copyright notice and this permission notice shall be included +!! in all copies or substantial portions of the Software. +!! +!! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS +!! OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +!! MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +!! IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +!! CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +!! TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +!! SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +!! +!! The generic subroutine, `ORD_SORT`, is substantially a translation to +!! Fortran 2008 of the `"Rust" sort` sorting routines in +!! [`slice.rs`](https://github.com/rust-lang/rust/blob/90eb44a5897c39e3dff9c7e48e3973671dcd9496/src/liballoc/slice.rs) +!! The `rust sort` implementation is distributed with the header: +!! +!! Copyright 2012-2015 The Rust Project Developers. See the COPYRIGHT +!! file at the top-level directory of this distribution and at +!! http://rust-lang.org/COPYRIGHT. +!! +!! Licensed under the Apache License, Version 2.0 or the MIT license +!! , at your +!! option. This file may not be copied, modified, or distributed +!! except according to those terms. +!! +!! so the license for the original`slice.rs` code is compatible with the use +!! of modified versions of the code in the Fortran Standard Library under +!! the MIT license. + +submodule(stdlib_sorting) stdlib_sorting_ord_sort + + implicit none + +contains + + module subroutine int8_ord_sort( array, work, reverse ) + integer(int8), intent(inout) :: array(0:) + integer(int8), intent(out), optional :: work(0:) + logical, intent(in), optional :: reverse + + logical :: reverse_ + + reverse_ = .false. + if(present(reverse)) reverse_ = reverse + + if (reverse_) then + call int8_decrease_ord_sort(array, work) + else + call int8_increase_ord_sort(array, work) + endif + + end subroutine int8_ord_sort + module subroutine int16_ord_sort( array, work, reverse ) + integer(int16), intent(inout) :: array(0:) + integer(int16), intent(out), optional :: work(0:) + logical, intent(in), optional :: reverse + + logical :: reverse_ + + reverse_ = .false. + if(present(reverse)) reverse_ = reverse + + if (reverse_) then + call int16_decrease_ord_sort(array, work) + else + call int16_increase_ord_sort(array, work) + endif + + end subroutine int16_ord_sort + module subroutine int32_ord_sort( array, work, reverse ) + integer(int32), intent(inout) :: array(0:) + integer(int32), intent(out), optional :: work(0:) + logical, intent(in), optional :: reverse + + logical :: reverse_ + + reverse_ = .false. + if(present(reverse)) reverse_ = reverse + + if (reverse_) then + call int32_decrease_ord_sort(array, work) + else + call int32_increase_ord_sort(array, work) + endif + + end subroutine int32_ord_sort + module subroutine int64_ord_sort( array, work, reverse ) + integer(int64), intent(inout) :: array(0:) + integer(int64), intent(out), optional :: work(0:) + logical, intent(in), optional :: reverse + + logical :: reverse_ + + reverse_ = .false. + if(present(reverse)) reverse_ = reverse + + if (reverse_) then + call int64_decrease_ord_sort(array, work) + else + call int64_increase_ord_sort(array, work) + endif + + end subroutine int64_ord_sort + module subroutine sp_ord_sort( array, work, reverse ) + real(sp), intent(inout) :: array(0:) + real(sp), intent(out), optional :: work(0:) + logical, intent(in), optional :: reverse + + logical :: reverse_ + + reverse_ = .false. + if(present(reverse)) reverse_ = reverse + + if (reverse_) then + call sp_decrease_ord_sort(array, work) + else + call sp_increase_ord_sort(array, work) + endif + + end subroutine sp_ord_sort + module subroutine dp_ord_sort( array, work, reverse ) + real(dp), intent(inout) :: array(0:) + real(dp), intent(out), optional :: work(0:) + logical, intent(in), optional :: reverse + + logical :: reverse_ + + reverse_ = .false. + if(present(reverse)) reverse_ = reverse + + if (reverse_) then + call dp_decrease_ord_sort(array, work) + else + call dp_increase_ord_sort(array, work) + endif + + end subroutine dp_ord_sort + module subroutine qp_ord_sort( array, work, reverse ) + real(qp), intent(inout) :: array(0:) + real(qp), intent(out), optional :: work(0:) + logical, intent(in), optional :: reverse + + logical :: reverse_ + + reverse_ = .false. + if(present(reverse)) reverse_ = reverse + + if (reverse_) then + call qp_decrease_ord_sort(array, work) + else + call qp_increase_ord_sort(array, work) + endif + + end subroutine qp_ord_sort + module subroutine string_type_ord_sort( array, work, reverse ) + type(string_type), intent(inout) :: array(0:) + type(string_type), intent(out), optional :: work(0:) + logical, intent(in), optional :: reverse + + logical :: reverse_ + + reverse_ = .false. + if(present(reverse)) reverse_ = reverse + + if (reverse_) then + call string_type_decrease_ord_sort(array, work) + else + call string_type_increase_ord_sort(array, work) + endif + + end subroutine string_type_ord_sort + + + subroutine int8_increase_ord_sort( array, work ) +! A translation to Fortran 2008, of the `"Rust" sort` algorithm found in +! `slice.rs` +! https://github.com/rust-lang/rust/blob/90eb44a5897c39e3dff9c7e48e3973671dcd9496/src/liballoc/slice.rs#L2159 +! The Rust version in turn is a simplification of the Timsort algorithm +! described in +! https://svn.python.org/projects/python/trunk/Objects/listsort.txt, as +! it drops both the use of 'galloping' to identify bounds of regions to be +! sorted and the estimation of the optimal `run size`. However it remains +! a hybrid sorting algorithm combining an iterative Merge sort controlled +! by a stack of `RUNS` identified by regions of uniformly decreasing or +! non-decreasing sequences that may be expanded to a minimum run size and +! initially processed by an insertion sort. +! +! Note the Fortran implementation simplifies the logic as it only has to +! deal with Fortran arrays of intrinsic types and not the full generality +! of Rust's arrays and lists for arbitrary types. It also adds the +! estimation of the optimal `run size` as suggested in Tim Peters' +! original `listsort.txt`, and an optional `work` array to be used as +! scratch memory. + integer(int8), intent(inout) :: array(0:) + integer(int8), intent(out), optional :: work(0:) + + integer(int8), allocatable :: buf(:) + integer(int_size) :: array_size + integer :: stat + + array_size = size( array, kind=int_size ) + if ( present(work) ) then + if ( size( work, kind=int_size) < array_size/2 ) then + error stop "int8_increase_ord_sort: work array is too small." + endif +! Use the work array as scratch memory + call merge_sort( array, work ) + else +! Allocate a buffer to use as scratch memory. + allocate( buf(0:array_size/2-1), stat=stat ) + if ( stat /= 0 ) error stop "int8_increase_ord_sort: Allocation of buffer failed." + call merge_sort( array, buf ) + end if + + contains + + pure function calc_min_run( n ) result(min_run) +!! Returns the minimum length of a run from 32-63 so that N/MIN_RUN is +!! less than or equal to a power of two. See +!! https://svn.python.org/projects/python/trunk/Objects/listsort.txt + integer(int_size) :: min_run + integer(int_size), intent(in) :: n + + integer(int_size) :: num, r + + num = n + r = 0_int_size + + do while( num >= 64 ) + r = ior( r, iand(num, 1_int_size) ) + num = ishft(num, -1_int_size) + end do + min_run = num + r + + end function calc_min_run + + + pure subroutine insertion_sort( array ) +! Sorts `ARRAY` using an insertion sort. + integer(int8), intent(inout) :: array(0:) + + integer(int_size) :: i, j + integer(int8) :: key + + do j=1, size(array, kind=int_size)-1 + key = array(j) + i = j - 1 + do while( i >= 0 ) + if ( array(i) <= key ) exit + array(i+1) = array(i) + i = i - 1 + end do + array(i+1) = key + end do + + end subroutine insertion_sort + + + pure function collapse( runs ) result ( r ) +! Examine the stack of runs waiting to be merged, identifying adjacent runs +! to be merged until the stack invariants are restablished: +! +! 1. len(-3) > len(-2) + len(-1) +! 2. len(-2) > len(-1) + integer(int_size) :: r + type(run_type), intent(in), target :: runs(0:) + + integer(int_size) :: n + logical :: test + + n = size(runs, kind=int_size) + test = .false. + if (n >= 2) then + if ( runs( n-1 ) % base == 0 .or. & + runs( n-2 ) % len <= runs(n-1) % len ) then + test = .true. + else if ( n >= 3 ) then ! X exists + if ( runs(n-3) % len <= & + runs(n-2) % len + runs(n-1) % len ) then + test = .true. +! |X| <= |Y| + |Z| => will need to merge due to rho1 or rho2 + else if( n >= 4 ) then + if ( runs(n-4) % len <= & + runs(n-3) % len + runs(n-2) % len ) then + test = .true. +! |W| <= |X| + |Y| => will need to merge due to rho1 or rho3 + end if + end if + end if + end if + if ( test ) then +! By default merge Y & Z, rho2 or rho3 + if ( n >= 3 ) then + if ( runs(n-3) % len < runs(n-1) % len ) then + r = n - 3 +! |X| < |Z| => merge X & Y, rho1 + return + end if + end if + r = n - 2 +! |Y| <= |Z| => merge Y & Z, rho4 + return + else + r = -1 + end if + + end function collapse + + + pure subroutine insert_head( array ) +! Inserts `array(0)` into the pre-sorted sequence `array(1:)` so that the +! whole `array(0:)` becomes sorted, copying the first element into +! a temporary variable, iterating until the right place for it is found. +! copying every traversed element into the slot preceding it, and finally, +! copying data from the temporary variable into the resulting hole. + + integer(int8), intent(inout) :: array(0:) + + integer(int8) :: tmp + integer(int_size) :: i + + tmp = array(0) + find_hole: do i=1, size(array, kind=int_size)-1 + if ( array(i) >= tmp ) exit find_hole + array(i-1) = array(i) + end do find_hole + array(i-1) = tmp + + end subroutine insert_head + + + subroutine merge_sort( array, buf ) +! The Rust merge sort borrows some (but not all) of the ideas from TimSort, +! which is described in detail at +! (http://svn.python.org/projects/python/trunk/Objects/listsort.txt). +! +! The algorithm identifies strictly descending and non-descending +! subsequences, which are called natural runs. Where these runs are less +! than a minimum run size they are padded by adding additional samples +! using an insertion sort. The merge process is driven by a stack of +! pending unmerged runs. Each newly found run is pushed onto the stack, +! and then pairs of adjacentd runs are merged until these two invariants +! are satisfied: +! +! 1. for every `i` in `1..size(runs)-1`: `runs(i - 1)%len > runs(i)%len` +! 2. for every `i` in `2..size(runs)-1`: `runs(i - 2)%len > +! runs(i - 1)%len + runs(i)%len` +! +! The invariants ensure that the total running time is `O(n log n)` +! worst-case. + + integer(int8), intent(inout) :: array(0:) + integer(int8), intent(inout) :: buf(0:) + + integer(int_size) :: array_size, finish, min_run, r, r_count, & + start + type(run_type) :: runs(0:max_merge_stack-1), left, right + + array_size = size(array, kind=int_size) + +! Very short runs are extended using insertion sort to span at least +! min_run elements. Slices of up to this length are sorted using insertion +! sort. + min_run = calc_min_run( array_size ) + + if ( array_size <= min_run ) then + if ( array_size >= 2 ) call insertion_sort( array ) + return + end if + +! Following Rust sort, natural runs in `array` are identified by traversing +! it backwards. By traversing it backward, merges more often go in the +! opposite direction (forwards). According to developers of Rust sort, +! merging forwards is slightly faster than merging backwards. Therefore +! identifying runs by traversing backwards should improve performance. + r_count = 0 + finish = array_size - 1 + do while ( finish >= 0 ) +! Find the next natural run, and reverse it if it's strictly descending. + start = finish + if ( start > 0 ) then + start = start - 1 + if ( array(start+1) < array(start) ) then + Descending: do while ( start > 0 ) + if ( array(start) >= array(start-1) ) & + exit Descending + start = start - 1 + end do Descending + call reverse_segment( array(start:finish) ) + else + Ascending: do while( start > 0 ) + if ( array(start) < array(start-1) ) exit Ascending + start = start - 1 + end do Ascending + end if + end if + +! If the run is too short insert some more elements using an insertion sort. + Insert: do while ( start > 0 ) + if ( finish - start >= min_run - 1 ) exit Insert + start = start - 1 + call insert_head( array(start:finish) ) + end do Insert + if ( start == 0 .and. finish == array_size - 1 ) return + + runs(r_count) = run_type( base = start, & + len = finish - start + 1 ) + finish = start-1 + r_count = r_count + 1 + +! Determine whether pairs of adjacent runs need to be merged to satisfy +! the invariants, and, if so, merge them. + Merge_loop: do + r = collapse( runs(0:r_count - 1) ) + if ( r < 0 .or. r_count <= 1 ) exit Merge_loop + left = runs( r + 1 ) + right = runs( r ) + call merge( array( left % base: & + right % base + right % len - 1 ), & + left % len, buf ) + + runs(r) = run_type( base = left % base, & + len = left % len + right % len ) + if ( r == r_count - 3 ) runs(r+1) = runs(r+2) + r_count = r_count - 1 + + end do Merge_loop + end do + if ( r_count /= 1 ) & + error stop "MERGE_SORT completed without RUN COUNT == 1." + + end subroutine merge_sort + + + pure subroutine merge( array, mid, buf ) +! Merges the two non-decreasing runs `ARRAY(0:MID-1)` and `ARRAY(MID:)` +! using `BUF` as temporary storage, and stores the merged runs into +! `ARRAY(0:)`. `MID` must be > 0, and < `SIZE(ARRAY)-1`. Buffer `BUF` +! must be long enough to hold the shorter of the two runs. + integer(int8), intent(inout) :: array(0:) + integer(int_size), intent(in) :: mid + integer(int8), intent(inout) :: buf(0:) + + integer(int_size) :: array_len, i, j, k + + array_len = size(array, kind=int_size) + +! Merge first copies the shorter run into `buf`. Then, depending on which +! run was shorter, it traces the copied run and the longer run forwards +! (or backwards), comparing their next unprocessed elements and then +! copying the lesser (or greater) one into `array`. + + if ( mid <= array_len - mid ) then ! The left run is shorter. + buf(0:mid-1) = array(0:mid-1) + i = 0 + j = mid + merge_lower: do k = 0, array_len-1 + if ( buf(i) <= array(j) ) then + array(k) = buf(i) + i = i + 1 + if ( i >= mid ) exit merge_lower + else + array(k) = array(j) + j = j + 1 + if ( j >= array_len ) then + array(k+1:) = buf(i:mid-1) + exit merge_lower + end if + end if + end do merge_lower + else ! The right run is shorter ! check that it is stable + buf(0:array_len-mid-1) = array(mid:array_len-1) + i = mid - 1 + j = array_len - mid -1 + merge_upper: do k = array_len-1, 0, -1 + if ( buf(j) >= array(i) ) then + array(k) = buf(j) + j = j - 1 + if ( j < 0 ) exit merge_upper + else + array(k) = array(i) + i = i - 1 + if ( i < 0 ) then + array(0:k-1) = buf(0:j) + exit merge_upper + end if + end if + end do merge_upper + end if + end subroutine merge + + + pure subroutine reverse_segment( array ) +! Reverse a segment of an array in place + integer(int8), intent(inout) :: array(0:) + + integer(int_size) :: lo, hi + integer(int8) :: temp + + lo = 0 + hi = size( array, kind=int_size ) - 1 + do while( lo < hi ) + temp = array(lo) + array(lo) = array(hi) + array(hi) = temp + lo = lo + 1 + hi = hi - 1 + end do + + end subroutine reverse_segment + + end subroutine int8_increase_ord_sort + + + subroutine int16_increase_ord_sort( array, work ) +! A translation to Fortran 2008, of the `"Rust" sort` algorithm found in +! `slice.rs` +! https://github.com/rust-lang/rust/blob/90eb44a5897c39e3dff9c7e48e3973671dcd9496/src/liballoc/slice.rs#L2159 +! The Rust version in turn is a simplification of the Timsort algorithm +! described in +! https://svn.python.org/projects/python/trunk/Objects/listsort.txt, as +! it drops both the use of 'galloping' to identify bounds of regions to be +! sorted and the estimation of the optimal `run size`. However it remains +! a hybrid sorting algorithm combining an iterative Merge sort controlled +! by a stack of `RUNS` identified by regions of uniformly decreasing or +! non-decreasing sequences that may be expanded to a minimum run size and +! initially processed by an insertion sort. +! +! Note the Fortran implementation simplifies the logic as it only has to +! deal with Fortran arrays of intrinsic types and not the full generality +! of Rust's arrays and lists for arbitrary types. It also adds the +! estimation of the optimal `run size` as suggested in Tim Peters' +! original `listsort.txt`, and an optional `work` array to be used as +! scratch memory. + integer(int16), intent(inout) :: array(0:) + integer(int16), intent(out), optional :: work(0:) + + integer(int16), allocatable :: buf(:) + integer(int_size) :: array_size + integer :: stat + + array_size = size( array, kind=int_size ) + if ( present(work) ) then + if ( size( work, kind=int_size) < array_size/2 ) then + error stop "int16_increase_ord_sort: work array is too small." + endif +! Use the work array as scratch memory + call merge_sort( array, work ) + else +! Allocate a buffer to use as scratch memory. + allocate( buf(0:array_size/2-1), stat=stat ) + if ( stat /= 0 ) error stop "int16_increase_ord_sort: Allocation of buffer failed." + call merge_sort( array, buf ) + end if + + contains + + pure function calc_min_run( n ) result(min_run) +!! Returns the minimum length of a run from 32-63 so that N/MIN_RUN is +!! less than or equal to a power of two. See +!! https://svn.python.org/projects/python/trunk/Objects/listsort.txt + integer(int_size) :: min_run + integer(int_size), intent(in) :: n + + integer(int_size) :: num, r + + num = n + r = 0_int_size + + do while( num >= 64 ) + r = ior( r, iand(num, 1_int_size) ) + num = ishft(num, -1_int_size) + end do + min_run = num + r + + end function calc_min_run + + + pure subroutine insertion_sort( array ) +! Sorts `ARRAY` using an insertion sort. + integer(int16), intent(inout) :: array(0:) + + integer(int_size) :: i, j + integer(int16) :: key + + do j=1, size(array, kind=int_size)-1 + key = array(j) + i = j - 1 + do while( i >= 0 ) + if ( array(i) <= key ) exit + array(i+1) = array(i) + i = i - 1 + end do + array(i+1) = key + end do + + end subroutine insertion_sort + + + pure function collapse( runs ) result ( r ) +! Examine the stack of runs waiting to be merged, identifying adjacent runs +! to be merged until the stack invariants are restablished: +! +! 1. len(-3) > len(-2) + len(-1) +! 2. len(-2) > len(-1) + integer(int_size) :: r + type(run_type), intent(in), target :: runs(0:) + + integer(int_size) :: n + logical :: test + + n = size(runs, kind=int_size) + test = .false. + if (n >= 2) then + if ( runs( n-1 ) % base == 0 .or. & + runs( n-2 ) % len <= runs(n-1) % len ) then + test = .true. + else if ( n >= 3 ) then ! X exists + if ( runs(n-3) % len <= & + runs(n-2) % len + runs(n-1) % len ) then + test = .true. +! |X| <= |Y| + |Z| => will need to merge due to rho1 or rho2 + else if( n >= 4 ) then + if ( runs(n-4) % len <= & + runs(n-3) % len + runs(n-2) % len ) then + test = .true. +! |W| <= |X| + |Y| => will need to merge due to rho1 or rho3 + end if + end if + end if + end if + if ( test ) then +! By default merge Y & Z, rho2 or rho3 + if ( n >= 3 ) then + if ( runs(n-3) % len < runs(n-1) % len ) then + r = n - 3 +! |X| < |Z| => merge X & Y, rho1 + return + end if + end if + r = n - 2 +! |Y| <= |Z| => merge Y & Z, rho4 + return + else + r = -1 + end if + + end function collapse + + + pure subroutine insert_head( array ) +! Inserts `array(0)` into the pre-sorted sequence `array(1:)` so that the +! whole `array(0:)` becomes sorted, copying the first element into +! a temporary variable, iterating until the right place for it is found. +! copying every traversed element into the slot preceding it, and finally, +! copying data from the temporary variable into the resulting hole. + + integer(int16), intent(inout) :: array(0:) + + integer(int16) :: tmp + integer(int_size) :: i + + tmp = array(0) + find_hole: do i=1, size(array, kind=int_size)-1 + if ( array(i) >= tmp ) exit find_hole + array(i-1) = array(i) + end do find_hole + array(i-1) = tmp + + end subroutine insert_head + + + subroutine merge_sort( array, buf ) +! The Rust merge sort borrows some (but not all) of the ideas from TimSort, +! which is described in detail at +! (http://svn.python.org/projects/python/trunk/Objects/listsort.txt). +! +! The algorithm identifies strictly descending and non-descending +! subsequences, which are called natural runs. Where these runs are less +! than a minimum run size they are padded by adding additional samples +! using an insertion sort. The merge process is driven by a stack of +! pending unmerged runs. Each newly found run is pushed onto the stack, +! and then pairs of adjacentd runs are merged until these two invariants +! are satisfied: +! +! 1. for every `i` in `1..size(runs)-1`: `runs(i - 1)%len > runs(i)%len` +! 2. for every `i` in `2..size(runs)-1`: `runs(i - 2)%len > +! runs(i - 1)%len + runs(i)%len` +! +! The invariants ensure that the total running time is `O(n log n)` +! worst-case. + + integer(int16), intent(inout) :: array(0:) + integer(int16), intent(inout) :: buf(0:) + + integer(int_size) :: array_size, finish, min_run, r, r_count, & + start + type(run_type) :: runs(0:max_merge_stack-1), left, right + + array_size = size(array, kind=int_size) + +! Very short runs are extended using insertion sort to span at least +! min_run elements. Slices of up to this length are sorted using insertion +! sort. + min_run = calc_min_run( array_size ) + + if ( array_size <= min_run ) then + if ( array_size >= 2 ) call insertion_sort( array ) + return + end if + +! Following Rust sort, natural runs in `array` are identified by traversing +! it backwards. By traversing it backward, merges more often go in the +! opposite direction (forwards). According to developers of Rust sort, +! merging forwards is slightly faster than merging backwards. Therefore +! identifying runs by traversing backwards should improve performance. + r_count = 0 + finish = array_size - 1 + do while ( finish >= 0 ) +! Find the next natural run, and reverse it if it's strictly descending. + start = finish + if ( start > 0 ) then + start = start - 1 + if ( array(start+1) < array(start) ) then + Descending: do while ( start > 0 ) + if ( array(start) >= array(start-1) ) & + exit Descending + start = start - 1 + end do Descending + call reverse_segment( array(start:finish) ) + else + Ascending: do while( start > 0 ) + if ( array(start) < array(start-1) ) exit Ascending + start = start - 1 + end do Ascending + end if + end if + +! If the run is too short insert some more elements using an insertion sort. + Insert: do while ( start > 0 ) + if ( finish - start >= min_run - 1 ) exit Insert + start = start - 1 + call insert_head( array(start:finish) ) + end do Insert + if ( start == 0 .and. finish == array_size - 1 ) return + + runs(r_count) = run_type( base = start, & + len = finish - start + 1 ) + finish = start-1 + r_count = r_count + 1 + +! Determine whether pairs of adjacent runs need to be merged to satisfy +! the invariants, and, if so, merge them. + Merge_loop: do + r = collapse( runs(0:r_count - 1) ) + if ( r < 0 .or. r_count <= 1 ) exit Merge_loop + left = runs( r + 1 ) + right = runs( r ) + call merge( array( left % base: & + right % base + right % len - 1 ), & + left % len, buf ) + + runs(r) = run_type( base = left % base, & + len = left % len + right % len ) + if ( r == r_count - 3 ) runs(r+1) = runs(r+2) + r_count = r_count - 1 + + end do Merge_loop + end do + if ( r_count /= 1 ) & + error stop "MERGE_SORT completed without RUN COUNT == 1." + + end subroutine merge_sort + + + pure subroutine merge( array, mid, buf ) +! Merges the two non-decreasing runs `ARRAY(0:MID-1)` and `ARRAY(MID:)` +! using `BUF` as temporary storage, and stores the merged runs into +! `ARRAY(0:)`. `MID` must be > 0, and < `SIZE(ARRAY)-1`. Buffer `BUF` +! must be long enough to hold the shorter of the two runs. + integer(int16), intent(inout) :: array(0:) + integer(int_size), intent(in) :: mid + integer(int16), intent(inout) :: buf(0:) + + integer(int_size) :: array_len, i, j, k + + array_len = size(array, kind=int_size) + +! Merge first copies the shorter run into `buf`. Then, depending on which +! run was shorter, it traces the copied run and the longer run forwards +! (or backwards), comparing their next unprocessed elements and then +! copying the lesser (or greater) one into `array`. + + if ( mid <= array_len - mid ) then ! The left run is shorter. + buf(0:mid-1) = array(0:mid-1) + i = 0 + j = mid + merge_lower: do k = 0, array_len-1 + if ( buf(i) <= array(j) ) then + array(k) = buf(i) + i = i + 1 + if ( i >= mid ) exit merge_lower + else + array(k) = array(j) + j = j + 1 + if ( j >= array_len ) then + array(k+1:) = buf(i:mid-1) + exit merge_lower + end if + end if + end do merge_lower + else ! The right run is shorter ! check that it is stable + buf(0:array_len-mid-1) = array(mid:array_len-1) + i = mid - 1 + j = array_len - mid -1 + merge_upper: do k = array_len-1, 0, -1 + if ( buf(j) >= array(i) ) then + array(k) = buf(j) + j = j - 1 + if ( j < 0 ) exit merge_upper + else + array(k) = array(i) + i = i - 1 + if ( i < 0 ) then + array(0:k-1) = buf(0:j) + exit merge_upper + end if + end if + end do merge_upper + end if + end subroutine merge + + + pure subroutine reverse_segment( array ) +! Reverse a segment of an array in place + integer(int16), intent(inout) :: array(0:) + + integer(int_size) :: lo, hi + integer(int16) :: temp + + lo = 0 + hi = size( array, kind=int_size ) - 1 + do while( lo < hi ) + temp = array(lo) + array(lo) = array(hi) + array(hi) = temp + lo = lo + 1 + hi = hi - 1 + end do + + end subroutine reverse_segment + + end subroutine int16_increase_ord_sort + + + subroutine int32_increase_ord_sort( array, work ) +! A translation to Fortran 2008, of the `"Rust" sort` algorithm found in +! `slice.rs` +! https://github.com/rust-lang/rust/blob/90eb44a5897c39e3dff9c7e48e3973671dcd9496/src/liballoc/slice.rs#L2159 +! The Rust version in turn is a simplification of the Timsort algorithm +! described in +! https://svn.python.org/projects/python/trunk/Objects/listsort.txt, as +! it drops both the use of 'galloping' to identify bounds of regions to be +! sorted and the estimation of the optimal `run size`. However it remains +! a hybrid sorting algorithm combining an iterative Merge sort controlled +! by a stack of `RUNS` identified by regions of uniformly decreasing or +! non-decreasing sequences that may be expanded to a minimum run size and +! initially processed by an insertion sort. +! +! Note the Fortran implementation simplifies the logic as it only has to +! deal with Fortran arrays of intrinsic types and not the full generality +! of Rust's arrays and lists for arbitrary types. It also adds the +! estimation of the optimal `run size` as suggested in Tim Peters' +! original `listsort.txt`, and an optional `work` array to be used as +! scratch memory. + integer(int32), intent(inout) :: array(0:) + integer(int32), intent(out), optional :: work(0:) + + integer(int32), allocatable :: buf(:) + integer(int_size) :: array_size + integer :: stat + + array_size = size( array, kind=int_size ) + if ( present(work) ) then + if ( size( work, kind=int_size) < array_size/2 ) then + error stop "int32_increase_ord_sort: work array is too small." + endif +! Use the work array as scratch memory + call merge_sort( array, work ) + else +! Allocate a buffer to use as scratch memory. + allocate( buf(0:array_size/2-1), stat=stat ) + if ( stat /= 0 ) error stop "int32_increase_ord_sort: Allocation of buffer failed." + call merge_sort( array, buf ) + end if + + contains + + pure function calc_min_run( n ) result(min_run) +!! Returns the minimum length of a run from 32-63 so that N/MIN_RUN is +!! less than or equal to a power of two. See +!! https://svn.python.org/projects/python/trunk/Objects/listsort.txt + integer(int_size) :: min_run + integer(int_size), intent(in) :: n + + integer(int_size) :: num, r + + num = n + r = 0_int_size + + do while( num >= 64 ) + r = ior( r, iand(num, 1_int_size) ) + num = ishft(num, -1_int_size) + end do + min_run = num + r + + end function calc_min_run + + + pure subroutine insertion_sort( array ) +! Sorts `ARRAY` using an insertion sort. + integer(int32), intent(inout) :: array(0:) + + integer(int_size) :: i, j + integer(int32) :: key + + do j=1, size(array, kind=int_size)-1 + key = array(j) + i = j - 1 + do while( i >= 0 ) + if ( array(i) <= key ) exit + array(i+1) = array(i) + i = i - 1 + end do + array(i+1) = key + end do + + end subroutine insertion_sort + + + pure function collapse( runs ) result ( r ) +! Examine the stack of runs waiting to be merged, identifying adjacent runs +! to be merged until the stack invariants are restablished: +! +! 1. len(-3) > len(-2) + len(-1) +! 2. len(-2) > len(-1) + integer(int_size) :: r + type(run_type), intent(in), target :: runs(0:) + + integer(int_size) :: n + logical :: test + + n = size(runs, kind=int_size) + test = .false. + if (n >= 2) then + if ( runs( n-1 ) % base == 0 .or. & + runs( n-2 ) % len <= runs(n-1) % len ) then + test = .true. + else if ( n >= 3 ) then ! X exists + if ( runs(n-3) % len <= & + runs(n-2) % len + runs(n-1) % len ) then + test = .true. +! |X| <= |Y| + |Z| => will need to merge due to rho1 or rho2 + else if( n >= 4 ) then + if ( runs(n-4) % len <= & + runs(n-3) % len + runs(n-2) % len ) then + test = .true. +! |W| <= |X| + |Y| => will need to merge due to rho1 or rho3 + end if + end if + end if + end if + if ( test ) then +! By default merge Y & Z, rho2 or rho3 + if ( n >= 3 ) then + if ( runs(n-3) % len < runs(n-1) % len ) then + r = n - 3 +! |X| < |Z| => merge X & Y, rho1 + return + end if + end if + r = n - 2 +! |Y| <= |Z| => merge Y & Z, rho4 + return + else + r = -1 + end if + + end function collapse + + + pure subroutine insert_head( array ) +! Inserts `array(0)` into the pre-sorted sequence `array(1:)` so that the +! whole `array(0:)` becomes sorted, copying the first element into +! a temporary variable, iterating until the right place for it is found. +! copying every traversed element into the slot preceding it, and finally, +! copying data from the temporary variable into the resulting hole. + + integer(int32), intent(inout) :: array(0:) + + integer(int32) :: tmp + integer(int_size) :: i + + tmp = array(0) + find_hole: do i=1, size(array, kind=int_size)-1 + if ( array(i) >= tmp ) exit find_hole + array(i-1) = array(i) + end do find_hole + array(i-1) = tmp + + end subroutine insert_head + + + subroutine merge_sort( array, buf ) +! The Rust merge sort borrows some (but not all) of the ideas from TimSort, +! which is described in detail at +! (http://svn.python.org/projects/python/trunk/Objects/listsort.txt). +! +! The algorithm identifies strictly descending and non-descending +! subsequences, which are called natural runs. Where these runs are less +! than a minimum run size they are padded by adding additional samples +! using an insertion sort. The merge process is driven by a stack of +! pending unmerged runs. Each newly found run is pushed onto the stack, +! and then pairs of adjacentd runs are merged until these two invariants +! are satisfied: +! +! 1. for every `i` in `1..size(runs)-1`: `runs(i - 1)%len > runs(i)%len` +! 2. for every `i` in `2..size(runs)-1`: `runs(i - 2)%len > +! runs(i - 1)%len + runs(i)%len` +! +! The invariants ensure that the total running time is `O(n log n)` +! worst-case. + + integer(int32), intent(inout) :: array(0:) + integer(int32), intent(inout) :: buf(0:) + + integer(int_size) :: array_size, finish, min_run, r, r_count, & + start + type(run_type) :: runs(0:max_merge_stack-1), left, right + + array_size = size(array, kind=int_size) + +! Very short runs are extended using insertion sort to span at least +! min_run elements. Slices of up to this length are sorted using insertion +! sort. + min_run = calc_min_run( array_size ) + + if ( array_size <= min_run ) then + if ( array_size >= 2 ) call insertion_sort( array ) + return + end if + +! Following Rust sort, natural runs in `array` are identified by traversing +! it backwards. By traversing it backward, merges more often go in the +! opposite direction (forwards). According to developers of Rust sort, +! merging forwards is slightly faster than merging backwards. Therefore +! identifying runs by traversing backwards should improve performance. + r_count = 0 + finish = array_size - 1 + do while ( finish >= 0 ) +! Find the next natural run, and reverse it if it's strictly descending. + start = finish + if ( start > 0 ) then + start = start - 1 + if ( array(start+1) < array(start) ) then + Descending: do while ( start > 0 ) + if ( array(start) >= array(start-1) ) & + exit Descending + start = start - 1 + end do Descending + call reverse_segment( array(start:finish) ) + else + Ascending: do while( start > 0 ) + if ( array(start) < array(start-1) ) exit Ascending + start = start - 1 + end do Ascending + end if + end if + +! If the run is too short insert some more elements using an insertion sort. + Insert: do while ( start > 0 ) + if ( finish - start >= min_run - 1 ) exit Insert + start = start - 1 + call insert_head( array(start:finish) ) + end do Insert + if ( start == 0 .and. finish == array_size - 1 ) return + + runs(r_count) = run_type( base = start, & + len = finish - start + 1 ) + finish = start-1 + r_count = r_count + 1 + +! Determine whether pairs of adjacent runs need to be merged to satisfy +! the invariants, and, if so, merge them. + Merge_loop: do + r = collapse( runs(0:r_count - 1) ) + if ( r < 0 .or. r_count <= 1 ) exit Merge_loop + left = runs( r + 1 ) + right = runs( r ) + call merge( array( left % base: & + right % base + right % len - 1 ), & + left % len, buf ) + + runs(r) = run_type( base = left % base, & + len = left % len + right % len ) + if ( r == r_count - 3 ) runs(r+1) = runs(r+2) + r_count = r_count - 1 + + end do Merge_loop + end do + if ( r_count /= 1 ) & + error stop "MERGE_SORT completed without RUN COUNT == 1." + + end subroutine merge_sort + + + pure subroutine merge( array, mid, buf ) +! Merges the two non-decreasing runs `ARRAY(0:MID-1)` and `ARRAY(MID:)` +! using `BUF` as temporary storage, and stores the merged runs into +! `ARRAY(0:)`. `MID` must be > 0, and < `SIZE(ARRAY)-1`. Buffer `BUF` +! must be long enough to hold the shorter of the two runs. + integer(int32), intent(inout) :: array(0:) + integer(int_size), intent(in) :: mid + integer(int32), intent(inout) :: buf(0:) + + integer(int_size) :: array_len, i, j, k + + array_len = size(array, kind=int_size) + +! Merge first copies the shorter run into `buf`. Then, depending on which +! run was shorter, it traces the copied run and the longer run forwards +! (or backwards), comparing their next unprocessed elements and then +! copying the lesser (or greater) one into `array`. + + if ( mid <= array_len - mid ) then ! The left run is shorter. + buf(0:mid-1) = array(0:mid-1) + i = 0 + j = mid + merge_lower: do k = 0, array_len-1 + if ( buf(i) <= array(j) ) then + array(k) = buf(i) + i = i + 1 + if ( i >= mid ) exit merge_lower + else + array(k) = array(j) + j = j + 1 + if ( j >= array_len ) then + array(k+1:) = buf(i:mid-1) + exit merge_lower + end if + end if + end do merge_lower + else ! The right run is shorter ! check that it is stable + buf(0:array_len-mid-1) = array(mid:array_len-1) + i = mid - 1 + j = array_len - mid -1 + merge_upper: do k = array_len-1, 0, -1 + if ( buf(j) >= array(i) ) then + array(k) = buf(j) + j = j - 1 + if ( j < 0 ) exit merge_upper + else + array(k) = array(i) + i = i - 1 + if ( i < 0 ) then + array(0:k-1) = buf(0:j) + exit merge_upper + end if + end if + end do merge_upper + end if + end subroutine merge + + + pure subroutine reverse_segment( array ) +! Reverse a segment of an array in place + integer(int32), intent(inout) :: array(0:) + + integer(int_size) :: lo, hi + integer(int32) :: temp + + lo = 0 + hi = size( array, kind=int_size ) - 1 + do while( lo < hi ) + temp = array(lo) + array(lo) = array(hi) + array(hi) = temp + lo = lo + 1 + hi = hi - 1 + end do + + end subroutine reverse_segment + + end subroutine int32_increase_ord_sort + + + subroutine int64_increase_ord_sort( array, work ) +! A translation to Fortran 2008, of the `"Rust" sort` algorithm found in +! `slice.rs` +! https://github.com/rust-lang/rust/blob/90eb44a5897c39e3dff9c7e48e3973671dcd9496/src/liballoc/slice.rs#L2159 +! The Rust version in turn is a simplification of the Timsort algorithm +! described in +! https://svn.python.org/projects/python/trunk/Objects/listsort.txt, as +! it drops both the use of 'galloping' to identify bounds of regions to be +! sorted and the estimation of the optimal `run size`. However it remains +! a hybrid sorting algorithm combining an iterative Merge sort controlled +! by a stack of `RUNS` identified by regions of uniformly decreasing or +! non-decreasing sequences that may be expanded to a minimum run size and +! initially processed by an insertion sort. +! +! Note the Fortran implementation simplifies the logic as it only has to +! deal with Fortran arrays of intrinsic types and not the full generality +! of Rust's arrays and lists for arbitrary types. It also adds the +! estimation of the optimal `run size` as suggested in Tim Peters' +! original `listsort.txt`, and an optional `work` array to be used as +! scratch memory. + integer(int64), intent(inout) :: array(0:) + integer(int64), intent(out), optional :: work(0:) + + integer(int64), allocatable :: buf(:) + integer(int_size) :: array_size + integer :: stat + + array_size = size( array, kind=int_size ) + if ( present(work) ) then + if ( size( work, kind=int_size) < array_size/2 ) then + error stop "int64_increase_ord_sort: work array is too small." + endif +! Use the work array as scratch memory + call merge_sort( array, work ) + else +! Allocate a buffer to use as scratch memory. + allocate( buf(0:array_size/2-1), stat=stat ) + if ( stat /= 0 ) error stop "int64_increase_ord_sort: Allocation of buffer failed." + call merge_sort( array, buf ) + end if + + contains + + pure function calc_min_run( n ) result(min_run) +!! Returns the minimum length of a run from 32-63 so that N/MIN_RUN is +!! less than or equal to a power of two. See +!! https://svn.python.org/projects/python/trunk/Objects/listsort.txt + integer(int_size) :: min_run + integer(int_size), intent(in) :: n + + integer(int_size) :: num, r + + num = n + r = 0_int_size + + do while( num >= 64 ) + r = ior( r, iand(num, 1_int_size) ) + num = ishft(num, -1_int_size) + end do + min_run = num + r + + end function calc_min_run + + + pure subroutine insertion_sort( array ) +! Sorts `ARRAY` using an insertion sort. + integer(int64), intent(inout) :: array(0:) + + integer(int_size) :: i, j + integer(int64) :: key + + do j=1, size(array, kind=int_size)-1 + key = array(j) + i = j - 1 + do while( i >= 0 ) + if ( array(i) <= key ) exit + array(i+1) = array(i) + i = i - 1 + end do + array(i+1) = key + end do + + end subroutine insertion_sort + + + pure function collapse( runs ) result ( r ) +! Examine the stack of runs waiting to be merged, identifying adjacent runs +! to be merged until the stack invariants are restablished: +! +! 1. len(-3) > len(-2) + len(-1) +! 2. len(-2) > len(-1) + integer(int_size) :: r + type(run_type), intent(in), target :: runs(0:) + + integer(int_size) :: n + logical :: test + + n = size(runs, kind=int_size) + test = .false. + if (n >= 2) then + if ( runs( n-1 ) % base == 0 .or. & + runs( n-2 ) % len <= runs(n-1) % len ) then + test = .true. + else if ( n >= 3 ) then ! X exists + if ( runs(n-3) % len <= & + runs(n-2) % len + runs(n-1) % len ) then + test = .true. +! |X| <= |Y| + |Z| => will need to merge due to rho1 or rho2 + else if( n >= 4 ) then + if ( runs(n-4) % len <= & + runs(n-3) % len + runs(n-2) % len ) then + test = .true. +! |W| <= |X| + |Y| => will need to merge due to rho1 or rho3 + end if + end if + end if + end if + if ( test ) then +! By default merge Y & Z, rho2 or rho3 + if ( n >= 3 ) then + if ( runs(n-3) % len < runs(n-1) % len ) then + r = n - 3 +! |X| < |Z| => merge X & Y, rho1 + return + end if + end if + r = n - 2 +! |Y| <= |Z| => merge Y & Z, rho4 + return + else + r = -1 + end if + + end function collapse + + + pure subroutine insert_head( array ) +! Inserts `array(0)` into the pre-sorted sequence `array(1:)` so that the +! whole `array(0:)` becomes sorted, copying the first element into +! a temporary variable, iterating until the right place for it is found. +! copying every traversed element into the slot preceding it, and finally, +! copying data from the temporary variable into the resulting hole. + + integer(int64), intent(inout) :: array(0:) + + integer(int64) :: tmp + integer(int_size) :: i + + tmp = array(0) + find_hole: do i=1, size(array, kind=int_size)-1 + if ( array(i) >= tmp ) exit find_hole + array(i-1) = array(i) + end do find_hole + array(i-1) = tmp + + end subroutine insert_head + + + subroutine merge_sort( array, buf ) +! The Rust merge sort borrows some (but not all) of the ideas from TimSort, +! which is described in detail at +! (http://svn.python.org/projects/python/trunk/Objects/listsort.txt). +! +! The algorithm identifies strictly descending and non-descending +! subsequences, which are called natural runs. Where these runs are less +! than a minimum run size they are padded by adding additional samples +! using an insertion sort. The merge process is driven by a stack of +! pending unmerged runs. Each newly found run is pushed onto the stack, +! and then pairs of adjacentd runs are merged until these two invariants +! are satisfied: +! +! 1. for every `i` in `1..size(runs)-1`: `runs(i - 1)%len > runs(i)%len` +! 2. for every `i` in `2..size(runs)-1`: `runs(i - 2)%len > +! runs(i - 1)%len + runs(i)%len` +! +! The invariants ensure that the total running time is `O(n log n)` +! worst-case. + + integer(int64), intent(inout) :: array(0:) + integer(int64), intent(inout) :: buf(0:) + + integer(int_size) :: array_size, finish, min_run, r, r_count, & + start + type(run_type) :: runs(0:max_merge_stack-1), left, right + + array_size = size(array, kind=int_size) + +! Very short runs are extended using insertion sort to span at least +! min_run elements. Slices of up to this length are sorted using insertion +! sort. + min_run = calc_min_run( array_size ) + + if ( array_size <= min_run ) then + if ( array_size >= 2 ) call insertion_sort( array ) + return + end if + +! Following Rust sort, natural runs in `array` are identified by traversing +! it backwards. By traversing it backward, merges more often go in the +! opposite direction (forwards). According to developers of Rust sort, +! merging forwards is slightly faster than merging backwards. Therefore +! identifying runs by traversing backwards should improve performance. + r_count = 0 + finish = array_size - 1 + do while ( finish >= 0 ) +! Find the next natural run, and reverse it if it's strictly descending. + start = finish + if ( start > 0 ) then + start = start - 1 + if ( array(start+1) < array(start) ) then + Descending: do while ( start > 0 ) + if ( array(start) >= array(start-1) ) & + exit Descending + start = start - 1 + end do Descending + call reverse_segment( array(start:finish) ) + else + Ascending: do while( start > 0 ) + if ( array(start) < array(start-1) ) exit Ascending + start = start - 1 + end do Ascending + end if + end if + +! If the run is too short insert some more elements using an insertion sort. + Insert: do while ( start > 0 ) + if ( finish - start >= min_run - 1 ) exit Insert + start = start - 1 + call insert_head( array(start:finish) ) + end do Insert + if ( start == 0 .and. finish == array_size - 1 ) return + + runs(r_count) = run_type( base = start, & + len = finish - start + 1 ) + finish = start-1 + r_count = r_count + 1 + +! Determine whether pairs of adjacent runs need to be merged to satisfy +! the invariants, and, if so, merge them. + Merge_loop: do + r = collapse( runs(0:r_count - 1) ) + if ( r < 0 .or. r_count <= 1 ) exit Merge_loop + left = runs( r + 1 ) + right = runs( r ) + call merge( array( left % base: & + right % base + right % len - 1 ), & + left % len, buf ) + + runs(r) = run_type( base = left % base, & + len = left % len + right % len ) + if ( r == r_count - 3 ) runs(r+1) = runs(r+2) + r_count = r_count - 1 + + end do Merge_loop + end do + if ( r_count /= 1 ) & + error stop "MERGE_SORT completed without RUN COUNT == 1." + + end subroutine merge_sort + + + pure subroutine merge( array, mid, buf ) +! Merges the two non-decreasing runs `ARRAY(0:MID-1)` and `ARRAY(MID:)` +! using `BUF` as temporary storage, and stores the merged runs into +! `ARRAY(0:)`. `MID` must be > 0, and < `SIZE(ARRAY)-1`. Buffer `BUF` +! must be long enough to hold the shorter of the two runs. + integer(int64), intent(inout) :: array(0:) + integer(int_size), intent(in) :: mid + integer(int64), intent(inout) :: buf(0:) + + integer(int_size) :: array_len, i, j, k + + array_len = size(array, kind=int_size) + +! Merge first copies the shorter run into `buf`. Then, depending on which +! run was shorter, it traces the copied run and the longer run forwards +! (or backwards), comparing their next unprocessed elements and then +! copying the lesser (or greater) one into `array`. + + if ( mid <= array_len - mid ) then ! The left run is shorter. + buf(0:mid-1) = array(0:mid-1) + i = 0 + j = mid + merge_lower: do k = 0, array_len-1 + if ( buf(i) <= array(j) ) then + array(k) = buf(i) + i = i + 1 + if ( i >= mid ) exit merge_lower + else + array(k) = array(j) + j = j + 1 + if ( j >= array_len ) then + array(k+1:) = buf(i:mid-1) + exit merge_lower + end if + end if + end do merge_lower + else ! The right run is shorter ! check that it is stable + buf(0:array_len-mid-1) = array(mid:array_len-1) + i = mid - 1 + j = array_len - mid -1 + merge_upper: do k = array_len-1, 0, -1 + if ( buf(j) >= array(i) ) then + array(k) = buf(j) + j = j - 1 + if ( j < 0 ) exit merge_upper + else + array(k) = array(i) + i = i - 1 + if ( i < 0 ) then + array(0:k-1) = buf(0:j) + exit merge_upper + end if + end if + end do merge_upper + end if + end subroutine merge + + + pure subroutine reverse_segment( array ) +! Reverse a segment of an array in place + integer(int64), intent(inout) :: array(0:) + + integer(int_size) :: lo, hi + integer(int64) :: temp + + lo = 0 + hi = size( array, kind=int_size ) - 1 + do while( lo < hi ) + temp = array(lo) + array(lo) = array(hi) + array(hi) = temp + lo = lo + 1 + hi = hi - 1 + end do + + end subroutine reverse_segment + + end subroutine int64_increase_ord_sort + + + subroutine sp_increase_ord_sort( array, work ) +! A translation to Fortran 2008, of the `"Rust" sort` algorithm found in +! `slice.rs` +! https://github.com/rust-lang/rust/blob/90eb44a5897c39e3dff9c7e48e3973671dcd9496/src/liballoc/slice.rs#L2159 +! The Rust version in turn is a simplification of the Timsort algorithm +! described in +! https://svn.python.org/projects/python/trunk/Objects/listsort.txt, as +! it drops both the use of 'galloping' to identify bounds of regions to be +! sorted and the estimation of the optimal `run size`. However it remains +! a hybrid sorting algorithm combining an iterative Merge sort controlled +! by a stack of `RUNS` identified by regions of uniformly decreasing or +! non-decreasing sequences that may be expanded to a minimum run size and +! initially processed by an insertion sort. +! +! Note the Fortran implementation simplifies the logic as it only has to +! deal with Fortran arrays of intrinsic types and not the full generality +! of Rust's arrays and lists for arbitrary types. It also adds the +! estimation of the optimal `run size` as suggested in Tim Peters' +! original `listsort.txt`, and an optional `work` array to be used as +! scratch memory. + real(sp), intent(inout) :: array(0:) + real(sp), intent(out), optional :: work(0:) + + real(sp), allocatable :: buf(:) + integer(int_size) :: array_size + integer :: stat + + array_size = size( array, kind=int_size ) + if ( present(work) ) then + if ( size( work, kind=int_size) < array_size/2 ) then + error stop "sp_increase_ord_sort: work array is too small." + endif +! Use the work array as scratch memory + call merge_sort( array, work ) + else +! Allocate a buffer to use as scratch memory. + allocate( buf(0:array_size/2-1), stat=stat ) + if ( stat /= 0 ) error stop "sp_increase_ord_sort: Allocation of buffer failed." + call merge_sort( array, buf ) + end if + + contains + + pure function calc_min_run( n ) result(min_run) +!! Returns the minimum length of a run from 32-63 so that N/MIN_RUN is +!! less than or equal to a power of two. See +!! https://svn.python.org/projects/python/trunk/Objects/listsort.txt + integer(int_size) :: min_run + integer(int_size), intent(in) :: n + + integer(int_size) :: num, r + + num = n + r = 0_int_size + + do while( num >= 64 ) + r = ior( r, iand(num, 1_int_size) ) + num = ishft(num, -1_int_size) + end do + min_run = num + r + + end function calc_min_run + + + pure subroutine insertion_sort( array ) +! Sorts `ARRAY` using an insertion sort. + real(sp), intent(inout) :: array(0:) + + integer(int_size) :: i, j + real(sp) :: key + + do j=1, size(array, kind=int_size)-1 + key = array(j) + i = j - 1 + do while( i >= 0 ) + if ( array(i) <= key ) exit + array(i+1) = array(i) + i = i - 1 + end do + array(i+1) = key + end do + + end subroutine insertion_sort + + + pure function collapse( runs ) result ( r ) +! Examine the stack of runs waiting to be merged, identifying adjacent runs +! to be merged until the stack invariants are restablished: +! +! 1. len(-3) > len(-2) + len(-1) +! 2. len(-2) > len(-1) + integer(int_size) :: r + type(run_type), intent(in), target :: runs(0:) + + integer(int_size) :: n + logical :: test + + n = size(runs, kind=int_size) + test = .false. + if (n >= 2) then + if ( runs( n-1 ) % base == 0 .or. & + runs( n-2 ) % len <= runs(n-1) % len ) then + test = .true. + else if ( n >= 3 ) then ! X exists + if ( runs(n-3) % len <= & + runs(n-2) % len + runs(n-1) % len ) then + test = .true. +! |X| <= |Y| + |Z| => will need to merge due to rho1 or rho2 + else if( n >= 4 ) then + if ( runs(n-4) % len <= & + runs(n-3) % len + runs(n-2) % len ) then + test = .true. +! |W| <= |X| + |Y| => will need to merge due to rho1 or rho3 + end if + end if + end if + end if + if ( test ) then +! By default merge Y & Z, rho2 or rho3 + if ( n >= 3 ) then + if ( runs(n-3) % len < runs(n-1) % len ) then + r = n - 3 +! |X| < |Z| => merge X & Y, rho1 + return + end if + end if + r = n - 2 +! |Y| <= |Z| => merge Y & Z, rho4 + return + else + r = -1 + end if + + end function collapse + + + pure subroutine insert_head( array ) +! Inserts `array(0)` into the pre-sorted sequence `array(1:)` so that the +! whole `array(0:)` becomes sorted, copying the first element into +! a temporary variable, iterating until the right place for it is found. +! copying every traversed element into the slot preceding it, and finally, +! copying data from the temporary variable into the resulting hole. + + real(sp), intent(inout) :: array(0:) + + real(sp) :: tmp + integer(int_size) :: i + + tmp = array(0) + find_hole: do i=1, size(array, kind=int_size)-1 + if ( array(i) >= tmp ) exit find_hole + array(i-1) = array(i) + end do find_hole + array(i-1) = tmp + + end subroutine insert_head + + + subroutine merge_sort( array, buf ) +! The Rust merge sort borrows some (but not all) of the ideas from TimSort, +! which is described in detail at +! (http://svn.python.org/projects/python/trunk/Objects/listsort.txt). +! +! The algorithm identifies strictly descending and non-descending +! subsequences, which are called natural runs. Where these runs are less +! than a minimum run size they are padded by adding additional samples +! using an insertion sort. The merge process is driven by a stack of +! pending unmerged runs. Each newly found run is pushed onto the stack, +! and then pairs of adjacentd runs are merged until these two invariants +! are satisfied: +! +! 1. for every `i` in `1..size(runs)-1`: `runs(i - 1)%len > runs(i)%len` +! 2. for every `i` in `2..size(runs)-1`: `runs(i - 2)%len > +! runs(i - 1)%len + runs(i)%len` +! +! The invariants ensure that the total running time is `O(n log n)` +! worst-case. + + real(sp), intent(inout) :: array(0:) + real(sp), intent(inout) :: buf(0:) + + integer(int_size) :: array_size, finish, min_run, r, r_count, & + start + type(run_type) :: runs(0:max_merge_stack-1), left, right + + array_size = size(array, kind=int_size) + +! Very short runs are extended using insertion sort to span at least +! min_run elements. Slices of up to this length are sorted using insertion +! sort. + min_run = calc_min_run( array_size ) + + if ( array_size <= min_run ) then + if ( array_size >= 2 ) call insertion_sort( array ) + return + end if + +! Following Rust sort, natural runs in `array` are identified by traversing +! it backwards. By traversing it backward, merges more often go in the +! opposite direction (forwards). According to developers of Rust sort, +! merging forwards is slightly faster than merging backwards. Therefore +! identifying runs by traversing backwards should improve performance. + r_count = 0 + finish = array_size - 1 + do while ( finish >= 0 ) +! Find the next natural run, and reverse it if it's strictly descending. + start = finish + if ( start > 0 ) then + start = start - 1 + if ( array(start+1) < array(start) ) then + Descending: do while ( start > 0 ) + if ( array(start) >= array(start-1) ) & + exit Descending + start = start - 1 + end do Descending + call reverse_segment( array(start:finish) ) + else + Ascending: do while( start > 0 ) + if ( array(start) < array(start-1) ) exit Ascending + start = start - 1 + end do Ascending + end if + end if + +! If the run is too short insert some more elements using an insertion sort. + Insert: do while ( start > 0 ) + if ( finish - start >= min_run - 1 ) exit Insert + start = start - 1 + call insert_head( array(start:finish) ) + end do Insert + if ( start == 0 .and. finish == array_size - 1 ) return + + runs(r_count) = run_type( base = start, & + len = finish - start + 1 ) + finish = start-1 + r_count = r_count + 1 + +! Determine whether pairs of adjacent runs need to be merged to satisfy +! the invariants, and, if so, merge them. + Merge_loop: do + r = collapse( runs(0:r_count - 1) ) + if ( r < 0 .or. r_count <= 1 ) exit Merge_loop + left = runs( r + 1 ) + right = runs( r ) + call merge( array( left % base: & + right % base + right % len - 1 ), & + left % len, buf ) + + runs(r) = run_type( base = left % base, & + len = left % len + right % len ) + if ( r == r_count - 3 ) runs(r+1) = runs(r+2) + r_count = r_count - 1 + + end do Merge_loop + end do + if ( r_count /= 1 ) & + error stop "MERGE_SORT completed without RUN COUNT == 1." + + end subroutine merge_sort + + + pure subroutine merge( array, mid, buf ) +! Merges the two non-decreasing runs `ARRAY(0:MID-1)` and `ARRAY(MID:)` +! using `BUF` as temporary storage, and stores the merged runs into +! `ARRAY(0:)`. `MID` must be > 0, and < `SIZE(ARRAY)-1`. Buffer `BUF` +! must be long enough to hold the shorter of the two runs. + real(sp), intent(inout) :: array(0:) + integer(int_size), intent(in) :: mid + real(sp), intent(inout) :: buf(0:) + + integer(int_size) :: array_len, i, j, k + + array_len = size(array, kind=int_size) + +! Merge first copies the shorter run into `buf`. Then, depending on which +! run was shorter, it traces the copied run and the longer run forwards +! (or backwards), comparing their next unprocessed elements and then +! copying the lesser (or greater) one into `array`. + + if ( mid <= array_len - mid ) then ! The left run is shorter. + buf(0:mid-1) = array(0:mid-1) + i = 0 + j = mid + merge_lower: do k = 0, array_len-1 + if ( buf(i) <= array(j) ) then + array(k) = buf(i) + i = i + 1 + if ( i >= mid ) exit merge_lower + else + array(k) = array(j) + j = j + 1 + if ( j >= array_len ) then + array(k+1:) = buf(i:mid-1) + exit merge_lower + end if + end if + end do merge_lower + else ! The right run is shorter ! check that it is stable + buf(0:array_len-mid-1) = array(mid:array_len-1) + i = mid - 1 + j = array_len - mid -1 + merge_upper: do k = array_len-1, 0, -1 + if ( buf(j) >= array(i) ) then + array(k) = buf(j) + j = j - 1 + if ( j < 0 ) exit merge_upper + else + array(k) = array(i) + i = i - 1 + if ( i < 0 ) then + array(0:k-1) = buf(0:j) + exit merge_upper + end if + end if + end do merge_upper + end if + end subroutine merge + + + pure subroutine reverse_segment( array ) +! Reverse a segment of an array in place + real(sp), intent(inout) :: array(0:) + + integer(int_size) :: lo, hi + real(sp) :: temp + + lo = 0 + hi = size( array, kind=int_size ) - 1 + do while( lo < hi ) + temp = array(lo) + array(lo) = array(hi) + array(hi) = temp + lo = lo + 1 + hi = hi - 1 + end do + + end subroutine reverse_segment + + end subroutine sp_increase_ord_sort + + + subroutine dp_increase_ord_sort( array, work ) +! A translation to Fortran 2008, of the `"Rust" sort` algorithm found in +! `slice.rs` +! https://github.com/rust-lang/rust/blob/90eb44a5897c39e3dff9c7e48e3973671dcd9496/src/liballoc/slice.rs#L2159 +! The Rust version in turn is a simplification of the Timsort algorithm +! described in +! https://svn.python.org/projects/python/trunk/Objects/listsort.txt, as +! it drops both the use of 'galloping' to identify bounds of regions to be +! sorted and the estimation of the optimal `run size`. However it remains +! a hybrid sorting algorithm combining an iterative Merge sort controlled +! by a stack of `RUNS` identified by regions of uniformly decreasing or +! non-decreasing sequences that may be expanded to a minimum run size and +! initially processed by an insertion sort. +! +! Note the Fortran implementation simplifies the logic as it only has to +! deal with Fortran arrays of intrinsic types and not the full generality +! of Rust's arrays and lists for arbitrary types. It also adds the +! estimation of the optimal `run size` as suggested in Tim Peters' +! original `listsort.txt`, and an optional `work` array to be used as +! scratch memory. + real(dp), intent(inout) :: array(0:) + real(dp), intent(out), optional :: work(0:) + + real(dp), allocatable :: buf(:) + integer(int_size) :: array_size + integer :: stat + + array_size = size( array, kind=int_size ) + if ( present(work) ) then + if ( size( work, kind=int_size) < array_size/2 ) then + error stop "dp_increase_ord_sort: work array is too small." + endif +! Use the work array as scratch memory + call merge_sort( array, work ) + else +! Allocate a buffer to use as scratch memory. + allocate( buf(0:array_size/2-1), stat=stat ) + if ( stat /= 0 ) error stop "dp_increase_ord_sort: Allocation of buffer failed." + call merge_sort( array, buf ) + end if + + contains + + pure function calc_min_run( n ) result(min_run) +!! Returns the minimum length of a run from 32-63 so that N/MIN_RUN is +!! less than or equal to a power of two. See +!! https://svn.python.org/projects/python/trunk/Objects/listsort.txt + integer(int_size) :: min_run + integer(int_size), intent(in) :: n + + integer(int_size) :: num, r + + num = n + r = 0_int_size + + do while( num >= 64 ) + r = ior( r, iand(num, 1_int_size) ) + num = ishft(num, -1_int_size) + end do + min_run = num + r + + end function calc_min_run + + + pure subroutine insertion_sort( array ) +! Sorts `ARRAY` using an insertion sort. + real(dp), intent(inout) :: array(0:) + + integer(int_size) :: i, j + real(dp) :: key + + do j=1, size(array, kind=int_size)-1 + key = array(j) + i = j - 1 + do while( i >= 0 ) + if ( array(i) <= key ) exit + array(i+1) = array(i) + i = i - 1 + end do + array(i+1) = key + end do + + end subroutine insertion_sort + + + pure function collapse( runs ) result ( r ) +! Examine the stack of runs waiting to be merged, identifying adjacent runs +! to be merged until the stack invariants are restablished: +! +! 1. len(-3) > len(-2) + len(-1) +! 2. len(-2) > len(-1) + integer(int_size) :: r + type(run_type), intent(in), target :: runs(0:) + + integer(int_size) :: n + logical :: test + + n = size(runs, kind=int_size) + test = .false. + if (n >= 2) then + if ( runs( n-1 ) % base == 0 .or. & + runs( n-2 ) % len <= runs(n-1) % len ) then + test = .true. + else if ( n >= 3 ) then ! X exists + if ( runs(n-3) % len <= & + runs(n-2) % len + runs(n-1) % len ) then + test = .true. +! |X| <= |Y| + |Z| => will need to merge due to rho1 or rho2 + else if( n >= 4 ) then + if ( runs(n-4) % len <= & + runs(n-3) % len + runs(n-2) % len ) then + test = .true. +! |W| <= |X| + |Y| => will need to merge due to rho1 or rho3 + end if + end if + end if + end if + if ( test ) then +! By default merge Y & Z, rho2 or rho3 + if ( n >= 3 ) then + if ( runs(n-3) % len < runs(n-1) % len ) then + r = n - 3 +! |X| < |Z| => merge X & Y, rho1 + return + end if + end if + r = n - 2 +! |Y| <= |Z| => merge Y & Z, rho4 + return + else + r = -1 + end if + + end function collapse + + + pure subroutine insert_head( array ) +! Inserts `array(0)` into the pre-sorted sequence `array(1:)` so that the +! whole `array(0:)` becomes sorted, copying the first element into +! a temporary variable, iterating until the right place for it is found. +! copying every traversed element into the slot preceding it, and finally, +! copying data from the temporary variable into the resulting hole. + + real(dp), intent(inout) :: array(0:) + + real(dp) :: tmp + integer(int_size) :: i + + tmp = array(0) + find_hole: do i=1, size(array, kind=int_size)-1 + if ( array(i) >= tmp ) exit find_hole + array(i-1) = array(i) + end do find_hole + array(i-1) = tmp + + end subroutine insert_head + + + subroutine merge_sort( array, buf ) +! The Rust merge sort borrows some (but not all) of the ideas from TimSort, +! which is described in detail at +! (http://svn.python.org/projects/python/trunk/Objects/listsort.txt). +! +! The algorithm identifies strictly descending and non-descending +! subsequences, which are called natural runs. Where these runs are less +! than a minimum run size they are padded by adding additional samples +! using an insertion sort. The merge process is driven by a stack of +! pending unmerged runs. Each newly found run is pushed onto the stack, +! and then pairs of adjacentd runs are merged until these two invariants +! are satisfied: +! +! 1. for every `i` in `1..size(runs)-1`: `runs(i - 1)%len > runs(i)%len` +! 2. for every `i` in `2..size(runs)-1`: `runs(i - 2)%len > +! runs(i - 1)%len + runs(i)%len` +! +! The invariants ensure that the total running time is `O(n log n)` +! worst-case. + + real(dp), intent(inout) :: array(0:) + real(dp), intent(inout) :: buf(0:) + + integer(int_size) :: array_size, finish, min_run, r, r_count, & + start + type(run_type) :: runs(0:max_merge_stack-1), left, right + + array_size = size(array, kind=int_size) + +! Very short runs are extended using insertion sort to span at least +! min_run elements. Slices of up to this length are sorted using insertion +! sort. + min_run = calc_min_run( array_size ) + + if ( array_size <= min_run ) then + if ( array_size >= 2 ) call insertion_sort( array ) + return + end if + +! Following Rust sort, natural runs in `array` are identified by traversing +! it backwards. By traversing it backward, merges more often go in the +! opposite direction (forwards). According to developers of Rust sort, +! merging forwards is slightly faster than merging backwards. Therefore +! identifying runs by traversing backwards should improve performance. + r_count = 0 + finish = array_size - 1 + do while ( finish >= 0 ) +! Find the next natural run, and reverse it if it's strictly descending. + start = finish + if ( start > 0 ) then + start = start - 1 + if ( array(start+1) < array(start) ) then + Descending: do while ( start > 0 ) + if ( array(start) >= array(start-1) ) & + exit Descending + start = start - 1 + end do Descending + call reverse_segment( array(start:finish) ) + else + Ascending: do while( start > 0 ) + if ( array(start) < array(start-1) ) exit Ascending + start = start - 1 + end do Ascending + end if + end if + +! If the run is too short insert some more elements using an insertion sort. + Insert: do while ( start > 0 ) + if ( finish - start >= min_run - 1 ) exit Insert + start = start - 1 + call insert_head( array(start:finish) ) + end do Insert + if ( start == 0 .and. finish == array_size - 1 ) return + + runs(r_count) = run_type( base = start, & + len = finish - start + 1 ) + finish = start-1 + r_count = r_count + 1 + +! Determine whether pairs of adjacent runs need to be merged to satisfy +! the invariants, and, if so, merge them. + Merge_loop: do + r = collapse( runs(0:r_count - 1) ) + if ( r < 0 .or. r_count <= 1 ) exit Merge_loop + left = runs( r + 1 ) + right = runs( r ) + call merge( array( left % base: & + right % base + right % len - 1 ), & + left % len, buf ) + + runs(r) = run_type( base = left % base, & + len = left % len + right % len ) + if ( r == r_count - 3 ) runs(r+1) = runs(r+2) + r_count = r_count - 1 + + end do Merge_loop + end do + if ( r_count /= 1 ) & + error stop "MERGE_SORT completed without RUN COUNT == 1." + + end subroutine merge_sort + + + pure subroutine merge( array, mid, buf ) +! Merges the two non-decreasing runs `ARRAY(0:MID-1)` and `ARRAY(MID:)` +! using `BUF` as temporary storage, and stores the merged runs into +! `ARRAY(0:)`. `MID` must be > 0, and < `SIZE(ARRAY)-1`. Buffer `BUF` +! must be long enough to hold the shorter of the two runs. + real(dp), intent(inout) :: array(0:) + integer(int_size), intent(in) :: mid + real(dp), intent(inout) :: buf(0:) + + integer(int_size) :: array_len, i, j, k + + array_len = size(array, kind=int_size) + +! Merge first copies the shorter run into `buf`. Then, depending on which +! run was shorter, it traces the copied run and the longer run forwards +! (or backwards), comparing their next unprocessed elements and then +! copying the lesser (or greater) one into `array`. + + if ( mid <= array_len - mid ) then ! The left run is shorter. + buf(0:mid-1) = array(0:mid-1) + i = 0 + j = mid + merge_lower: do k = 0, array_len-1 + if ( buf(i) <= array(j) ) then + array(k) = buf(i) + i = i + 1 + if ( i >= mid ) exit merge_lower + else + array(k) = array(j) + j = j + 1 + if ( j >= array_len ) then + array(k+1:) = buf(i:mid-1) + exit merge_lower + end if + end if + end do merge_lower + else ! The right run is shorter ! check that it is stable + buf(0:array_len-mid-1) = array(mid:array_len-1) + i = mid - 1 + j = array_len - mid -1 + merge_upper: do k = array_len-1, 0, -1 + if ( buf(j) >= array(i) ) then + array(k) = buf(j) + j = j - 1 + if ( j < 0 ) exit merge_upper + else + array(k) = array(i) + i = i - 1 + if ( i < 0 ) then + array(0:k-1) = buf(0:j) + exit merge_upper + end if + end if + end do merge_upper + end if + end subroutine merge + + + pure subroutine reverse_segment( array ) +! Reverse a segment of an array in place + real(dp), intent(inout) :: array(0:) + + integer(int_size) :: lo, hi + real(dp) :: temp + + lo = 0 + hi = size( array, kind=int_size ) - 1 + do while( lo < hi ) + temp = array(lo) + array(lo) = array(hi) + array(hi) = temp + lo = lo + 1 + hi = hi - 1 + end do + + end subroutine reverse_segment + + end subroutine dp_increase_ord_sort + + + subroutine qp_increase_ord_sort( array, work ) +! A translation to Fortran 2008, of the `"Rust" sort` algorithm found in +! `slice.rs` +! https://github.com/rust-lang/rust/blob/90eb44a5897c39e3dff9c7e48e3973671dcd9496/src/liballoc/slice.rs#L2159 +! The Rust version in turn is a simplification of the Timsort algorithm +! described in +! https://svn.python.org/projects/python/trunk/Objects/listsort.txt, as +! it drops both the use of 'galloping' to identify bounds of regions to be +! sorted and the estimation of the optimal `run size`. However it remains +! a hybrid sorting algorithm combining an iterative Merge sort controlled +! by a stack of `RUNS` identified by regions of uniformly decreasing or +! non-decreasing sequences that may be expanded to a minimum run size and +! initially processed by an insertion sort. +! +! Note the Fortran implementation simplifies the logic as it only has to +! deal with Fortran arrays of intrinsic types and not the full generality +! of Rust's arrays and lists for arbitrary types. It also adds the +! estimation of the optimal `run size` as suggested in Tim Peters' +! original `listsort.txt`, and an optional `work` array to be used as +! scratch memory. + real(qp), intent(inout) :: array(0:) + real(qp), intent(out), optional :: work(0:) + + real(qp), allocatable :: buf(:) + integer(int_size) :: array_size + integer :: stat + + array_size = size( array, kind=int_size ) + if ( present(work) ) then + if ( size( work, kind=int_size) < array_size/2 ) then + error stop "qp_increase_ord_sort: work array is too small." + endif +! Use the work array as scratch memory + call merge_sort( array, work ) + else +! Allocate a buffer to use as scratch memory. + allocate( buf(0:array_size/2-1), stat=stat ) + if ( stat /= 0 ) error stop "qp_increase_ord_sort: Allocation of buffer failed." + call merge_sort( array, buf ) + end if + + contains + + pure function calc_min_run( n ) result(min_run) +!! Returns the minimum length of a run from 32-63 so that N/MIN_RUN is +!! less than or equal to a power of two. See +!! https://svn.python.org/projects/python/trunk/Objects/listsort.txt + integer(int_size) :: min_run + integer(int_size), intent(in) :: n + + integer(int_size) :: num, r + + num = n + r = 0_int_size + + do while( num >= 64 ) + r = ior( r, iand(num, 1_int_size) ) + num = ishft(num, -1_int_size) + end do + min_run = num + r + + end function calc_min_run + + + pure subroutine insertion_sort( array ) +! Sorts `ARRAY` using an insertion sort. + real(qp), intent(inout) :: array(0:) + + integer(int_size) :: i, j + real(qp) :: key + + do j=1, size(array, kind=int_size)-1 + key = array(j) + i = j - 1 + do while( i >= 0 ) + if ( array(i) <= key ) exit + array(i+1) = array(i) + i = i - 1 + end do + array(i+1) = key + end do + + end subroutine insertion_sort + + + pure function collapse( runs ) result ( r ) +! Examine the stack of runs waiting to be merged, identifying adjacent runs +! to be merged until the stack invariants are restablished: +! +! 1. len(-3) > len(-2) + len(-1) +! 2. len(-2) > len(-1) + integer(int_size) :: r + type(run_type), intent(in), target :: runs(0:) + + integer(int_size) :: n + logical :: test + + n = size(runs, kind=int_size) + test = .false. + if (n >= 2) then + if ( runs( n-1 ) % base == 0 .or. & + runs( n-2 ) % len <= runs(n-1) % len ) then + test = .true. + else if ( n >= 3 ) then ! X exists + if ( runs(n-3) % len <= & + runs(n-2) % len + runs(n-1) % len ) then + test = .true. +! |X| <= |Y| + |Z| => will need to merge due to rho1 or rho2 + else if( n >= 4 ) then + if ( runs(n-4) % len <= & + runs(n-3) % len + runs(n-2) % len ) then + test = .true. +! |W| <= |X| + |Y| => will need to merge due to rho1 or rho3 + end if + end if + end if + end if + if ( test ) then +! By default merge Y & Z, rho2 or rho3 + if ( n >= 3 ) then + if ( runs(n-3) % len < runs(n-1) % len ) then + r = n - 3 +! |X| < |Z| => merge X & Y, rho1 + return + end if + end if + r = n - 2 +! |Y| <= |Z| => merge Y & Z, rho4 + return + else + r = -1 + end if + + end function collapse + + + pure subroutine insert_head( array ) +! Inserts `array(0)` into the pre-sorted sequence `array(1:)` so that the +! whole `array(0:)` becomes sorted, copying the first element into +! a temporary variable, iterating until the right place for it is found. +! copying every traversed element into the slot preceding it, and finally, +! copying data from the temporary variable into the resulting hole. + + real(qp), intent(inout) :: array(0:) + + real(qp) :: tmp + integer(int_size) :: i + + tmp = array(0) + find_hole: do i=1, size(array, kind=int_size)-1 + if ( array(i) >= tmp ) exit find_hole + array(i-1) = array(i) + end do find_hole + array(i-1) = tmp + + end subroutine insert_head + + + subroutine merge_sort( array, buf ) +! The Rust merge sort borrows some (but not all) of the ideas from TimSort, +! which is described in detail at +! (http://svn.python.org/projects/python/trunk/Objects/listsort.txt). +! +! The algorithm identifies strictly descending and non-descending +! subsequences, which are called natural runs. Where these runs are less +! than a minimum run size they are padded by adding additional samples +! using an insertion sort. The merge process is driven by a stack of +! pending unmerged runs. Each newly found run is pushed onto the stack, +! and then pairs of adjacentd runs are merged until these two invariants +! are satisfied: +! +! 1. for every `i` in `1..size(runs)-1`: `runs(i - 1)%len > runs(i)%len` +! 2. for every `i` in `2..size(runs)-1`: `runs(i - 2)%len > +! runs(i - 1)%len + runs(i)%len` +! +! The invariants ensure that the total running time is `O(n log n)` +! worst-case. + + real(qp), intent(inout) :: array(0:) + real(qp), intent(inout) :: buf(0:) + + integer(int_size) :: array_size, finish, min_run, r, r_count, & + start + type(run_type) :: runs(0:max_merge_stack-1), left, right + + array_size = size(array, kind=int_size) + +! Very short runs are extended using insertion sort to span at least +! min_run elements. Slices of up to this length are sorted using insertion +! sort. + min_run = calc_min_run( array_size ) + + if ( array_size <= min_run ) then + if ( array_size >= 2 ) call insertion_sort( array ) + return + end if + +! Following Rust sort, natural runs in `array` are identified by traversing +! it backwards. By traversing it backward, merges more often go in the +! opposite direction (forwards). According to developers of Rust sort, +! merging forwards is slightly faster than merging backwards. Therefore +! identifying runs by traversing backwards should improve performance. + r_count = 0 + finish = array_size - 1 + do while ( finish >= 0 ) +! Find the next natural run, and reverse it if it's strictly descending. + start = finish + if ( start > 0 ) then + start = start - 1 + if ( array(start+1) < array(start) ) then + Descending: do while ( start > 0 ) + if ( array(start) >= array(start-1) ) & + exit Descending + start = start - 1 + end do Descending + call reverse_segment( array(start:finish) ) + else + Ascending: do while( start > 0 ) + if ( array(start) < array(start-1) ) exit Ascending + start = start - 1 + end do Ascending + end if + end if + +! If the run is too short insert some more elements using an insertion sort. + Insert: do while ( start > 0 ) + if ( finish - start >= min_run - 1 ) exit Insert + start = start - 1 + call insert_head( array(start:finish) ) + end do Insert + if ( start == 0 .and. finish == array_size - 1 ) return + + runs(r_count) = run_type( base = start, & + len = finish - start + 1 ) + finish = start-1 + r_count = r_count + 1 + +! Determine whether pairs of adjacent runs need to be merged to satisfy +! the invariants, and, if so, merge them. + Merge_loop: do + r = collapse( runs(0:r_count - 1) ) + if ( r < 0 .or. r_count <= 1 ) exit Merge_loop + left = runs( r + 1 ) + right = runs( r ) + call merge( array( left % base: & + right % base + right % len - 1 ), & + left % len, buf ) + + runs(r) = run_type( base = left % base, & + len = left % len + right % len ) + if ( r == r_count - 3 ) runs(r+1) = runs(r+2) + r_count = r_count - 1 + + end do Merge_loop + end do + if ( r_count /= 1 ) & + error stop "MERGE_SORT completed without RUN COUNT == 1." + + end subroutine merge_sort + + + pure subroutine merge( array, mid, buf ) +! Merges the two non-decreasing runs `ARRAY(0:MID-1)` and `ARRAY(MID:)` +! using `BUF` as temporary storage, and stores the merged runs into +! `ARRAY(0:)`. `MID` must be > 0, and < `SIZE(ARRAY)-1`. Buffer `BUF` +! must be long enough to hold the shorter of the two runs. + real(qp), intent(inout) :: array(0:) + integer(int_size), intent(in) :: mid + real(qp), intent(inout) :: buf(0:) + + integer(int_size) :: array_len, i, j, k + + array_len = size(array, kind=int_size) + +! Merge first copies the shorter run into `buf`. Then, depending on which +! run was shorter, it traces the copied run and the longer run forwards +! (or backwards), comparing their next unprocessed elements and then +! copying the lesser (or greater) one into `array`. + + if ( mid <= array_len - mid ) then ! The left run is shorter. + buf(0:mid-1) = array(0:mid-1) + i = 0 + j = mid + merge_lower: do k = 0, array_len-1 + if ( buf(i) <= array(j) ) then + array(k) = buf(i) + i = i + 1 + if ( i >= mid ) exit merge_lower + else + array(k) = array(j) + j = j + 1 + if ( j >= array_len ) then + array(k+1:) = buf(i:mid-1) + exit merge_lower + end if + end if + end do merge_lower + else ! The right run is shorter ! check that it is stable + buf(0:array_len-mid-1) = array(mid:array_len-1) + i = mid - 1 + j = array_len - mid -1 + merge_upper: do k = array_len-1, 0, -1 + if ( buf(j) >= array(i) ) then + array(k) = buf(j) + j = j - 1 + if ( j < 0 ) exit merge_upper + else + array(k) = array(i) + i = i - 1 + if ( i < 0 ) then + array(0:k-1) = buf(0:j) + exit merge_upper + end if + end if + end do merge_upper + end if + end subroutine merge + + + pure subroutine reverse_segment( array ) +! Reverse a segment of an array in place + real(qp), intent(inout) :: array(0:) + + integer(int_size) :: lo, hi + real(qp) :: temp + + lo = 0 + hi = size( array, kind=int_size ) - 1 + do while( lo < hi ) + temp = array(lo) + array(lo) = array(hi) + array(hi) = temp + lo = lo + 1 + hi = hi - 1 + end do + + end subroutine reverse_segment + + end subroutine qp_increase_ord_sort + + + subroutine string_type_increase_ord_sort( array, work ) +! A translation to Fortran 2008, of the `"Rust" sort` algorithm found in +! `slice.rs` +! https://github.com/rust-lang/rust/blob/90eb44a5897c39e3dff9c7e48e3973671dcd9496/src/liballoc/slice.rs#L2159 +! The Rust version in turn is a simplification of the Timsort algorithm +! described in +! https://svn.python.org/projects/python/trunk/Objects/listsort.txt, as +! it drops both the use of 'galloping' to identify bounds of regions to be +! sorted and the estimation of the optimal `run size`. However it remains +! a hybrid sorting algorithm combining an iterative Merge sort controlled +! by a stack of `RUNS` identified by regions of uniformly decreasing or +! non-decreasing sequences that may be expanded to a minimum run size and +! initially processed by an insertion sort. +! +! Note the Fortran implementation simplifies the logic as it only has to +! deal with Fortran arrays of intrinsic types and not the full generality +! of Rust's arrays and lists for arbitrary types. It also adds the +! estimation of the optimal `run size` as suggested in Tim Peters' +! original `listsort.txt`, and an optional `work` array to be used as +! scratch memory. + type(string_type), intent(inout) :: array(0:) + type(string_type), intent(out), optional :: work(0:) + + type(string_type), allocatable :: buf(:) + integer(int_size) :: array_size + integer :: stat + + array_size = size( array, kind=int_size ) + if ( present(work) ) then + if ( size( work, kind=int_size) < array_size/2 ) then + error stop "string_type_increase_ord_sort: work array is too small." + endif +! Use the work array as scratch memory + call merge_sort( array, work ) + else +! Allocate a buffer to use as scratch memory. + allocate( buf(0:array_size/2-1), stat=stat ) + if ( stat /= 0 ) error stop "string_type_increase_ord_sort: Allocation of buffer failed." + call merge_sort( array, buf ) + end if + + contains + + pure function calc_min_run( n ) result(min_run) +!! Returns the minimum length of a run from 32-63 so that N/MIN_RUN is +!! less than or equal to a power of two. See +!! https://svn.python.org/projects/python/trunk/Objects/listsort.txt + integer(int_size) :: min_run + integer(int_size), intent(in) :: n + + integer(int_size) :: num, r + + num = n + r = 0_int_size + + do while( num >= 64 ) + r = ior( r, iand(num, 1_int_size) ) + num = ishft(num, -1_int_size) + end do + min_run = num + r + + end function calc_min_run + + + pure subroutine insertion_sort( array ) +! Sorts `ARRAY` using an insertion sort. + type(string_type), intent(inout) :: array(0:) + + integer(int_size) :: i, j + type(string_type) :: key + + do j=1, size(array, kind=int_size)-1 + key = array(j) + i = j - 1 + do while( i >= 0 ) + if ( array(i) <= key ) exit + array(i+1) = array(i) + i = i - 1 + end do + array(i+1) = key + end do + + end subroutine insertion_sort + + + pure function collapse( runs ) result ( r ) +! Examine the stack of runs waiting to be merged, identifying adjacent runs +! to be merged until the stack invariants are restablished: +! +! 1. len(-3) > len(-2) + len(-1) +! 2. len(-2) > len(-1) + integer(int_size) :: r + type(run_type), intent(in), target :: runs(0:) + + integer(int_size) :: n + logical :: test + + n = size(runs, kind=int_size) + test = .false. + if (n >= 2) then + if ( runs( n-1 ) % base == 0 .or. & + runs( n-2 ) % len <= runs(n-1) % len ) then + test = .true. + else if ( n >= 3 ) then ! X exists + if ( runs(n-3) % len <= & + runs(n-2) % len + runs(n-1) % len ) then + test = .true. +! |X| <= |Y| + |Z| => will need to merge due to rho1 or rho2 + else if( n >= 4 ) then + if ( runs(n-4) % len <= & + runs(n-3) % len + runs(n-2) % len ) then + test = .true. +! |W| <= |X| + |Y| => will need to merge due to rho1 or rho3 + end if + end if + end if + end if + if ( test ) then +! By default merge Y & Z, rho2 or rho3 + if ( n >= 3 ) then + if ( runs(n-3) % len < runs(n-1) % len ) then + r = n - 3 +! |X| < |Z| => merge X & Y, rho1 + return + end if + end if + r = n - 2 +! |Y| <= |Z| => merge Y & Z, rho4 + return + else + r = -1 + end if + + end function collapse + + + pure subroutine insert_head( array ) +! Inserts `array(0)` into the pre-sorted sequence `array(1:)` so that the +! whole `array(0:)` becomes sorted, copying the first element into +! a temporary variable, iterating until the right place for it is found. +! copying every traversed element into the slot preceding it, and finally, +! copying data from the temporary variable into the resulting hole. + + type(string_type), intent(inout) :: array(0:) + + type(string_type) :: tmp + integer(int_size) :: i + + tmp = array(0) + find_hole: do i=1, size(array, kind=int_size)-1 + if ( array(i) >= tmp ) exit find_hole + array(i-1) = array(i) + end do find_hole + array(i-1) = tmp + + end subroutine insert_head + + + subroutine merge_sort( array, buf ) +! The Rust merge sort borrows some (but not all) of the ideas from TimSort, +! which is described in detail at +! (http://svn.python.org/projects/python/trunk/Objects/listsort.txt). +! +! The algorithm identifies strictly descending and non-descending +! subsequences, which are called natural runs. Where these runs are less +! than a minimum run size they are padded by adding additional samples +! using an insertion sort. The merge process is driven by a stack of +! pending unmerged runs. Each newly found run is pushed onto the stack, +! and then pairs of adjacentd runs are merged until these two invariants +! are satisfied: +! +! 1. for every `i` in `1..size(runs)-1`: `runs(i - 1)%len > runs(i)%len` +! 2. for every `i` in `2..size(runs)-1`: `runs(i - 2)%len > +! runs(i - 1)%len + runs(i)%len` +! +! The invariants ensure that the total running time is `O(n log n)` +! worst-case. + + type(string_type), intent(inout) :: array(0:) + type(string_type), intent(inout) :: buf(0:) + + integer(int_size) :: array_size, finish, min_run, r, r_count, & + start + type(run_type) :: runs(0:max_merge_stack-1), left, right + + array_size = size(array, kind=int_size) + +! Very short runs are extended using insertion sort to span at least +! min_run elements. Slices of up to this length are sorted using insertion +! sort. + min_run = calc_min_run( array_size ) + + if ( array_size <= min_run ) then + if ( array_size >= 2 ) call insertion_sort( array ) + return + end if + +! Following Rust sort, natural runs in `array` are identified by traversing +! it backwards. By traversing it backward, merges more often go in the +! opposite direction (forwards). According to developers of Rust sort, +! merging forwards is slightly faster than merging backwards. Therefore +! identifying runs by traversing backwards should improve performance. + r_count = 0 + finish = array_size - 1 + do while ( finish >= 0 ) +! Find the next natural run, and reverse it if it's strictly descending. + start = finish + if ( start > 0 ) then + start = start - 1 + if ( array(start+1) < array(start) ) then + Descending: do while ( start > 0 ) + if ( array(start) >= array(start-1) ) & + exit Descending + start = start - 1 + end do Descending + call reverse_segment( array(start:finish) ) + else + Ascending: do while( start > 0 ) + if ( array(start) < array(start-1) ) exit Ascending + start = start - 1 + end do Ascending + end if + end if + +! If the run is too short insert some more elements using an insertion sort. + Insert: do while ( start > 0 ) + if ( finish - start >= min_run - 1 ) exit Insert + start = start - 1 + call insert_head( array(start:finish) ) + end do Insert + if ( start == 0 .and. finish == array_size - 1 ) return + + runs(r_count) = run_type( base = start, & + len = finish - start + 1 ) + finish = start-1 + r_count = r_count + 1 + +! Determine whether pairs of adjacent runs need to be merged to satisfy +! the invariants, and, if so, merge them. + Merge_loop: do + r = collapse( runs(0:r_count - 1) ) + if ( r < 0 .or. r_count <= 1 ) exit Merge_loop + left = runs( r + 1 ) + right = runs( r ) + call merge( array( left % base: & + right % base + right % len - 1 ), & + left % len, buf ) + + runs(r) = run_type( base = left % base, & + len = left % len + right % len ) + if ( r == r_count - 3 ) runs(r+1) = runs(r+2) + r_count = r_count - 1 + + end do Merge_loop + end do + if ( r_count /= 1 ) & + error stop "MERGE_SORT completed without RUN COUNT == 1." + + end subroutine merge_sort + + + pure subroutine merge( array, mid, buf ) +! Merges the two non-decreasing runs `ARRAY(0:MID-1)` and `ARRAY(MID:)` +! using `BUF` as temporary storage, and stores the merged runs into +! `ARRAY(0:)`. `MID` must be > 0, and < `SIZE(ARRAY)-1`. Buffer `BUF` +! must be long enough to hold the shorter of the two runs. + type(string_type), intent(inout) :: array(0:) + integer(int_size), intent(in) :: mid + type(string_type), intent(inout) :: buf(0:) + + integer(int_size) :: array_len, i, j, k + + array_len = size(array, kind=int_size) + +! Merge first copies the shorter run into `buf`. Then, depending on which +! run was shorter, it traces the copied run and the longer run forwards +! (or backwards), comparing their next unprocessed elements and then +! copying the lesser (or greater) one into `array`. + + if ( mid <= array_len - mid ) then ! The left run is shorter. + buf(0:mid-1) = array(0:mid-1) + i = 0 + j = mid + merge_lower: do k = 0, array_len-1 + if ( buf(i) <= array(j) ) then + array(k) = buf(i) + i = i + 1 + if ( i >= mid ) exit merge_lower + else + array(k) = array(j) + j = j + 1 + if ( j >= array_len ) then + array(k+1:) = buf(i:mid-1) + exit merge_lower + end if + end if + end do merge_lower + else ! The right run is shorter ! check that it is stable + buf(0:array_len-mid-1) = array(mid:array_len-1) + i = mid - 1 + j = array_len - mid -1 + merge_upper: do k = array_len-1, 0, -1 + if ( buf(j) >= array(i) ) then + array(k) = buf(j) + j = j - 1 + if ( j < 0 ) exit merge_upper + else + array(k) = array(i) + i = i - 1 + if ( i < 0 ) then + array(0:k-1) = buf(0:j) + exit merge_upper + end if + end if + end do merge_upper + end if + end subroutine merge + + + pure subroutine reverse_segment( array ) +! Reverse a segment of an array in place + type(string_type), intent(inout) :: array(0:) + + integer(int_size) :: lo, hi + type(string_type) :: temp + + lo = 0 + hi = size( array, kind=int_size ) - 1 + do while( lo < hi ) + temp = array(lo) + array(lo) = array(hi) + array(hi) = temp + lo = lo + 1 + hi = hi - 1 + end do + + end subroutine reverse_segment + + end subroutine string_type_increase_ord_sort + + + subroutine int8_decrease_ord_sort( array, work ) +! A translation to Fortran 2008, of the `"Rust" sort` algorithm found in +! `slice.rs` +! https://github.com/rust-lang/rust/blob/90eb44a5897c39e3dff9c7e48e3973671dcd9496/src/liballoc/slice.rs#L2159 +! The Rust version in turn is a simplification of the Timsort algorithm +! described in +! https://svn.python.org/projects/python/trunk/Objects/listsort.txt, as +! it drops both the use of 'galloping' to identify bounds of regions to be +! sorted and the estimation of the optimal `run size`. However it remains +! a hybrid sorting algorithm combining an iterative Merge sort controlled +! by a stack of `RUNS` identified by regions of uniformly decreasing or +! non-decreasing sequences that may be expanded to a minimum run size and +! initially processed by an insertion sort. +! +! Note the Fortran implementation simplifies the logic as it only has to +! deal with Fortran arrays of intrinsic types and not the full generality +! of Rust's arrays and lists for arbitrary types. It also adds the +! estimation of the optimal `run size` as suggested in Tim Peters' +! original `listsort.txt`, and an optional `work` array to be used as +! scratch memory. + integer(int8), intent(inout) :: array(0:) + integer(int8), intent(out), optional :: work(0:) + + integer(int8), allocatable :: buf(:) + integer(int_size) :: array_size + integer :: stat + + array_size = size( array, kind=int_size ) + if ( present(work) ) then + if ( size( work, kind=int_size) < array_size/2 ) then + error stop "int8_decrease_ord_sort: work array is too small." + endif +! Use the work array as scratch memory + call merge_sort( array, work ) + else +! Allocate a buffer to use as scratch memory. + allocate( buf(0:array_size/2-1), stat=stat ) + if ( stat /= 0 ) error stop "int8_decrease_ord_sort: Allocation of buffer failed." + call merge_sort( array, buf ) + end if + + contains + + pure function calc_min_run( n ) result(min_run) +!! Returns the minimum length of a run from 32-63 so that N/MIN_RUN is +!! less than or equal to a power of two. See +!! https://svn.python.org/projects/python/trunk/Objects/listsort.txt + integer(int_size) :: min_run + integer(int_size), intent(in) :: n + + integer(int_size) :: num, r + + num = n + r = 0_int_size + + do while( num >= 64 ) + r = ior( r, iand(num, 1_int_size) ) + num = ishft(num, -1_int_size) + end do + min_run = num + r + + end function calc_min_run + + + pure subroutine insertion_sort( array ) +! Sorts `ARRAY` using an insertion sort. + integer(int8), intent(inout) :: array(0:) + + integer(int_size) :: i, j + integer(int8) :: key + + do j=1, size(array, kind=int_size)-1 + key = array(j) + i = j - 1 + do while( i >= 0 ) + if ( array(i) >= key ) exit + array(i+1) = array(i) + i = i - 1 + end do + array(i+1) = key + end do + + end subroutine insertion_sort + + + pure function collapse( runs ) result ( r ) +! Examine the stack of runs waiting to be merged, identifying adjacent runs +! to be merged until the stack invariants are restablished: +! +! 1. len(-3) > len(-2) + len(-1) +! 2. len(-2) > len(-1) + integer(int_size) :: r + type(run_type), intent(in), target :: runs(0:) + + integer(int_size) :: n + logical :: test + + n = size(runs, kind=int_size) + test = .false. + if (n >= 2) then + if ( runs( n-1 ) % base == 0 .or. & + runs( n-2 ) % len <= runs(n-1) % len ) then + test = .true. + else if ( n >= 3 ) then ! X exists + if ( runs(n-3) % len <= & + runs(n-2) % len + runs(n-1) % len ) then + test = .true. +! |X| <= |Y| + |Z| => will need to merge due to rho1 or rho2 + else if( n >= 4 ) then + if ( runs(n-4) % len <= & + runs(n-3) % len + runs(n-2) % len ) then + test = .true. +! |W| <= |X| + |Y| => will need to merge due to rho1 or rho3 + end if + end if + end if + end if + if ( test ) then +! By default merge Y & Z, rho2 or rho3 + if ( n >= 3 ) then + if ( runs(n-3) % len < runs(n-1) % len ) then + r = n - 3 +! |X| < |Z| => merge X & Y, rho1 + return + end if + end if + r = n - 2 +! |Y| <= |Z| => merge Y & Z, rho4 + return + else + r = -1 + end if + + end function collapse + + + pure subroutine insert_head( array ) +! Inserts `array(0)` into the pre-sorted sequence `array(1:)` so that the +! whole `array(0:)` becomes sorted, copying the first element into +! a temporary variable, iterating until the right place for it is found. +! copying every traversed element into the slot preceding it, and finally, +! copying data from the temporary variable into the resulting hole. + + integer(int8), intent(inout) :: array(0:) + + integer(int8) :: tmp + integer(int_size) :: i + + tmp = array(0) + find_hole: do i=1, size(array, kind=int_size)-1 + if ( array(i) <= tmp ) exit find_hole + array(i-1) = array(i) + end do find_hole + array(i-1) = tmp + + end subroutine insert_head + + + subroutine merge_sort( array, buf ) +! The Rust merge sort borrows some (but not all) of the ideas from TimSort, +! which is described in detail at +! (http://svn.python.org/projects/python/trunk/Objects/listsort.txt). +! +! The algorithm identifies strictly descending and non-descending +! subsequences, which are called natural runs. Where these runs are less +! than a minimum run size they are padded by adding additional samples +! using an insertion sort. The merge process is driven by a stack of +! pending unmerged runs. Each newly found run is pushed onto the stack, +! and then pairs of adjacentd runs are merged until these two invariants +! are satisfied: +! +! 1. for every `i` in `1..size(runs)-1`: `runs(i - 1)%len > runs(i)%len` +! 2. for every `i` in `2..size(runs)-1`: `runs(i - 2)%len > +! runs(i - 1)%len + runs(i)%len` +! +! The invariants ensure that the total running time is `O(n log n)` +! worst-case. + + integer(int8), intent(inout) :: array(0:) + integer(int8), intent(inout) :: buf(0:) + + integer(int_size) :: array_size, finish, min_run, r, r_count, & + start + type(run_type) :: runs(0:max_merge_stack-1), left, right + + array_size = size(array, kind=int_size) + +! Very short runs are extended using insertion sort to span at least +! min_run elements. Slices of up to this length are sorted using insertion +! sort. + min_run = calc_min_run( array_size ) + + if ( array_size <= min_run ) then + if ( array_size >= 2 ) call insertion_sort( array ) + return + end if + +! Following Rust sort, natural runs in `array` are identified by traversing +! it backwards. By traversing it backward, merges more often go in the +! opposite direction (forwards). According to developers of Rust sort, +! merging forwards is slightly faster than merging backwards. Therefore +! identifying runs by traversing backwards should improve performance. + r_count = 0 + finish = array_size - 1 + do while ( finish >= 0 ) +! Find the next natural run, and reverse it if it's strictly descending. + start = finish + if ( start > 0 ) then + start = start - 1 + if ( array(start+1) > array(start) ) then + Descending: do while ( start > 0 ) + if ( array(start) <= array(start-1) ) & + exit Descending + start = start - 1 + end do Descending + call reverse_segment( array(start:finish) ) + else + Ascending: do while( start > 0 ) + if ( array(start) > array(start-1) ) exit Ascending + start = start - 1 + end do Ascending + end if + end if + +! If the run is too short insert some more elements using an insertion sort. + Insert: do while ( start > 0 ) + if ( finish - start >= min_run - 1 ) exit Insert + start = start - 1 + call insert_head( array(start:finish) ) + end do Insert + if ( start == 0 .and. finish == array_size - 1 ) return + + runs(r_count) = run_type( base = start, & + len = finish - start + 1 ) + finish = start-1 + r_count = r_count + 1 + +! Determine whether pairs of adjacent runs need to be merged to satisfy +! the invariants, and, if so, merge them. + Merge_loop: do + r = collapse( runs(0:r_count - 1) ) + if ( r < 0 .or. r_count <= 1 ) exit Merge_loop + left = runs( r + 1 ) + right = runs( r ) + call merge( array( left % base: & + right % base + right % len - 1 ), & + left % len, buf ) + + runs(r) = run_type( base = left % base, & + len = left % len + right % len ) + if ( r == r_count - 3 ) runs(r+1) = runs(r+2) + r_count = r_count - 1 + + end do Merge_loop + end do + if ( r_count /= 1 ) & + error stop "MERGE_SORT completed without RUN COUNT == 1." + + end subroutine merge_sort + + + pure subroutine merge( array, mid, buf ) +! Merges the two non-decreasing runs `ARRAY(0:MID-1)` and `ARRAY(MID:)` +! using `BUF` as temporary storage, and stores the merged runs into +! `ARRAY(0:)`. `MID` must be > 0, and < `SIZE(ARRAY)-1`. Buffer `BUF` +! must be long enough to hold the shorter of the two runs. + integer(int8), intent(inout) :: array(0:) + integer(int_size), intent(in) :: mid + integer(int8), intent(inout) :: buf(0:) + + integer(int_size) :: array_len, i, j, k + + array_len = size(array, kind=int_size) + +! Merge first copies the shorter run into `buf`. Then, depending on which +! run was shorter, it traces the copied run and the longer run forwards +! (or backwards), comparing their next unprocessed elements and then +! copying the lesser (or greater) one into `array`. + + if ( mid <= array_len - mid ) then ! The left run is shorter. + buf(0:mid-1) = array(0:mid-1) + i = 0 + j = mid + merge_lower: do k = 0, array_len-1 + if ( buf(i) >= array(j) ) then + array(k) = buf(i) + i = i + 1 + if ( i >= mid ) exit merge_lower + else + array(k) = array(j) + j = j + 1 + if ( j >= array_len ) then + array(k+1:) = buf(i:mid-1) + exit merge_lower + end if + end if + end do merge_lower + else ! The right run is shorter ! check that it is stable + buf(0:array_len-mid-1) = array(mid:array_len-1) + i = mid - 1 + j = array_len - mid -1 + merge_upper: do k = array_len-1, 0, -1 + if ( buf(j) <= array(i) ) then + array(k) = buf(j) + j = j - 1 + if ( j < 0 ) exit merge_upper + else + array(k) = array(i) + i = i - 1 + if ( i < 0 ) then + array(0:k-1) = buf(0:j) + exit merge_upper + end if + end if + end do merge_upper + end if + end subroutine merge + + + pure subroutine reverse_segment( array ) +! Reverse a segment of an array in place + integer(int8), intent(inout) :: array(0:) + + integer(int_size) :: lo, hi + integer(int8) :: temp + + lo = 0 + hi = size( array, kind=int_size ) - 1 + do while( lo < hi ) + temp = array(lo) + array(lo) = array(hi) + array(hi) = temp + lo = lo + 1 + hi = hi - 1 + end do + + end subroutine reverse_segment + + end subroutine int8_decrease_ord_sort + + + subroutine int16_decrease_ord_sort( array, work ) +! A translation to Fortran 2008, of the `"Rust" sort` algorithm found in +! `slice.rs` +! https://github.com/rust-lang/rust/blob/90eb44a5897c39e3dff9c7e48e3973671dcd9496/src/liballoc/slice.rs#L2159 +! The Rust version in turn is a simplification of the Timsort algorithm +! described in +! https://svn.python.org/projects/python/trunk/Objects/listsort.txt, as +! it drops both the use of 'galloping' to identify bounds of regions to be +! sorted and the estimation of the optimal `run size`. However it remains +! a hybrid sorting algorithm combining an iterative Merge sort controlled +! by a stack of `RUNS` identified by regions of uniformly decreasing or +! non-decreasing sequences that may be expanded to a minimum run size and +! initially processed by an insertion sort. +! +! Note the Fortran implementation simplifies the logic as it only has to +! deal with Fortran arrays of intrinsic types and not the full generality +! of Rust's arrays and lists for arbitrary types. It also adds the +! estimation of the optimal `run size` as suggested in Tim Peters' +! original `listsort.txt`, and an optional `work` array to be used as +! scratch memory. + integer(int16), intent(inout) :: array(0:) + integer(int16), intent(out), optional :: work(0:) + + integer(int16), allocatable :: buf(:) + integer(int_size) :: array_size + integer :: stat + + array_size = size( array, kind=int_size ) + if ( present(work) ) then + if ( size( work, kind=int_size) < array_size/2 ) then + error stop "int16_decrease_ord_sort: work array is too small." + endif +! Use the work array as scratch memory + call merge_sort( array, work ) + else +! Allocate a buffer to use as scratch memory. + allocate( buf(0:array_size/2-1), stat=stat ) + if ( stat /= 0 ) error stop "int16_decrease_ord_sort: Allocation of buffer failed." + call merge_sort( array, buf ) + end if + + contains + + pure function calc_min_run( n ) result(min_run) +!! Returns the minimum length of a run from 32-63 so that N/MIN_RUN is +!! less than or equal to a power of two. See +!! https://svn.python.org/projects/python/trunk/Objects/listsort.txt + integer(int_size) :: min_run + integer(int_size), intent(in) :: n + + integer(int_size) :: num, r + + num = n + r = 0_int_size + + do while( num >= 64 ) + r = ior( r, iand(num, 1_int_size) ) + num = ishft(num, -1_int_size) + end do + min_run = num + r + + end function calc_min_run + + + pure subroutine insertion_sort( array ) +! Sorts `ARRAY` using an insertion sort. + integer(int16), intent(inout) :: array(0:) + + integer(int_size) :: i, j + integer(int16) :: key + + do j=1, size(array, kind=int_size)-1 + key = array(j) + i = j - 1 + do while( i >= 0 ) + if ( array(i) >= key ) exit + array(i+1) = array(i) + i = i - 1 + end do + array(i+1) = key + end do + + end subroutine insertion_sort + + + pure function collapse( runs ) result ( r ) +! Examine the stack of runs waiting to be merged, identifying adjacent runs +! to be merged until the stack invariants are restablished: +! +! 1. len(-3) > len(-2) + len(-1) +! 2. len(-2) > len(-1) + integer(int_size) :: r + type(run_type), intent(in), target :: runs(0:) + + integer(int_size) :: n + logical :: test + + n = size(runs, kind=int_size) + test = .false. + if (n >= 2) then + if ( runs( n-1 ) % base == 0 .or. & + runs( n-2 ) % len <= runs(n-1) % len ) then + test = .true. + else if ( n >= 3 ) then ! X exists + if ( runs(n-3) % len <= & + runs(n-2) % len + runs(n-1) % len ) then + test = .true. +! |X| <= |Y| + |Z| => will need to merge due to rho1 or rho2 + else if( n >= 4 ) then + if ( runs(n-4) % len <= & + runs(n-3) % len + runs(n-2) % len ) then + test = .true. +! |W| <= |X| + |Y| => will need to merge due to rho1 or rho3 + end if + end if + end if + end if + if ( test ) then +! By default merge Y & Z, rho2 or rho3 + if ( n >= 3 ) then + if ( runs(n-3) % len < runs(n-1) % len ) then + r = n - 3 +! |X| < |Z| => merge X & Y, rho1 + return + end if + end if + r = n - 2 +! |Y| <= |Z| => merge Y & Z, rho4 + return + else + r = -1 + end if + + end function collapse + + + pure subroutine insert_head( array ) +! Inserts `array(0)` into the pre-sorted sequence `array(1:)` so that the +! whole `array(0:)` becomes sorted, copying the first element into +! a temporary variable, iterating until the right place for it is found. +! copying every traversed element into the slot preceding it, and finally, +! copying data from the temporary variable into the resulting hole. + + integer(int16), intent(inout) :: array(0:) + + integer(int16) :: tmp + integer(int_size) :: i + + tmp = array(0) + find_hole: do i=1, size(array, kind=int_size)-1 + if ( array(i) <= tmp ) exit find_hole + array(i-1) = array(i) + end do find_hole + array(i-1) = tmp + + end subroutine insert_head + + + subroutine merge_sort( array, buf ) +! The Rust merge sort borrows some (but not all) of the ideas from TimSort, +! which is described in detail at +! (http://svn.python.org/projects/python/trunk/Objects/listsort.txt). +! +! The algorithm identifies strictly descending and non-descending +! subsequences, which are called natural runs. Where these runs are less +! than a minimum run size they are padded by adding additional samples +! using an insertion sort. The merge process is driven by a stack of +! pending unmerged runs. Each newly found run is pushed onto the stack, +! and then pairs of adjacentd runs are merged until these two invariants +! are satisfied: +! +! 1. for every `i` in `1..size(runs)-1`: `runs(i - 1)%len > runs(i)%len` +! 2. for every `i` in `2..size(runs)-1`: `runs(i - 2)%len > +! runs(i - 1)%len + runs(i)%len` +! +! The invariants ensure that the total running time is `O(n log n)` +! worst-case. + + integer(int16), intent(inout) :: array(0:) + integer(int16), intent(inout) :: buf(0:) + + integer(int_size) :: array_size, finish, min_run, r, r_count, & + start + type(run_type) :: runs(0:max_merge_stack-1), left, right + + array_size = size(array, kind=int_size) + +! Very short runs are extended using insertion sort to span at least +! min_run elements. Slices of up to this length are sorted using insertion +! sort. + min_run = calc_min_run( array_size ) + + if ( array_size <= min_run ) then + if ( array_size >= 2 ) call insertion_sort( array ) + return + end if + +! Following Rust sort, natural runs in `array` are identified by traversing +! it backwards. By traversing it backward, merges more often go in the +! opposite direction (forwards). According to developers of Rust sort, +! merging forwards is slightly faster than merging backwards. Therefore +! identifying runs by traversing backwards should improve performance. + r_count = 0 + finish = array_size - 1 + do while ( finish >= 0 ) +! Find the next natural run, and reverse it if it's strictly descending. + start = finish + if ( start > 0 ) then + start = start - 1 + if ( array(start+1) > array(start) ) then + Descending: do while ( start > 0 ) + if ( array(start) <= array(start-1) ) & + exit Descending + start = start - 1 + end do Descending + call reverse_segment( array(start:finish) ) + else + Ascending: do while( start > 0 ) + if ( array(start) > array(start-1) ) exit Ascending + start = start - 1 + end do Ascending + end if + end if + +! If the run is too short insert some more elements using an insertion sort. + Insert: do while ( start > 0 ) + if ( finish - start >= min_run - 1 ) exit Insert + start = start - 1 + call insert_head( array(start:finish) ) + end do Insert + if ( start == 0 .and. finish == array_size - 1 ) return + + runs(r_count) = run_type( base = start, & + len = finish - start + 1 ) + finish = start-1 + r_count = r_count + 1 + +! Determine whether pairs of adjacent runs need to be merged to satisfy +! the invariants, and, if so, merge them. + Merge_loop: do + r = collapse( runs(0:r_count - 1) ) + if ( r < 0 .or. r_count <= 1 ) exit Merge_loop + left = runs( r + 1 ) + right = runs( r ) + call merge( array( left % base: & + right % base + right % len - 1 ), & + left % len, buf ) + + runs(r) = run_type( base = left % base, & + len = left % len + right % len ) + if ( r == r_count - 3 ) runs(r+1) = runs(r+2) + r_count = r_count - 1 + + end do Merge_loop + end do + if ( r_count /= 1 ) & + error stop "MERGE_SORT completed without RUN COUNT == 1." + + end subroutine merge_sort + + + pure subroutine merge( array, mid, buf ) +! Merges the two non-decreasing runs `ARRAY(0:MID-1)` and `ARRAY(MID:)` +! using `BUF` as temporary storage, and stores the merged runs into +! `ARRAY(0:)`. `MID` must be > 0, and < `SIZE(ARRAY)-1`. Buffer `BUF` +! must be long enough to hold the shorter of the two runs. + integer(int16), intent(inout) :: array(0:) + integer(int_size), intent(in) :: mid + integer(int16), intent(inout) :: buf(0:) + + integer(int_size) :: array_len, i, j, k + + array_len = size(array, kind=int_size) + +! Merge first copies the shorter run into `buf`. Then, depending on which +! run was shorter, it traces the copied run and the longer run forwards +! (or backwards), comparing their next unprocessed elements and then +! copying the lesser (or greater) one into `array`. + + if ( mid <= array_len - mid ) then ! The left run is shorter. + buf(0:mid-1) = array(0:mid-1) + i = 0 + j = mid + merge_lower: do k = 0, array_len-1 + if ( buf(i) >= array(j) ) then + array(k) = buf(i) + i = i + 1 + if ( i >= mid ) exit merge_lower + else + array(k) = array(j) + j = j + 1 + if ( j >= array_len ) then + array(k+1:) = buf(i:mid-1) + exit merge_lower + end if + end if + end do merge_lower + else ! The right run is shorter ! check that it is stable + buf(0:array_len-mid-1) = array(mid:array_len-1) + i = mid - 1 + j = array_len - mid -1 + merge_upper: do k = array_len-1, 0, -1 + if ( buf(j) <= array(i) ) then + array(k) = buf(j) + j = j - 1 + if ( j < 0 ) exit merge_upper + else + array(k) = array(i) + i = i - 1 + if ( i < 0 ) then + array(0:k-1) = buf(0:j) + exit merge_upper + end if + end if + end do merge_upper + end if + end subroutine merge + + + pure subroutine reverse_segment( array ) +! Reverse a segment of an array in place + integer(int16), intent(inout) :: array(0:) + + integer(int_size) :: lo, hi + integer(int16) :: temp + + lo = 0 + hi = size( array, kind=int_size ) - 1 + do while( lo < hi ) + temp = array(lo) + array(lo) = array(hi) + array(hi) = temp + lo = lo + 1 + hi = hi - 1 + end do + + end subroutine reverse_segment + + end subroutine int16_decrease_ord_sort + + + subroutine int32_decrease_ord_sort( array, work ) +! A translation to Fortran 2008, of the `"Rust" sort` algorithm found in +! `slice.rs` +! https://github.com/rust-lang/rust/blob/90eb44a5897c39e3dff9c7e48e3973671dcd9496/src/liballoc/slice.rs#L2159 +! The Rust version in turn is a simplification of the Timsort algorithm +! described in +! https://svn.python.org/projects/python/trunk/Objects/listsort.txt, as +! it drops both the use of 'galloping' to identify bounds of regions to be +! sorted and the estimation of the optimal `run size`. However it remains +! a hybrid sorting algorithm combining an iterative Merge sort controlled +! by a stack of `RUNS` identified by regions of uniformly decreasing or +! non-decreasing sequences that may be expanded to a minimum run size and +! initially processed by an insertion sort. +! +! Note the Fortran implementation simplifies the logic as it only has to +! deal with Fortran arrays of intrinsic types and not the full generality +! of Rust's arrays and lists for arbitrary types. It also adds the +! estimation of the optimal `run size` as suggested in Tim Peters' +! original `listsort.txt`, and an optional `work` array to be used as +! scratch memory. + integer(int32), intent(inout) :: array(0:) + integer(int32), intent(out), optional :: work(0:) + + integer(int32), allocatable :: buf(:) + integer(int_size) :: array_size + integer :: stat + + array_size = size( array, kind=int_size ) + if ( present(work) ) then + if ( size( work, kind=int_size) < array_size/2 ) then + error stop "int32_decrease_ord_sort: work array is too small." + endif +! Use the work array as scratch memory + call merge_sort( array, work ) + else +! Allocate a buffer to use as scratch memory. + allocate( buf(0:array_size/2-1), stat=stat ) + if ( stat /= 0 ) error stop "int32_decrease_ord_sort: Allocation of buffer failed." + call merge_sort( array, buf ) + end if + + contains + + pure function calc_min_run( n ) result(min_run) +!! Returns the minimum length of a run from 32-63 so that N/MIN_RUN is +!! less than or equal to a power of two. See +!! https://svn.python.org/projects/python/trunk/Objects/listsort.txt + integer(int_size) :: min_run + integer(int_size), intent(in) :: n + + integer(int_size) :: num, r + + num = n + r = 0_int_size + + do while( num >= 64 ) + r = ior( r, iand(num, 1_int_size) ) + num = ishft(num, -1_int_size) + end do + min_run = num + r + + end function calc_min_run + + + pure subroutine insertion_sort( array ) +! Sorts `ARRAY` using an insertion sort. + integer(int32), intent(inout) :: array(0:) + + integer(int_size) :: i, j + integer(int32) :: key + + do j=1, size(array, kind=int_size)-1 + key = array(j) + i = j - 1 + do while( i >= 0 ) + if ( array(i) >= key ) exit + array(i+1) = array(i) + i = i - 1 + end do + array(i+1) = key + end do + + end subroutine insertion_sort + + + pure function collapse( runs ) result ( r ) +! Examine the stack of runs waiting to be merged, identifying adjacent runs +! to be merged until the stack invariants are restablished: +! +! 1. len(-3) > len(-2) + len(-1) +! 2. len(-2) > len(-1) + integer(int_size) :: r + type(run_type), intent(in), target :: runs(0:) + + integer(int_size) :: n + logical :: test + + n = size(runs, kind=int_size) + test = .false. + if (n >= 2) then + if ( runs( n-1 ) % base == 0 .or. & + runs( n-2 ) % len <= runs(n-1) % len ) then + test = .true. + else if ( n >= 3 ) then ! X exists + if ( runs(n-3) % len <= & + runs(n-2) % len + runs(n-1) % len ) then + test = .true. +! |X| <= |Y| + |Z| => will need to merge due to rho1 or rho2 + else if( n >= 4 ) then + if ( runs(n-4) % len <= & + runs(n-3) % len + runs(n-2) % len ) then + test = .true. +! |W| <= |X| + |Y| => will need to merge due to rho1 or rho3 + end if + end if + end if + end if + if ( test ) then +! By default merge Y & Z, rho2 or rho3 + if ( n >= 3 ) then + if ( runs(n-3) % len < runs(n-1) % len ) then + r = n - 3 +! |X| < |Z| => merge X & Y, rho1 + return + end if + end if + r = n - 2 +! |Y| <= |Z| => merge Y & Z, rho4 + return + else + r = -1 + end if + + end function collapse + + + pure subroutine insert_head( array ) +! Inserts `array(0)` into the pre-sorted sequence `array(1:)` so that the +! whole `array(0:)` becomes sorted, copying the first element into +! a temporary variable, iterating until the right place for it is found. +! copying every traversed element into the slot preceding it, and finally, +! copying data from the temporary variable into the resulting hole. + + integer(int32), intent(inout) :: array(0:) + + integer(int32) :: tmp + integer(int_size) :: i + + tmp = array(0) + find_hole: do i=1, size(array, kind=int_size)-1 + if ( array(i) <= tmp ) exit find_hole + array(i-1) = array(i) + end do find_hole + array(i-1) = tmp + + end subroutine insert_head + + + subroutine merge_sort( array, buf ) +! The Rust merge sort borrows some (but not all) of the ideas from TimSort, +! which is described in detail at +! (http://svn.python.org/projects/python/trunk/Objects/listsort.txt). +! +! The algorithm identifies strictly descending and non-descending +! subsequences, which are called natural runs. Where these runs are less +! than a minimum run size they are padded by adding additional samples +! using an insertion sort. The merge process is driven by a stack of +! pending unmerged runs. Each newly found run is pushed onto the stack, +! and then pairs of adjacentd runs are merged until these two invariants +! are satisfied: +! +! 1. for every `i` in `1..size(runs)-1`: `runs(i - 1)%len > runs(i)%len` +! 2. for every `i` in `2..size(runs)-1`: `runs(i - 2)%len > +! runs(i - 1)%len + runs(i)%len` +! +! The invariants ensure that the total running time is `O(n log n)` +! worst-case. + + integer(int32), intent(inout) :: array(0:) + integer(int32), intent(inout) :: buf(0:) + + integer(int_size) :: array_size, finish, min_run, r, r_count, & + start + type(run_type) :: runs(0:max_merge_stack-1), left, right + + array_size = size(array, kind=int_size) + +! Very short runs are extended using insertion sort to span at least +! min_run elements. Slices of up to this length are sorted using insertion +! sort. + min_run = calc_min_run( array_size ) + + if ( array_size <= min_run ) then + if ( array_size >= 2 ) call insertion_sort( array ) + return + end if + +! Following Rust sort, natural runs in `array` are identified by traversing +! it backwards. By traversing it backward, merges more often go in the +! opposite direction (forwards). According to developers of Rust sort, +! merging forwards is slightly faster than merging backwards. Therefore +! identifying runs by traversing backwards should improve performance. + r_count = 0 + finish = array_size - 1 + do while ( finish >= 0 ) +! Find the next natural run, and reverse it if it's strictly descending. + start = finish + if ( start > 0 ) then + start = start - 1 + if ( array(start+1) > array(start) ) then + Descending: do while ( start > 0 ) + if ( array(start) <= array(start-1) ) & + exit Descending + start = start - 1 + end do Descending + call reverse_segment( array(start:finish) ) + else + Ascending: do while( start > 0 ) + if ( array(start) > array(start-1) ) exit Ascending + start = start - 1 + end do Ascending + end if + end if + +! If the run is too short insert some more elements using an insertion sort. + Insert: do while ( start > 0 ) + if ( finish - start >= min_run - 1 ) exit Insert + start = start - 1 + call insert_head( array(start:finish) ) + end do Insert + if ( start == 0 .and. finish == array_size - 1 ) return + + runs(r_count) = run_type( base = start, & + len = finish - start + 1 ) + finish = start-1 + r_count = r_count + 1 + +! Determine whether pairs of adjacent runs need to be merged to satisfy +! the invariants, and, if so, merge them. + Merge_loop: do + r = collapse( runs(0:r_count - 1) ) + if ( r < 0 .or. r_count <= 1 ) exit Merge_loop + left = runs( r + 1 ) + right = runs( r ) + call merge( array( left % base: & + right % base + right % len - 1 ), & + left % len, buf ) + + runs(r) = run_type( base = left % base, & + len = left % len + right % len ) + if ( r == r_count - 3 ) runs(r+1) = runs(r+2) + r_count = r_count - 1 + + end do Merge_loop + end do + if ( r_count /= 1 ) & + error stop "MERGE_SORT completed without RUN COUNT == 1." + + end subroutine merge_sort + + + pure subroutine merge( array, mid, buf ) +! Merges the two non-decreasing runs `ARRAY(0:MID-1)` and `ARRAY(MID:)` +! using `BUF` as temporary storage, and stores the merged runs into +! `ARRAY(0:)`. `MID` must be > 0, and < `SIZE(ARRAY)-1`. Buffer `BUF` +! must be long enough to hold the shorter of the two runs. + integer(int32), intent(inout) :: array(0:) + integer(int_size), intent(in) :: mid + integer(int32), intent(inout) :: buf(0:) + + integer(int_size) :: array_len, i, j, k + + array_len = size(array, kind=int_size) + +! Merge first copies the shorter run into `buf`. Then, depending on which +! run was shorter, it traces the copied run and the longer run forwards +! (or backwards), comparing their next unprocessed elements and then +! copying the lesser (or greater) one into `array`. + + if ( mid <= array_len - mid ) then ! The left run is shorter. + buf(0:mid-1) = array(0:mid-1) + i = 0 + j = mid + merge_lower: do k = 0, array_len-1 + if ( buf(i) >= array(j) ) then + array(k) = buf(i) + i = i + 1 + if ( i >= mid ) exit merge_lower + else + array(k) = array(j) + j = j + 1 + if ( j >= array_len ) then + array(k+1:) = buf(i:mid-1) + exit merge_lower + end if + end if + end do merge_lower + else ! The right run is shorter ! check that it is stable + buf(0:array_len-mid-1) = array(mid:array_len-1) + i = mid - 1 + j = array_len - mid -1 + merge_upper: do k = array_len-1, 0, -1 + if ( buf(j) <= array(i) ) then + array(k) = buf(j) + j = j - 1 + if ( j < 0 ) exit merge_upper + else + array(k) = array(i) + i = i - 1 + if ( i < 0 ) then + array(0:k-1) = buf(0:j) + exit merge_upper + end if + end if + end do merge_upper + end if + end subroutine merge + + + pure subroutine reverse_segment( array ) +! Reverse a segment of an array in place + integer(int32), intent(inout) :: array(0:) + + integer(int_size) :: lo, hi + integer(int32) :: temp + + lo = 0 + hi = size( array, kind=int_size ) - 1 + do while( lo < hi ) + temp = array(lo) + array(lo) = array(hi) + array(hi) = temp + lo = lo + 1 + hi = hi - 1 + end do + + end subroutine reverse_segment + + end subroutine int32_decrease_ord_sort + + + subroutine int64_decrease_ord_sort( array, work ) +! A translation to Fortran 2008, of the `"Rust" sort` algorithm found in +! `slice.rs` +! https://github.com/rust-lang/rust/blob/90eb44a5897c39e3dff9c7e48e3973671dcd9496/src/liballoc/slice.rs#L2159 +! The Rust version in turn is a simplification of the Timsort algorithm +! described in +! https://svn.python.org/projects/python/trunk/Objects/listsort.txt, as +! it drops both the use of 'galloping' to identify bounds of regions to be +! sorted and the estimation of the optimal `run size`. However it remains +! a hybrid sorting algorithm combining an iterative Merge sort controlled +! by a stack of `RUNS` identified by regions of uniformly decreasing or +! non-decreasing sequences that may be expanded to a minimum run size and +! initially processed by an insertion sort. +! +! Note the Fortran implementation simplifies the logic as it only has to +! deal with Fortran arrays of intrinsic types and not the full generality +! of Rust's arrays and lists for arbitrary types. It also adds the +! estimation of the optimal `run size` as suggested in Tim Peters' +! original `listsort.txt`, and an optional `work` array to be used as +! scratch memory. + integer(int64), intent(inout) :: array(0:) + integer(int64), intent(out), optional :: work(0:) + + integer(int64), allocatable :: buf(:) + integer(int_size) :: array_size + integer :: stat + + array_size = size( array, kind=int_size ) + if ( present(work) ) then + if ( size( work, kind=int_size) < array_size/2 ) then + error stop "int64_decrease_ord_sort: work array is too small." + endif +! Use the work array as scratch memory + call merge_sort( array, work ) + else +! Allocate a buffer to use as scratch memory. + allocate( buf(0:array_size/2-1), stat=stat ) + if ( stat /= 0 ) error stop "int64_decrease_ord_sort: Allocation of buffer failed." + call merge_sort( array, buf ) + end if + + contains + + pure function calc_min_run( n ) result(min_run) +!! Returns the minimum length of a run from 32-63 so that N/MIN_RUN is +!! less than or equal to a power of two. See +!! https://svn.python.org/projects/python/trunk/Objects/listsort.txt + integer(int_size) :: min_run + integer(int_size), intent(in) :: n + + integer(int_size) :: num, r + + num = n + r = 0_int_size + + do while( num >= 64 ) + r = ior( r, iand(num, 1_int_size) ) + num = ishft(num, -1_int_size) + end do + min_run = num + r + + end function calc_min_run + + + pure subroutine insertion_sort( array ) +! Sorts `ARRAY` using an insertion sort. + integer(int64), intent(inout) :: array(0:) + + integer(int_size) :: i, j + integer(int64) :: key + + do j=1, size(array, kind=int_size)-1 + key = array(j) + i = j - 1 + do while( i >= 0 ) + if ( array(i) >= key ) exit + array(i+1) = array(i) + i = i - 1 + end do + array(i+1) = key + end do + + end subroutine insertion_sort + + + pure function collapse( runs ) result ( r ) +! Examine the stack of runs waiting to be merged, identifying adjacent runs +! to be merged until the stack invariants are restablished: +! +! 1. len(-3) > len(-2) + len(-1) +! 2. len(-2) > len(-1) + integer(int_size) :: r + type(run_type), intent(in), target :: runs(0:) + + integer(int_size) :: n + logical :: test + + n = size(runs, kind=int_size) + test = .false. + if (n >= 2) then + if ( runs( n-1 ) % base == 0 .or. & + runs( n-2 ) % len <= runs(n-1) % len ) then + test = .true. + else if ( n >= 3 ) then ! X exists + if ( runs(n-3) % len <= & + runs(n-2) % len + runs(n-1) % len ) then + test = .true. +! |X| <= |Y| + |Z| => will need to merge due to rho1 or rho2 + else if( n >= 4 ) then + if ( runs(n-4) % len <= & + runs(n-3) % len + runs(n-2) % len ) then + test = .true. +! |W| <= |X| + |Y| => will need to merge due to rho1 or rho3 + end if + end if + end if + end if + if ( test ) then +! By default merge Y & Z, rho2 or rho3 + if ( n >= 3 ) then + if ( runs(n-3) % len < runs(n-1) % len ) then + r = n - 3 +! |X| < |Z| => merge X & Y, rho1 + return + end if + end if + r = n - 2 +! |Y| <= |Z| => merge Y & Z, rho4 + return + else + r = -1 + end if + + end function collapse + + + pure subroutine insert_head( array ) +! Inserts `array(0)` into the pre-sorted sequence `array(1:)` so that the +! whole `array(0:)` becomes sorted, copying the first element into +! a temporary variable, iterating until the right place for it is found. +! copying every traversed element into the slot preceding it, and finally, +! copying data from the temporary variable into the resulting hole. + + integer(int64), intent(inout) :: array(0:) + + integer(int64) :: tmp + integer(int_size) :: i + + tmp = array(0) + find_hole: do i=1, size(array, kind=int_size)-1 + if ( array(i) <= tmp ) exit find_hole + array(i-1) = array(i) + end do find_hole + array(i-1) = tmp + + end subroutine insert_head + + + subroutine merge_sort( array, buf ) +! The Rust merge sort borrows some (but not all) of the ideas from TimSort, +! which is described in detail at +! (http://svn.python.org/projects/python/trunk/Objects/listsort.txt). +! +! The algorithm identifies strictly descending and non-descending +! subsequences, which are called natural runs. Where these runs are less +! than a minimum run size they are padded by adding additional samples +! using an insertion sort. The merge process is driven by a stack of +! pending unmerged runs. Each newly found run is pushed onto the stack, +! and then pairs of adjacentd runs are merged until these two invariants +! are satisfied: +! +! 1. for every `i` in `1..size(runs)-1`: `runs(i - 1)%len > runs(i)%len` +! 2. for every `i` in `2..size(runs)-1`: `runs(i - 2)%len > +! runs(i - 1)%len + runs(i)%len` +! +! The invariants ensure that the total running time is `O(n log n)` +! worst-case. + + integer(int64), intent(inout) :: array(0:) + integer(int64), intent(inout) :: buf(0:) + + integer(int_size) :: array_size, finish, min_run, r, r_count, & + start + type(run_type) :: runs(0:max_merge_stack-1), left, right + + array_size = size(array, kind=int_size) + +! Very short runs are extended using insertion sort to span at least +! min_run elements. Slices of up to this length are sorted using insertion +! sort. + min_run = calc_min_run( array_size ) + + if ( array_size <= min_run ) then + if ( array_size >= 2 ) call insertion_sort( array ) + return + end if + +! Following Rust sort, natural runs in `array` are identified by traversing +! it backwards. By traversing it backward, merges more often go in the +! opposite direction (forwards). According to developers of Rust sort, +! merging forwards is slightly faster than merging backwards. Therefore +! identifying runs by traversing backwards should improve performance. + r_count = 0 + finish = array_size - 1 + do while ( finish >= 0 ) +! Find the next natural run, and reverse it if it's strictly descending. + start = finish + if ( start > 0 ) then + start = start - 1 + if ( array(start+1) > array(start) ) then + Descending: do while ( start > 0 ) + if ( array(start) <= array(start-1) ) & + exit Descending + start = start - 1 + end do Descending + call reverse_segment( array(start:finish) ) + else + Ascending: do while( start > 0 ) + if ( array(start) > array(start-1) ) exit Ascending + start = start - 1 + end do Ascending + end if + end if + +! If the run is too short insert some more elements using an insertion sort. + Insert: do while ( start > 0 ) + if ( finish - start >= min_run - 1 ) exit Insert + start = start - 1 + call insert_head( array(start:finish) ) + end do Insert + if ( start == 0 .and. finish == array_size - 1 ) return + + runs(r_count) = run_type( base = start, & + len = finish - start + 1 ) + finish = start-1 + r_count = r_count + 1 + +! Determine whether pairs of adjacent runs need to be merged to satisfy +! the invariants, and, if so, merge them. + Merge_loop: do + r = collapse( runs(0:r_count - 1) ) + if ( r < 0 .or. r_count <= 1 ) exit Merge_loop + left = runs( r + 1 ) + right = runs( r ) + call merge( array( left % base: & + right % base + right % len - 1 ), & + left % len, buf ) + + runs(r) = run_type( base = left % base, & + len = left % len + right % len ) + if ( r == r_count - 3 ) runs(r+1) = runs(r+2) + r_count = r_count - 1 + + end do Merge_loop + end do + if ( r_count /= 1 ) & + error stop "MERGE_SORT completed without RUN COUNT == 1." + + end subroutine merge_sort + + + pure subroutine merge( array, mid, buf ) +! Merges the two non-decreasing runs `ARRAY(0:MID-1)` and `ARRAY(MID:)` +! using `BUF` as temporary storage, and stores the merged runs into +! `ARRAY(0:)`. `MID` must be > 0, and < `SIZE(ARRAY)-1`. Buffer `BUF` +! must be long enough to hold the shorter of the two runs. + integer(int64), intent(inout) :: array(0:) + integer(int_size), intent(in) :: mid + integer(int64), intent(inout) :: buf(0:) + + integer(int_size) :: array_len, i, j, k + + array_len = size(array, kind=int_size) + +! Merge first copies the shorter run into `buf`. Then, depending on which +! run was shorter, it traces the copied run and the longer run forwards +! (or backwards), comparing their next unprocessed elements and then +! copying the lesser (or greater) one into `array`. + + if ( mid <= array_len - mid ) then ! The left run is shorter. + buf(0:mid-1) = array(0:mid-1) + i = 0 + j = mid + merge_lower: do k = 0, array_len-1 + if ( buf(i) >= array(j) ) then + array(k) = buf(i) + i = i + 1 + if ( i >= mid ) exit merge_lower + else + array(k) = array(j) + j = j + 1 + if ( j >= array_len ) then + array(k+1:) = buf(i:mid-1) + exit merge_lower + end if + end if + end do merge_lower + else ! The right run is shorter ! check that it is stable + buf(0:array_len-mid-1) = array(mid:array_len-1) + i = mid - 1 + j = array_len - mid -1 + merge_upper: do k = array_len-1, 0, -1 + if ( buf(j) <= array(i) ) then + array(k) = buf(j) + j = j - 1 + if ( j < 0 ) exit merge_upper + else + array(k) = array(i) + i = i - 1 + if ( i < 0 ) then + array(0:k-1) = buf(0:j) + exit merge_upper + end if + end if + end do merge_upper + end if + end subroutine merge + + + pure subroutine reverse_segment( array ) +! Reverse a segment of an array in place + integer(int64), intent(inout) :: array(0:) + + integer(int_size) :: lo, hi + integer(int64) :: temp + + lo = 0 + hi = size( array, kind=int_size ) - 1 + do while( lo < hi ) + temp = array(lo) + array(lo) = array(hi) + array(hi) = temp + lo = lo + 1 + hi = hi - 1 + end do + + end subroutine reverse_segment + + end subroutine int64_decrease_ord_sort + + + subroutine sp_decrease_ord_sort( array, work ) +! A translation to Fortran 2008, of the `"Rust" sort` algorithm found in +! `slice.rs` +! https://github.com/rust-lang/rust/blob/90eb44a5897c39e3dff9c7e48e3973671dcd9496/src/liballoc/slice.rs#L2159 +! The Rust version in turn is a simplification of the Timsort algorithm +! described in +! https://svn.python.org/projects/python/trunk/Objects/listsort.txt, as +! it drops both the use of 'galloping' to identify bounds of regions to be +! sorted and the estimation of the optimal `run size`. However it remains +! a hybrid sorting algorithm combining an iterative Merge sort controlled +! by a stack of `RUNS` identified by regions of uniformly decreasing or +! non-decreasing sequences that may be expanded to a minimum run size and +! initially processed by an insertion sort. +! +! Note the Fortran implementation simplifies the logic as it only has to +! deal with Fortran arrays of intrinsic types and not the full generality +! of Rust's arrays and lists for arbitrary types. It also adds the +! estimation of the optimal `run size` as suggested in Tim Peters' +! original `listsort.txt`, and an optional `work` array to be used as +! scratch memory. + real(sp), intent(inout) :: array(0:) + real(sp), intent(out), optional :: work(0:) + + real(sp), allocatable :: buf(:) + integer(int_size) :: array_size + integer :: stat + + array_size = size( array, kind=int_size ) + if ( present(work) ) then + if ( size( work, kind=int_size) < array_size/2 ) then + error stop "sp_decrease_ord_sort: work array is too small." + endif +! Use the work array as scratch memory + call merge_sort( array, work ) + else +! Allocate a buffer to use as scratch memory. + allocate( buf(0:array_size/2-1), stat=stat ) + if ( stat /= 0 ) error stop "sp_decrease_ord_sort: Allocation of buffer failed." + call merge_sort( array, buf ) + end if + + contains + + pure function calc_min_run( n ) result(min_run) +!! Returns the minimum length of a run from 32-63 so that N/MIN_RUN is +!! less than or equal to a power of two. See +!! https://svn.python.org/projects/python/trunk/Objects/listsort.txt + integer(int_size) :: min_run + integer(int_size), intent(in) :: n + + integer(int_size) :: num, r + + num = n + r = 0_int_size + + do while( num >= 64 ) + r = ior( r, iand(num, 1_int_size) ) + num = ishft(num, -1_int_size) + end do + min_run = num + r + + end function calc_min_run + + + pure subroutine insertion_sort( array ) +! Sorts `ARRAY` using an insertion sort. + real(sp), intent(inout) :: array(0:) + + integer(int_size) :: i, j + real(sp) :: key + + do j=1, size(array, kind=int_size)-1 + key = array(j) + i = j - 1 + do while( i >= 0 ) + if ( array(i) >= key ) exit + array(i+1) = array(i) + i = i - 1 + end do + array(i+1) = key + end do + + end subroutine insertion_sort + + + pure function collapse( runs ) result ( r ) +! Examine the stack of runs waiting to be merged, identifying adjacent runs +! to be merged until the stack invariants are restablished: +! +! 1. len(-3) > len(-2) + len(-1) +! 2. len(-2) > len(-1) + integer(int_size) :: r + type(run_type), intent(in), target :: runs(0:) + + integer(int_size) :: n + logical :: test + + n = size(runs, kind=int_size) + test = .false. + if (n >= 2) then + if ( runs( n-1 ) % base == 0 .or. & + runs( n-2 ) % len <= runs(n-1) % len ) then + test = .true. + else if ( n >= 3 ) then ! X exists + if ( runs(n-3) % len <= & + runs(n-2) % len + runs(n-1) % len ) then + test = .true. +! |X| <= |Y| + |Z| => will need to merge due to rho1 or rho2 + else if( n >= 4 ) then + if ( runs(n-4) % len <= & + runs(n-3) % len + runs(n-2) % len ) then + test = .true. +! |W| <= |X| + |Y| => will need to merge due to rho1 or rho3 + end if + end if + end if + end if + if ( test ) then +! By default merge Y & Z, rho2 or rho3 + if ( n >= 3 ) then + if ( runs(n-3) % len < runs(n-1) % len ) then + r = n - 3 +! |X| < |Z| => merge X & Y, rho1 + return + end if + end if + r = n - 2 +! |Y| <= |Z| => merge Y & Z, rho4 + return + else + r = -1 + end if + + end function collapse + + + pure subroutine insert_head( array ) +! Inserts `array(0)` into the pre-sorted sequence `array(1:)` so that the +! whole `array(0:)` becomes sorted, copying the first element into +! a temporary variable, iterating until the right place for it is found. +! copying every traversed element into the slot preceding it, and finally, +! copying data from the temporary variable into the resulting hole. + + real(sp), intent(inout) :: array(0:) + + real(sp) :: tmp + integer(int_size) :: i + + tmp = array(0) + find_hole: do i=1, size(array, kind=int_size)-1 + if ( array(i) <= tmp ) exit find_hole + array(i-1) = array(i) + end do find_hole + array(i-1) = tmp + + end subroutine insert_head + + + subroutine merge_sort( array, buf ) +! The Rust merge sort borrows some (but not all) of the ideas from TimSort, +! which is described in detail at +! (http://svn.python.org/projects/python/trunk/Objects/listsort.txt). +! +! The algorithm identifies strictly descending and non-descending +! subsequences, which are called natural runs. Where these runs are less +! than a minimum run size they are padded by adding additional samples +! using an insertion sort. The merge process is driven by a stack of +! pending unmerged runs. Each newly found run is pushed onto the stack, +! and then pairs of adjacentd runs are merged until these two invariants +! are satisfied: +! +! 1. for every `i` in `1..size(runs)-1`: `runs(i - 1)%len > runs(i)%len` +! 2. for every `i` in `2..size(runs)-1`: `runs(i - 2)%len > +! runs(i - 1)%len + runs(i)%len` +! +! The invariants ensure that the total running time is `O(n log n)` +! worst-case. + + real(sp), intent(inout) :: array(0:) + real(sp), intent(inout) :: buf(0:) + + integer(int_size) :: array_size, finish, min_run, r, r_count, & + start + type(run_type) :: runs(0:max_merge_stack-1), left, right + + array_size = size(array, kind=int_size) + +! Very short runs are extended using insertion sort to span at least +! min_run elements. Slices of up to this length are sorted using insertion +! sort. + min_run = calc_min_run( array_size ) + + if ( array_size <= min_run ) then + if ( array_size >= 2 ) call insertion_sort( array ) + return + end if + +! Following Rust sort, natural runs in `array` are identified by traversing +! it backwards. By traversing it backward, merges more often go in the +! opposite direction (forwards). According to developers of Rust sort, +! merging forwards is slightly faster than merging backwards. Therefore +! identifying runs by traversing backwards should improve performance. + r_count = 0 + finish = array_size - 1 + do while ( finish >= 0 ) +! Find the next natural run, and reverse it if it's strictly descending. + start = finish + if ( start > 0 ) then + start = start - 1 + if ( array(start+1) > array(start) ) then + Descending: do while ( start > 0 ) + if ( array(start) <= array(start-1) ) & + exit Descending + start = start - 1 + end do Descending + call reverse_segment( array(start:finish) ) + else + Ascending: do while( start > 0 ) + if ( array(start) > array(start-1) ) exit Ascending + start = start - 1 + end do Ascending + end if + end if + +! If the run is too short insert some more elements using an insertion sort. + Insert: do while ( start > 0 ) + if ( finish - start >= min_run - 1 ) exit Insert + start = start - 1 + call insert_head( array(start:finish) ) + end do Insert + if ( start == 0 .and. finish == array_size - 1 ) return + + runs(r_count) = run_type( base = start, & + len = finish - start + 1 ) + finish = start-1 + r_count = r_count + 1 + +! Determine whether pairs of adjacent runs need to be merged to satisfy +! the invariants, and, if so, merge them. + Merge_loop: do + r = collapse( runs(0:r_count - 1) ) + if ( r < 0 .or. r_count <= 1 ) exit Merge_loop + left = runs( r + 1 ) + right = runs( r ) + call merge( array( left % base: & + right % base + right % len - 1 ), & + left % len, buf ) + + runs(r) = run_type( base = left % base, & + len = left % len + right % len ) + if ( r == r_count - 3 ) runs(r+1) = runs(r+2) + r_count = r_count - 1 + + end do Merge_loop + end do + if ( r_count /= 1 ) & + error stop "MERGE_SORT completed without RUN COUNT == 1." + + end subroutine merge_sort + + + pure subroutine merge( array, mid, buf ) +! Merges the two non-decreasing runs `ARRAY(0:MID-1)` and `ARRAY(MID:)` +! using `BUF` as temporary storage, and stores the merged runs into +! `ARRAY(0:)`. `MID` must be > 0, and < `SIZE(ARRAY)-1`. Buffer `BUF` +! must be long enough to hold the shorter of the two runs. + real(sp), intent(inout) :: array(0:) + integer(int_size), intent(in) :: mid + real(sp), intent(inout) :: buf(0:) + + integer(int_size) :: array_len, i, j, k + + array_len = size(array, kind=int_size) + +! Merge first copies the shorter run into `buf`. Then, depending on which +! run was shorter, it traces the copied run and the longer run forwards +! (or backwards), comparing their next unprocessed elements and then +! copying the lesser (or greater) one into `array`. + + if ( mid <= array_len - mid ) then ! The left run is shorter. + buf(0:mid-1) = array(0:mid-1) + i = 0 + j = mid + merge_lower: do k = 0, array_len-1 + if ( buf(i) >= array(j) ) then + array(k) = buf(i) + i = i + 1 + if ( i >= mid ) exit merge_lower + else + array(k) = array(j) + j = j + 1 + if ( j >= array_len ) then + array(k+1:) = buf(i:mid-1) + exit merge_lower + end if + end if + end do merge_lower + else ! The right run is shorter ! check that it is stable + buf(0:array_len-mid-1) = array(mid:array_len-1) + i = mid - 1 + j = array_len - mid -1 + merge_upper: do k = array_len-1, 0, -1 + if ( buf(j) <= array(i) ) then + array(k) = buf(j) + j = j - 1 + if ( j < 0 ) exit merge_upper + else + array(k) = array(i) + i = i - 1 + if ( i < 0 ) then + array(0:k-1) = buf(0:j) + exit merge_upper + end if + end if + end do merge_upper + end if + end subroutine merge + + + pure subroutine reverse_segment( array ) +! Reverse a segment of an array in place + real(sp), intent(inout) :: array(0:) + + integer(int_size) :: lo, hi + real(sp) :: temp + + lo = 0 + hi = size( array, kind=int_size ) - 1 + do while( lo < hi ) + temp = array(lo) + array(lo) = array(hi) + array(hi) = temp + lo = lo + 1 + hi = hi - 1 + end do + + end subroutine reverse_segment + + end subroutine sp_decrease_ord_sort + + + subroutine dp_decrease_ord_sort( array, work ) +! A translation to Fortran 2008, of the `"Rust" sort` algorithm found in +! `slice.rs` +! https://github.com/rust-lang/rust/blob/90eb44a5897c39e3dff9c7e48e3973671dcd9496/src/liballoc/slice.rs#L2159 +! The Rust version in turn is a simplification of the Timsort algorithm +! described in +! https://svn.python.org/projects/python/trunk/Objects/listsort.txt, as +! it drops both the use of 'galloping' to identify bounds of regions to be +! sorted and the estimation of the optimal `run size`. However it remains +! a hybrid sorting algorithm combining an iterative Merge sort controlled +! by a stack of `RUNS` identified by regions of uniformly decreasing or +! non-decreasing sequences that may be expanded to a minimum run size and +! initially processed by an insertion sort. +! +! Note the Fortran implementation simplifies the logic as it only has to +! deal with Fortran arrays of intrinsic types and not the full generality +! of Rust's arrays and lists for arbitrary types. It also adds the +! estimation of the optimal `run size` as suggested in Tim Peters' +! original `listsort.txt`, and an optional `work` array to be used as +! scratch memory. + real(dp), intent(inout) :: array(0:) + real(dp), intent(out), optional :: work(0:) + + real(dp), allocatable :: buf(:) + integer(int_size) :: array_size + integer :: stat + + array_size = size( array, kind=int_size ) + if ( present(work) ) then + if ( size( work, kind=int_size) < array_size/2 ) then + error stop "dp_decrease_ord_sort: work array is too small." + endif +! Use the work array as scratch memory + call merge_sort( array, work ) + else +! Allocate a buffer to use as scratch memory. + allocate( buf(0:array_size/2-1), stat=stat ) + if ( stat /= 0 ) error stop "dp_decrease_ord_sort: Allocation of buffer failed." + call merge_sort( array, buf ) + end if + + contains + + pure function calc_min_run( n ) result(min_run) +!! Returns the minimum length of a run from 32-63 so that N/MIN_RUN is +!! less than or equal to a power of two. See +!! https://svn.python.org/projects/python/trunk/Objects/listsort.txt + integer(int_size) :: min_run + integer(int_size), intent(in) :: n + + integer(int_size) :: num, r + + num = n + r = 0_int_size + + do while( num >= 64 ) + r = ior( r, iand(num, 1_int_size) ) + num = ishft(num, -1_int_size) + end do + min_run = num + r + + end function calc_min_run + + + pure subroutine insertion_sort( array ) +! Sorts `ARRAY` using an insertion sort. + real(dp), intent(inout) :: array(0:) + + integer(int_size) :: i, j + real(dp) :: key + + do j=1, size(array, kind=int_size)-1 + key = array(j) + i = j - 1 + do while( i >= 0 ) + if ( array(i) >= key ) exit + array(i+1) = array(i) + i = i - 1 + end do + array(i+1) = key + end do + + end subroutine insertion_sort + + + pure function collapse( runs ) result ( r ) +! Examine the stack of runs waiting to be merged, identifying adjacent runs +! to be merged until the stack invariants are restablished: +! +! 1. len(-3) > len(-2) + len(-1) +! 2. len(-2) > len(-1) + integer(int_size) :: r + type(run_type), intent(in), target :: runs(0:) + + integer(int_size) :: n + logical :: test + + n = size(runs, kind=int_size) + test = .false. + if (n >= 2) then + if ( runs( n-1 ) % base == 0 .or. & + runs( n-2 ) % len <= runs(n-1) % len ) then + test = .true. + else if ( n >= 3 ) then ! X exists + if ( runs(n-3) % len <= & + runs(n-2) % len + runs(n-1) % len ) then + test = .true. +! |X| <= |Y| + |Z| => will need to merge due to rho1 or rho2 + else if( n >= 4 ) then + if ( runs(n-4) % len <= & + runs(n-3) % len + runs(n-2) % len ) then + test = .true. +! |W| <= |X| + |Y| => will need to merge due to rho1 or rho3 + end if + end if + end if + end if + if ( test ) then +! By default merge Y & Z, rho2 or rho3 + if ( n >= 3 ) then + if ( runs(n-3) % len < runs(n-1) % len ) then + r = n - 3 +! |X| < |Z| => merge X & Y, rho1 + return + end if + end if + r = n - 2 +! |Y| <= |Z| => merge Y & Z, rho4 + return + else + r = -1 + end if + + end function collapse + + + pure subroutine insert_head( array ) +! Inserts `array(0)` into the pre-sorted sequence `array(1:)` so that the +! whole `array(0:)` becomes sorted, copying the first element into +! a temporary variable, iterating until the right place for it is found. +! copying every traversed element into the slot preceding it, and finally, +! copying data from the temporary variable into the resulting hole. + + real(dp), intent(inout) :: array(0:) + + real(dp) :: tmp + integer(int_size) :: i + + tmp = array(0) + find_hole: do i=1, size(array, kind=int_size)-1 + if ( array(i) <= tmp ) exit find_hole + array(i-1) = array(i) + end do find_hole + array(i-1) = tmp + + end subroutine insert_head + + + subroutine merge_sort( array, buf ) +! The Rust merge sort borrows some (but not all) of the ideas from TimSort, +! which is described in detail at +! (http://svn.python.org/projects/python/trunk/Objects/listsort.txt). +! +! The algorithm identifies strictly descending and non-descending +! subsequences, which are called natural runs. Where these runs are less +! than a minimum run size they are padded by adding additional samples +! using an insertion sort. The merge process is driven by a stack of +! pending unmerged runs. Each newly found run is pushed onto the stack, +! and then pairs of adjacentd runs are merged until these two invariants +! are satisfied: +! +! 1. for every `i` in `1..size(runs)-1`: `runs(i - 1)%len > runs(i)%len` +! 2. for every `i` in `2..size(runs)-1`: `runs(i - 2)%len > +! runs(i - 1)%len + runs(i)%len` +! +! The invariants ensure that the total running time is `O(n log n)` +! worst-case. + + real(dp), intent(inout) :: array(0:) + real(dp), intent(inout) :: buf(0:) + + integer(int_size) :: array_size, finish, min_run, r, r_count, & + start + type(run_type) :: runs(0:max_merge_stack-1), left, right + + array_size = size(array, kind=int_size) + +! Very short runs are extended using insertion sort to span at least +! min_run elements. Slices of up to this length are sorted using insertion +! sort. + min_run = calc_min_run( array_size ) + + if ( array_size <= min_run ) then + if ( array_size >= 2 ) call insertion_sort( array ) + return + end if + +! Following Rust sort, natural runs in `array` are identified by traversing +! it backwards. By traversing it backward, merges more often go in the +! opposite direction (forwards). According to developers of Rust sort, +! merging forwards is slightly faster than merging backwards. Therefore +! identifying runs by traversing backwards should improve performance. + r_count = 0 + finish = array_size - 1 + do while ( finish >= 0 ) +! Find the next natural run, and reverse it if it's strictly descending. + start = finish + if ( start > 0 ) then + start = start - 1 + if ( array(start+1) > array(start) ) then + Descending: do while ( start > 0 ) + if ( array(start) <= array(start-1) ) & + exit Descending + start = start - 1 + end do Descending + call reverse_segment( array(start:finish) ) + else + Ascending: do while( start > 0 ) + if ( array(start) > array(start-1) ) exit Ascending + start = start - 1 + end do Ascending + end if + end if + +! If the run is too short insert some more elements using an insertion sort. + Insert: do while ( start > 0 ) + if ( finish - start >= min_run - 1 ) exit Insert + start = start - 1 + call insert_head( array(start:finish) ) + end do Insert + if ( start == 0 .and. finish == array_size - 1 ) return + + runs(r_count) = run_type( base = start, & + len = finish - start + 1 ) + finish = start-1 + r_count = r_count + 1 + +! Determine whether pairs of adjacent runs need to be merged to satisfy +! the invariants, and, if so, merge them. + Merge_loop: do + r = collapse( runs(0:r_count - 1) ) + if ( r < 0 .or. r_count <= 1 ) exit Merge_loop + left = runs( r + 1 ) + right = runs( r ) + call merge( array( left % base: & + right % base + right % len - 1 ), & + left % len, buf ) + + runs(r) = run_type( base = left % base, & + len = left % len + right % len ) + if ( r == r_count - 3 ) runs(r+1) = runs(r+2) + r_count = r_count - 1 + + end do Merge_loop + end do + if ( r_count /= 1 ) & + error stop "MERGE_SORT completed without RUN COUNT == 1." + + end subroutine merge_sort + + + pure subroutine merge( array, mid, buf ) +! Merges the two non-decreasing runs `ARRAY(0:MID-1)` and `ARRAY(MID:)` +! using `BUF` as temporary storage, and stores the merged runs into +! `ARRAY(0:)`. `MID` must be > 0, and < `SIZE(ARRAY)-1`. Buffer `BUF` +! must be long enough to hold the shorter of the two runs. + real(dp), intent(inout) :: array(0:) + integer(int_size), intent(in) :: mid + real(dp), intent(inout) :: buf(0:) + + integer(int_size) :: array_len, i, j, k + + array_len = size(array, kind=int_size) + +! Merge first copies the shorter run into `buf`. Then, depending on which +! run was shorter, it traces the copied run and the longer run forwards +! (or backwards), comparing their next unprocessed elements and then +! copying the lesser (or greater) one into `array`. + + if ( mid <= array_len - mid ) then ! The left run is shorter. + buf(0:mid-1) = array(0:mid-1) + i = 0 + j = mid + merge_lower: do k = 0, array_len-1 + if ( buf(i) >= array(j) ) then + array(k) = buf(i) + i = i + 1 + if ( i >= mid ) exit merge_lower + else + array(k) = array(j) + j = j + 1 + if ( j >= array_len ) then + array(k+1:) = buf(i:mid-1) + exit merge_lower + end if + end if + end do merge_lower + else ! The right run is shorter ! check that it is stable + buf(0:array_len-mid-1) = array(mid:array_len-1) + i = mid - 1 + j = array_len - mid -1 + merge_upper: do k = array_len-1, 0, -1 + if ( buf(j) <= array(i) ) then + array(k) = buf(j) + j = j - 1 + if ( j < 0 ) exit merge_upper + else + array(k) = array(i) + i = i - 1 + if ( i < 0 ) then + array(0:k-1) = buf(0:j) + exit merge_upper + end if + end if + end do merge_upper + end if + end subroutine merge + + + pure subroutine reverse_segment( array ) +! Reverse a segment of an array in place + real(dp), intent(inout) :: array(0:) + + integer(int_size) :: lo, hi + real(dp) :: temp + + lo = 0 + hi = size( array, kind=int_size ) - 1 + do while( lo < hi ) + temp = array(lo) + array(lo) = array(hi) + array(hi) = temp + lo = lo + 1 + hi = hi - 1 + end do + + end subroutine reverse_segment + + end subroutine dp_decrease_ord_sort + + + subroutine qp_decrease_ord_sort( array, work ) +! A translation to Fortran 2008, of the `"Rust" sort` algorithm found in +! `slice.rs` +! https://github.com/rust-lang/rust/blob/90eb44a5897c39e3dff9c7e48e3973671dcd9496/src/liballoc/slice.rs#L2159 +! The Rust version in turn is a simplification of the Timsort algorithm +! described in +! https://svn.python.org/projects/python/trunk/Objects/listsort.txt, as +! it drops both the use of 'galloping' to identify bounds of regions to be +! sorted and the estimation of the optimal `run size`. However it remains +! a hybrid sorting algorithm combining an iterative Merge sort controlled +! by a stack of `RUNS` identified by regions of uniformly decreasing or +! non-decreasing sequences that may be expanded to a minimum run size and +! initially processed by an insertion sort. +! +! Note the Fortran implementation simplifies the logic as it only has to +! deal with Fortran arrays of intrinsic types and not the full generality +! of Rust's arrays and lists for arbitrary types. It also adds the +! estimation of the optimal `run size` as suggested in Tim Peters' +! original `listsort.txt`, and an optional `work` array to be used as +! scratch memory. + real(qp), intent(inout) :: array(0:) + real(qp), intent(out), optional :: work(0:) + + real(qp), allocatable :: buf(:) + integer(int_size) :: array_size + integer :: stat + + array_size = size( array, kind=int_size ) + if ( present(work) ) then + if ( size( work, kind=int_size) < array_size/2 ) then + error stop "qp_decrease_ord_sort: work array is too small." + endif +! Use the work array as scratch memory + call merge_sort( array, work ) + else +! Allocate a buffer to use as scratch memory. + allocate( buf(0:array_size/2-1), stat=stat ) + if ( stat /= 0 ) error stop "qp_decrease_ord_sort: Allocation of buffer failed." + call merge_sort( array, buf ) + end if + + contains + + pure function calc_min_run( n ) result(min_run) +!! Returns the minimum length of a run from 32-63 so that N/MIN_RUN is +!! less than or equal to a power of two. See +!! https://svn.python.org/projects/python/trunk/Objects/listsort.txt + integer(int_size) :: min_run + integer(int_size), intent(in) :: n + + integer(int_size) :: num, r + + num = n + r = 0_int_size + + do while( num >= 64 ) + r = ior( r, iand(num, 1_int_size) ) + num = ishft(num, -1_int_size) + end do + min_run = num + r + + end function calc_min_run + + + pure subroutine insertion_sort( array ) +! Sorts `ARRAY` using an insertion sort. + real(qp), intent(inout) :: array(0:) + + integer(int_size) :: i, j + real(qp) :: key + + do j=1, size(array, kind=int_size)-1 + key = array(j) + i = j - 1 + do while( i >= 0 ) + if ( array(i) >= key ) exit + array(i+1) = array(i) + i = i - 1 + end do + array(i+1) = key + end do + + end subroutine insertion_sort + + + pure function collapse( runs ) result ( r ) +! Examine the stack of runs waiting to be merged, identifying adjacent runs +! to be merged until the stack invariants are restablished: +! +! 1. len(-3) > len(-2) + len(-1) +! 2. len(-2) > len(-1) + integer(int_size) :: r + type(run_type), intent(in), target :: runs(0:) + + integer(int_size) :: n + logical :: test + + n = size(runs, kind=int_size) + test = .false. + if (n >= 2) then + if ( runs( n-1 ) % base == 0 .or. & + runs( n-2 ) % len <= runs(n-1) % len ) then + test = .true. + else if ( n >= 3 ) then ! X exists + if ( runs(n-3) % len <= & + runs(n-2) % len + runs(n-1) % len ) then + test = .true. +! |X| <= |Y| + |Z| => will need to merge due to rho1 or rho2 + else if( n >= 4 ) then + if ( runs(n-4) % len <= & + runs(n-3) % len + runs(n-2) % len ) then + test = .true. +! |W| <= |X| + |Y| => will need to merge due to rho1 or rho3 + end if + end if + end if + end if + if ( test ) then +! By default merge Y & Z, rho2 or rho3 + if ( n >= 3 ) then + if ( runs(n-3) % len < runs(n-1) % len ) then + r = n - 3 +! |X| < |Z| => merge X & Y, rho1 + return + end if + end if + r = n - 2 +! |Y| <= |Z| => merge Y & Z, rho4 + return + else + r = -1 + end if + + end function collapse + + + pure subroutine insert_head( array ) +! Inserts `array(0)` into the pre-sorted sequence `array(1:)` so that the +! whole `array(0:)` becomes sorted, copying the first element into +! a temporary variable, iterating until the right place for it is found. +! copying every traversed element into the slot preceding it, and finally, +! copying data from the temporary variable into the resulting hole. + + real(qp), intent(inout) :: array(0:) + + real(qp) :: tmp + integer(int_size) :: i + + tmp = array(0) + find_hole: do i=1, size(array, kind=int_size)-1 + if ( array(i) <= tmp ) exit find_hole + array(i-1) = array(i) + end do find_hole + array(i-1) = tmp + + end subroutine insert_head + + + subroutine merge_sort( array, buf ) +! The Rust merge sort borrows some (but not all) of the ideas from TimSort, +! which is described in detail at +! (http://svn.python.org/projects/python/trunk/Objects/listsort.txt). +! +! The algorithm identifies strictly descending and non-descending +! subsequences, which are called natural runs. Where these runs are less +! than a minimum run size they are padded by adding additional samples +! using an insertion sort. The merge process is driven by a stack of +! pending unmerged runs. Each newly found run is pushed onto the stack, +! and then pairs of adjacentd runs are merged until these two invariants +! are satisfied: +! +! 1. for every `i` in `1..size(runs)-1`: `runs(i - 1)%len > runs(i)%len` +! 2. for every `i` in `2..size(runs)-1`: `runs(i - 2)%len > +! runs(i - 1)%len + runs(i)%len` +! +! The invariants ensure that the total running time is `O(n log n)` +! worst-case. + + real(qp), intent(inout) :: array(0:) + real(qp), intent(inout) :: buf(0:) + + integer(int_size) :: array_size, finish, min_run, r, r_count, & + start + type(run_type) :: runs(0:max_merge_stack-1), left, right + + array_size = size(array, kind=int_size) + +! Very short runs are extended using insertion sort to span at least +! min_run elements. Slices of up to this length are sorted using insertion +! sort. + min_run = calc_min_run( array_size ) + + if ( array_size <= min_run ) then + if ( array_size >= 2 ) call insertion_sort( array ) + return + end if + +! Following Rust sort, natural runs in `array` are identified by traversing +! it backwards. By traversing it backward, merges more often go in the +! opposite direction (forwards). According to developers of Rust sort, +! merging forwards is slightly faster than merging backwards. Therefore +! identifying runs by traversing backwards should improve performance. + r_count = 0 + finish = array_size - 1 + do while ( finish >= 0 ) +! Find the next natural run, and reverse it if it's strictly descending. + start = finish + if ( start > 0 ) then + start = start - 1 + if ( array(start+1) > array(start) ) then + Descending: do while ( start > 0 ) + if ( array(start) <= array(start-1) ) & + exit Descending + start = start - 1 + end do Descending + call reverse_segment( array(start:finish) ) + else + Ascending: do while( start > 0 ) + if ( array(start) > array(start-1) ) exit Ascending + start = start - 1 + end do Ascending + end if + end if + +! If the run is too short insert some more elements using an insertion sort. + Insert: do while ( start > 0 ) + if ( finish - start >= min_run - 1 ) exit Insert + start = start - 1 + call insert_head( array(start:finish) ) + end do Insert + if ( start == 0 .and. finish == array_size - 1 ) return + + runs(r_count) = run_type( base = start, & + len = finish - start + 1 ) + finish = start-1 + r_count = r_count + 1 + +! Determine whether pairs of adjacent runs need to be merged to satisfy +! the invariants, and, if so, merge them. + Merge_loop: do + r = collapse( runs(0:r_count - 1) ) + if ( r < 0 .or. r_count <= 1 ) exit Merge_loop + left = runs( r + 1 ) + right = runs( r ) + call merge( array( left % base: & + right % base + right % len - 1 ), & + left % len, buf ) + + runs(r) = run_type( base = left % base, & + len = left % len + right % len ) + if ( r == r_count - 3 ) runs(r+1) = runs(r+2) + r_count = r_count - 1 + + end do Merge_loop + end do + if ( r_count /= 1 ) & + error stop "MERGE_SORT completed without RUN COUNT == 1." + + end subroutine merge_sort + + + pure subroutine merge( array, mid, buf ) +! Merges the two non-decreasing runs `ARRAY(0:MID-1)` and `ARRAY(MID:)` +! using `BUF` as temporary storage, and stores the merged runs into +! `ARRAY(0:)`. `MID` must be > 0, and < `SIZE(ARRAY)-1`. Buffer `BUF` +! must be long enough to hold the shorter of the two runs. + real(qp), intent(inout) :: array(0:) + integer(int_size), intent(in) :: mid + real(qp), intent(inout) :: buf(0:) + + integer(int_size) :: array_len, i, j, k + + array_len = size(array, kind=int_size) + +! Merge first copies the shorter run into `buf`. Then, depending on which +! run was shorter, it traces the copied run and the longer run forwards +! (or backwards), comparing their next unprocessed elements and then +! copying the lesser (or greater) one into `array`. + + if ( mid <= array_len - mid ) then ! The left run is shorter. + buf(0:mid-1) = array(0:mid-1) + i = 0 + j = mid + merge_lower: do k = 0, array_len-1 + if ( buf(i) >= array(j) ) then + array(k) = buf(i) + i = i + 1 + if ( i >= mid ) exit merge_lower + else + array(k) = array(j) + j = j + 1 + if ( j >= array_len ) then + array(k+1:) = buf(i:mid-1) + exit merge_lower + end if + end if + end do merge_lower + else ! The right run is shorter ! check that it is stable + buf(0:array_len-mid-1) = array(mid:array_len-1) + i = mid - 1 + j = array_len - mid -1 + merge_upper: do k = array_len-1, 0, -1 + if ( buf(j) <= array(i) ) then + array(k) = buf(j) + j = j - 1 + if ( j < 0 ) exit merge_upper + else + array(k) = array(i) + i = i - 1 + if ( i < 0 ) then + array(0:k-1) = buf(0:j) + exit merge_upper + end if + end if + end do merge_upper + end if + end subroutine merge + + + pure subroutine reverse_segment( array ) +! Reverse a segment of an array in place + real(qp), intent(inout) :: array(0:) + + integer(int_size) :: lo, hi + real(qp) :: temp + + lo = 0 + hi = size( array, kind=int_size ) - 1 + do while( lo < hi ) + temp = array(lo) + array(lo) = array(hi) + array(hi) = temp + lo = lo + 1 + hi = hi - 1 + end do + + end subroutine reverse_segment + + end subroutine qp_decrease_ord_sort + + + subroutine string_type_decrease_ord_sort( array, work ) +! A translation to Fortran 2008, of the `"Rust" sort` algorithm found in +! `slice.rs` +! https://github.com/rust-lang/rust/blob/90eb44a5897c39e3dff9c7e48e3973671dcd9496/src/liballoc/slice.rs#L2159 +! The Rust version in turn is a simplification of the Timsort algorithm +! described in +! https://svn.python.org/projects/python/trunk/Objects/listsort.txt, as +! it drops both the use of 'galloping' to identify bounds of regions to be +! sorted and the estimation of the optimal `run size`. However it remains +! a hybrid sorting algorithm combining an iterative Merge sort controlled +! by a stack of `RUNS` identified by regions of uniformly decreasing or +! non-decreasing sequences that may be expanded to a minimum run size and +! initially processed by an insertion sort. +! +! Note the Fortran implementation simplifies the logic as it only has to +! deal with Fortran arrays of intrinsic types and not the full generality +! of Rust's arrays and lists for arbitrary types. It also adds the +! estimation of the optimal `run size` as suggested in Tim Peters' +! original `listsort.txt`, and an optional `work` array to be used as +! scratch memory. + type(string_type), intent(inout) :: array(0:) + type(string_type), intent(out), optional :: work(0:) + + type(string_type), allocatable :: buf(:) + integer(int_size) :: array_size + integer :: stat + + array_size = size( array, kind=int_size ) + if ( present(work) ) then + if ( size( work, kind=int_size) < array_size/2 ) then + error stop "string_type_decrease_ord_sort: work array is too small." + endif +! Use the work array as scratch memory + call merge_sort( array, work ) + else +! Allocate a buffer to use as scratch memory. + allocate( buf(0:array_size/2-1), stat=stat ) + if ( stat /= 0 ) error stop "string_type_decrease_ord_sort: Allocation of buffer failed." + call merge_sort( array, buf ) + end if + + contains + + pure function calc_min_run( n ) result(min_run) +!! Returns the minimum length of a run from 32-63 so that N/MIN_RUN is +!! less than or equal to a power of two. See +!! https://svn.python.org/projects/python/trunk/Objects/listsort.txt + integer(int_size) :: min_run + integer(int_size), intent(in) :: n + + integer(int_size) :: num, r + + num = n + r = 0_int_size + + do while( num >= 64 ) + r = ior( r, iand(num, 1_int_size) ) + num = ishft(num, -1_int_size) + end do + min_run = num + r + + end function calc_min_run + + + pure subroutine insertion_sort( array ) +! Sorts `ARRAY` using an insertion sort. + type(string_type), intent(inout) :: array(0:) + + integer(int_size) :: i, j + type(string_type) :: key + + do j=1, size(array, kind=int_size)-1 + key = array(j) + i = j - 1 + do while( i >= 0 ) + if ( array(i) >= key ) exit + array(i+1) = array(i) + i = i - 1 + end do + array(i+1) = key + end do + + end subroutine insertion_sort + + + pure function collapse( runs ) result ( r ) +! Examine the stack of runs waiting to be merged, identifying adjacent runs +! to be merged until the stack invariants are restablished: +! +! 1. len(-3) > len(-2) + len(-1) +! 2. len(-2) > len(-1) + integer(int_size) :: r + type(run_type), intent(in), target :: runs(0:) + + integer(int_size) :: n + logical :: test + + n = size(runs, kind=int_size) + test = .false. + if (n >= 2) then + if ( runs( n-1 ) % base == 0 .or. & + runs( n-2 ) % len <= runs(n-1) % len ) then + test = .true. + else if ( n >= 3 ) then ! X exists + if ( runs(n-3) % len <= & + runs(n-2) % len + runs(n-1) % len ) then + test = .true. +! |X| <= |Y| + |Z| => will need to merge due to rho1 or rho2 + else if( n >= 4 ) then + if ( runs(n-4) % len <= & + runs(n-3) % len + runs(n-2) % len ) then + test = .true. +! |W| <= |X| + |Y| => will need to merge due to rho1 or rho3 + end if + end if + end if + end if + if ( test ) then +! By default merge Y & Z, rho2 or rho3 + if ( n >= 3 ) then + if ( runs(n-3) % len < runs(n-1) % len ) then + r = n - 3 +! |X| < |Z| => merge X & Y, rho1 + return + end if + end if + r = n - 2 +! |Y| <= |Z| => merge Y & Z, rho4 + return + else + r = -1 + end if + + end function collapse + + + pure subroutine insert_head( array ) +! Inserts `array(0)` into the pre-sorted sequence `array(1:)` so that the +! whole `array(0:)` becomes sorted, copying the first element into +! a temporary variable, iterating until the right place for it is found. +! copying every traversed element into the slot preceding it, and finally, +! copying data from the temporary variable into the resulting hole. + + type(string_type), intent(inout) :: array(0:) + + type(string_type) :: tmp + integer(int_size) :: i + + tmp = array(0) + find_hole: do i=1, size(array, kind=int_size)-1 + if ( array(i) <= tmp ) exit find_hole + array(i-1) = array(i) + end do find_hole + array(i-1) = tmp + + end subroutine insert_head + + + subroutine merge_sort( array, buf ) +! The Rust merge sort borrows some (but not all) of the ideas from TimSort, +! which is described in detail at +! (http://svn.python.org/projects/python/trunk/Objects/listsort.txt). +! +! The algorithm identifies strictly descending and non-descending +! subsequences, which are called natural runs. Where these runs are less +! than a minimum run size they are padded by adding additional samples +! using an insertion sort. The merge process is driven by a stack of +! pending unmerged runs. Each newly found run is pushed onto the stack, +! and then pairs of adjacentd runs are merged until these two invariants +! are satisfied: +! +! 1. for every `i` in `1..size(runs)-1`: `runs(i - 1)%len > runs(i)%len` +! 2. for every `i` in `2..size(runs)-1`: `runs(i - 2)%len > +! runs(i - 1)%len + runs(i)%len` +! +! The invariants ensure that the total running time is `O(n log n)` +! worst-case. + + type(string_type), intent(inout) :: array(0:) + type(string_type), intent(inout) :: buf(0:) + + integer(int_size) :: array_size, finish, min_run, r, r_count, & + start + type(run_type) :: runs(0:max_merge_stack-1), left, right + + array_size = size(array, kind=int_size) + +! Very short runs are extended using insertion sort to span at least +! min_run elements. Slices of up to this length are sorted using insertion +! sort. + min_run = calc_min_run( array_size ) + + if ( array_size <= min_run ) then + if ( array_size >= 2 ) call insertion_sort( array ) + return + end if + +! Following Rust sort, natural runs in `array` are identified by traversing +! it backwards. By traversing it backward, merges more often go in the +! opposite direction (forwards). According to developers of Rust sort, +! merging forwards is slightly faster than merging backwards. Therefore +! identifying runs by traversing backwards should improve performance. + r_count = 0 + finish = array_size - 1 + do while ( finish >= 0 ) +! Find the next natural run, and reverse it if it's strictly descending. + start = finish + if ( start > 0 ) then + start = start - 1 + if ( array(start+1) > array(start) ) then + Descending: do while ( start > 0 ) + if ( array(start) <= array(start-1) ) & + exit Descending + start = start - 1 + end do Descending + call reverse_segment( array(start:finish) ) + else + Ascending: do while( start > 0 ) + if ( array(start) > array(start-1) ) exit Ascending + start = start - 1 + end do Ascending + end if + end if + +! If the run is too short insert some more elements using an insertion sort. + Insert: do while ( start > 0 ) + if ( finish - start >= min_run - 1 ) exit Insert + start = start - 1 + call insert_head( array(start:finish) ) + end do Insert + if ( start == 0 .and. finish == array_size - 1 ) return + + runs(r_count) = run_type( base = start, & + len = finish - start + 1 ) + finish = start-1 + r_count = r_count + 1 + +! Determine whether pairs of adjacent runs need to be merged to satisfy +! the invariants, and, if so, merge them. + Merge_loop: do + r = collapse( runs(0:r_count - 1) ) + if ( r < 0 .or. r_count <= 1 ) exit Merge_loop + left = runs( r + 1 ) + right = runs( r ) + call merge( array( left % base: & + right % base + right % len - 1 ), & + left % len, buf ) + + runs(r) = run_type( base = left % base, & + len = left % len + right % len ) + if ( r == r_count - 3 ) runs(r+1) = runs(r+2) + r_count = r_count - 1 + + end do Merge_loop + end do + if ( r_count /= 1 ) & + error stop "MERGE_SORT completed without RUN COUNT == 1." + + end subroutine merge_sort + + + pure subroutine merge( array, mid, buf ) +! Merges the two non-decreasing runs `ARRAY(0:MID-1)` and `ARRAY(MID:)` +! using `BUF` as temporary storage, and stores the merged runs into +! `ARRAY(0:)`. `MID` must be > 0, and < `SIZE(ARRAY)-1`. Buffer `BUF` +! must be long enough to hold the shorter of the two runs. + type(string_type), intent(inout) :: array(0:) + integer(int_size), intent(in) :: mid + type(string_type), intent(inout) :: buf(0:) + + integer(int_size) :: array_len, i, j, k + + array_len = size(array, kind=int_size) + +! Merge first copies the shorter run into `buf`. Then, depending on which +! run was shorter, it traces the copied run and the longer run forwards +! (or backwards), comparing their next unprocessed elements and then +! copying the lesser (or greater) one into `array`. + + if ( mid <= array_len - mid ) then ! The left run is shorter. + buf(0:mid-1) = array(0:mid-1) + i = 0 + j = mid + merge_lower: do k = 0, array_len-1 + if ( buf(i) >= array(j) ) then + array(k) = buf(i) + i = i + 1 + if ( i >= mid ) exit merge_lower + else + array(k) = array(j) + j = j + 1 + if ( j >= array_len ) then + array(k+1:) = buf(i:mid-1) + exit merge_lower + end if + end if + end do merge_lower + else ! The right run is shorter ! check that it is stable + buf(0:array_len-mid-1) = array(mid:array_len-1) + i = mid - 1 + j = array_len - mid -1 + merge_upper: do k = array_len-1, 0, -1 + if ( buf(j) <= array(i) ) then + array(k) = buf(j) + j = j - 1 + if ( j < 0 ) exit merge_upper + else + array(k) = array(i) + i = i - 1 + if ( i < 0 ) then + array(0:k-1) = buf(0:j) + exit merge_upper + end if + end if + end do merge_upper + end if + end subroutine merge + + + pure subroutine reverse_segment( array ) +! Reverse a segment of an array in place + type(string_type), intent(inout) :: array(0:) + + integer(int_size) :: lo, hi + type(string_type) :: temp + + lo = 0 + hi = size( array, kind=int_size ) - 1 + do while( lo < hi ) + temp = array(lo) + array(lo) = array(hi) + array(hi) = temp + lo = lo + 1 + hi = hi - 1 + end do + + end subroutine reverse_segment + + end subroutine string_type_decrease_ord_sort + + + module subroutine char_ord_sort( array, work, reverse ) + character(len=*), intent(inout) :: array(0:) + character(len=len(array)), intent(out), optional :: work(0:) + logical, intent(in), optional :: reverse + + logical :: reverse_ + + reverse_ = .false. + if(present(reverse)) reverse_ = reverse + + if (reverse_) then + call char_decrease_ord_sort(array, work) + else + call char_increase_ord_sort(array, work) + endif + + end subroutine char_ord_sort + + + subroutine char_increase_ord_sort( array, work ) +! A translation to Fortran 2008, of the `"Rust" sort` algorithm found in +! `slice.rs` +! https://github.com/rust-lang/rust/blob/90eb44a5897c39e3dff9c7e48e3973671dcd9496/src/liballoc/slice.rs#L2159 +! The Rust version in turn is a simplification of the Timsort algorithm +! described in +! https://svn.python.org/projects/python/trunk/Objects/listsort.txt, as +! it drops both the use of 'galloping' to identify bounds of regions to be +! sorted and the estimation of the optimal `run size`. However it remains +! a hybrid sorting algorithm combining an iterative Merge sort controlled +! by a stack of `RUNS` identified by regions of uniformly decreasing or +! non-decreasing sequences that may be expanded to a minimum run size and +! initially processed by an insertion sort. +! +! Note the Fortran implementation simplifies the logic as it only has to +! deal with Fortran arrays of intrinsic types and not the full generality +! of Rust's arrays and lists for arbitrary types. It also adds the +! estimation of the optimal `run size` as suggested in Tim Peters' +! original `listsort.txt`, and an optional `work` array to be used as +! scratch memory. + character(len=*), intent(inout) :: array(0:) + character(len=len(array)), intent(out), optional :: work(0:) + + character(len=:), allocatable :: buf(:) + integer(int_size) :: array_size + integer :: stat + + if ( present(work) ) then +! Use the work array as scratch memory + call merge_sort( array, work ) + else +! Allocate a buffer to use as scratch memory. + array_size = size( array, kind=int_size ) + allocate( character(len=len(array)) :: buf(0:array_size/2-1), & + stat=stat ) + if ( stat /= 0 ) error stop "string_type_increase_ord_sort: Allocation of buffer failed." + call merge_sort( array, buf ) + end if + + contains + + pure function calc_min_run( n ) result(min_run) +!! Returns the minimum length of a run from 32-63 so that N/MIN_RUN is +!! less than or equal to a power of two. See +!! https://svn.python.org/projects/python/trunk/Objects/listsort.txt + integer(int_size) :: min_run + integer(int_size), intent(in) :: n + + integer(int_size) :: num, r + + num = n + r = 0_int_size + + do while( num >= 64 ) + r = ior( r, iand(num, 1_int_size) ) + num = ishft(num, -1_int_size) + end do + min_run = num + r + + end function calc_min_run + + + pure subroutine insertion_sort( array ) +! Sorts `ARRAY` using an insertion sort. + character(len=*), intent(inout) :: array(0:) + + integer(int_size) :: i, j + character(len=len(array)) :: key + + do j=1, size(array, kind=int_size)-1 + key = array(j) + i = j - 1 + do while( i >= 0 ) + if ( array(i) <= key ) exit + array(i+1) = array(i) + i = i - 1 + end do + array(i+1) = key + end do + + end subroutine insertion_sort + + + pure function collapse( runs ) result ( r ) +! Examine the stack of runs waiting to be merged, identifying adjacent runs +! to be merged until the stack invariants are restablished: +! +! 1. len(-3) > len(-2) + len(-1) +! 2. len(-2) > len(-1) + integer(int_size) :: r + type(run_type), intent(in), target :: runs(0:) + + integer(int_size) :: n + logical :: test + + n = size(runs, kind=int_size) + test = .false. + if (n >= 2) then + if ( runs( n-1 ) % base == 0 .or. & + runs( n-2 ) % len <= runs(n-1) % len ) then + test = .true. + else if ( n >= 3 ) then ! X exists + if ( runs(n-3) % len <= & + runs(n-2) % len + runs(n-1) % len ) then + test = .true. +! |X| <= |Y| + |Z| => will need to merge due to rho1 or rho2 + else if( n >= 4 ) then + if ( runs(n-4) % len <= & + runs(n-3) % len + runs(n-2) % len ) then + test = .true. +! |W| <= |X| + |Y| => will need to merge due to rho1 or rho3 + end if + end if + end if + end if + if ( test ) then +! By default merge Y & Z, rho2 or rho3 + if ( n >= 3 ) then + if ( runs(n-3) % len < runs(n-1) % len ) then + r = n - 3 +! |X| < |Z| => merge X & Y, rho1 + return + end if + end if + r = n - 2 +! |Y| <= |Z| => merge Y & Z, rho4 + return + else + r = -1 + end if + + end function collapse + + + pure subroutine insert_head( array ) +! Inserts `array(0)` into the pre-sorted sequence `array(1:)` so that the +! whole `array(0:)` becomes sorted, copying the first element into +! a temporary variable, iterating until the right place for it is found. +! copying every traversed element into the slot preceding it, and finally, +! copying data from the temporary variable into the resulting hole. + + character(len=*), intent(inout) :: array(0:) + + character(len=len(array)) :: tmp + integer(int_size) :: i + + tmp = array(0) + find_hole: do i=1, size(array, kind=int_size)-1 + if ( array(i) >= tmp ) exit find_hole + array(i-1) = array(i) + end do find_hole + array(i-1) = tmp + + end subroutine insert_head + + + subroutine merge_sort( array, buf ) +! The Rust merge sort borrows some (but not all) of the ideas from TimSort, +! which is described in detail at +! (http://svn.python.org/projects/python/trunk/Objects/listsort.txt). +! +! The algorithm identifies strictly descending and non-descending +! subsequences, which are called natural runs. Where these runs are less +! than a minimum run size they are padded by adding additional samples +! using an insertion sort. The merge process is driven by a stack of +! pending unmerged runs. Each newly found run is pushed onto the stack, +! and then pairs of adjacentd runs are merged until these two invariants +! are satisfied: +! +! 1. for every `i` in `1..size(runs)-1`: `runs(i - 1)%len > runs(i)%len` +! 2. for every `i` in `2..size(runs)-1`: `runs(i - 2)%len > +! runs(i - 1)%len + runs(i)%len` +! +! The invariants ensure that the total running time is `O(n log n)` +! worst-case. + + character(len=*), intent(inout) :: array(0:) + character(len=len(array)), intent(inout) :: buf(0:) + + integer(int_size) :: array_size, finish, min_run, r, r_count, & + start + type(run_type) :: runs(0:max_merge_stack-1), left, right + + array_size = size(array, kind=int_size) + +! Very short runs are extended using insertion sort to span at least +! min_run elements. Slices of up to this length are sorted using insertion +! sort. + min_run = calc_min_run( array_size ) + + if ( array_size <= min_run ) then + if ( array_size >= 2 ) call insertion_sort( array ) + return + end if + +! Following Rust sort, natural runs in `array` are identified by traversing +! it backwards. By traversing it backward, merges more often go in the +! opposite direction (forwards). According to developers of Rust sort, +! merging forwards is slightly faster than merging backwards. Therefore +! identifying runs by traversing backwards should improve performance. + r_count = 0 + finish = array_size - 1 + do while ( finish >= 0 ) +! Find the next natural run, and reverse it if it's strictly descending. + start = finish + if ( start > 0 ) then + start = start - 1 + if ( array(start+1) < array(start) ) then + Descending: do while ( start > 0 ) + if ( array(start) >= array(start-1) ) & + exit Descending + start = start - 1 + end do Descending + call reverse_segment( array(start:finish) ) + else + Ascending: do while( start > 0 ) + if ( array(start) < array(start-1) ) exit Ascending + start = start - 1 + end do Ascending + end if + end if + +! If the run is too short insert some more elements using an insertion sort. + Insert: do while ( start > 0 ) + if ( finish - start >= min_run - 1 ) exit Insert + start = start - 1 + call insert_head( array(start:finish) ) + end do Insert + if ( start == 0 .and. finish == array_size - 1 ) return + + runs(r_count) = run_type( base = start, & + len = finish - start + 1 ) + finish = start-1 + r_count = r_count + 1 + +! Determine whether pairs of adjacent runs need to be merged to satisfy +! the invariants, and, if so, merge them. + Merge_loop: do + r = collapse( runs(0:r_count - 1) ) + if ( r < 0 .or. r_count <= 1 ) exit Merge_loop + left = runs( r + 1 ) + right = runs( r ) + call merge( array( left % base: & + right % base + right % len - 1 ), & + left % len, buf ) + + runs(r) = run_type( base = left % base, & + len = left % len + right % len ) + if ( r == r_count - 3 ) runs(r+1) = runs(r+2) + r_count = r_count - 1 + + end do Merge_loop + end do + if ( r_count /= 1 ) & + error stop "MERGE_SORT completed without RUN COUNT == 1." + + end subroutine merge_sort + + + pure subroutine merge( array, mid, buf ) +! Merges the two non-decreasing runs `ARRAY(0:MID-1)` and `ARRAY(MID:)` +! using `BUF` as temporary storage, and stores the merged runs into +! `ARRAY(0:)`. `MID` must be > 0, and < `SIZE(ARRAY)-1`. Buffer `BUF` +! must be long enough to hold the shorter of the two runs. + character(len=*), intent(inout) :: array(0:) + integer(int_size), intent(in) :: mid + character(len=len(array)), intent(inout) :: buf(0:) + + integer(int_size) :: array_len, i, j, k + + array_len = size(array, kind=int_size) + +! Merge first copies the shorter run into `buf`. Then, depending on which +! run was shorter, it traces the copied run and the longer run forwards +! (or backwards), comparing their next unprocessed elements and then +! copying the lesser (or greater) one into `array`. + + if ( mid <= array_len - mid ) then ! The left run is shorter. + buf(0:mid-1) = array(0:mid-1) + i = 0 + j = mid + merge_lower: do k = 0, array_len-1 + if ( buf(i) <= array(j) ) then + array(k) = buf(i) + i = i + 1 + if ( i >= mid ) exit merge_lower + else + array(k) = array(j) + j = j + 1 + if ( j >= array_len ) then + array(k+1:) = buf(i:mid-1) + exit merge_lower + end if + end if + end do merge_lower + else ! The right run is shorter ! check that it is stable + buf(0:array_len-mid-1) = array(mid:array_len-1) + i = mid - 1 + j = array_len - mid -1 + merge_upper: do k = array_len-1, 0, -1 + if ( buf(j) >= array(i) ) then + array(k) = buf(j) + j = j - 1 + if ( j < 0 ) exit merge_upper + else + array(k) = array(i) + i = i - 1 + if ( i < 0 ) then + array(0:k-1) = buf(0:j) + exit merge_upper + end if + end if + end do merge_upper + end if + end subroutine merge + + + pure subroutine reverse_segment( array ) +! Reverse a segment of an array in place + character(len=*), intent(inout) :: array(0:) + + integer(int_size) :: lo, hi + character(len=len(array)) :: temp + + lo = 0 + hi = size( array, kind=int_size ) - 1 + do while( lo < hi ) + temp = array(lo) + array(lo) = array(hi) + array(hi) = temp + lo = lo + 1 + hi = hi - 1 + end do + + end subroutine reverse_segment + + end subroutine char_increase_ord_sort + subroutine char_decrease_ord_sort( array, work ) +! A translation to Fortran 2008, of the `"Rust" sort` algorithm found in +! `slice.rs` +! https://github.com/rust-lang/rust/blob/90eb44a5897c39e3dff9c7e48e3973671dcd9496/src/liballoc/slice.rs#L2159 +! The Rust version in turn is a simplification of the Timsort algorithm +! described in +! https://svn.python.org/projects/python/trunk/Objects/listsort.txt, as +! it drops both the use of 'galloping' to identify bounds of regions to be +! sorted and the estimation of the optimal `run size`. However it remains +! a hybrid sorting algorithm combining an iterative Merge sort controlled +! by a stack of `RUNS` identified by regions of uniformly decreasing or +! non-decreasing sequences that may be expanded to a minimum run size and +! initially processed by an insertion sort. +! +! Note the Fortran implementation simplifies the logic as it only has to +! deal with Fortran arrays of intrinsic types and not the full generality +! of Rust's arrays and lists for arbitrary types. It also adds the +! estimation of the optimal `run size` as suggested in Tim Peters' +! original `listsort.txt`, and an optional `work` array to be used as +! scratch memory. + character(len=*), intent(inout) :: array(0:) + character(len=len(array)), intent(out), optional :: work(0:) + + character(len=:), allocatable :: buf(:) + integer(int_size) :: array_size + integer :: stat + + if ( present(work) ) then +! Use the work array as scratch memory + call merge_sort( array, work ) + else +! Allocate a buffer to use as scratch memory. + array_size = size( array, kind=int_size ) + allocate( character(len=len(array)) :: buf(0:array_size/2-1), & + stat=stat ) + if ( stat /= 0 ) error stop "string_type_decrease_ord_sort: Allocation of buffer failed." + call merge_sort( array, buf ) + end if + + contains + + pure function calc_min_run( n ) result(min_run) +!! Returns the minimum length of a run from 32-63 so that N/MIN_RUN is +!! less than or equal to a power of two. See +!! https://svn.python.org/projects/python/trunk/Objects/listsort.txt + integer(int_size) :: min_run + integer(int_size), intent(in) :: n + + integer(int_size) :: num, r + + num = n + r = 0_int_size + + do while( num >= 64 ) + r = ior( r, iand(num, 1_int_size) ) + num = ishft(num, -1_int_size) + end do + min_run = num + r + + end function calc_min_run + + + pure subroutine insertion_sort( array ) +! Sorts `ARRAY` using an insertion sort. + character(len=*), intent(inout) :: array(0:) + + integer(int_size) :: i, j + character(len=len(array)) :: key + + do j=1, size(array, kind=int_size)-1 + key = array(j) + i = j - 1 + do while( i >= 0 ) + if ( array(i) >= key ) exit + array(i+1) = array(i) + i = i - 1 + end do + array(i+1) = key + end do + + end subroutine insertion_sort + + + pure function collapse( runs ) result ( r ) +! Examine the stack of runs waiting to be merged, identifying adjacent runs +! to be merged until the stack invariants are restablished: +! +! 1. len(-3) > len(-2) + len(-1) +! 2. len(-2) > len(-1) + integer(int_size) :: r + type(run_type), intent(in), target :: runs(0:) + + integer(int_size) :: n + logical :: test + + n = size(runs, kind=int_size) + test = .false. + if (n >= 2) then + if ( runs( n-1 ) % base == 0 .or. & + runs( n-2 ) % len <= runs(n-1) % len ) then + test = .true. + else if ( n >= 3 ) then ! X exists + if ( runs(n-3) % len <= & + runs(n-2) % len + runs(n-1) % len ) then + test = .true. +! |X| <= |Y| + |Z| => will need to merge due to rho1 or rho2 + else if( n >= 4 ) then + if ( runs(n-4) % len <= & + runs(n-3) % len + runs(n-2) % len ) then + test = .true. +! |W| <= |X| + |Y| => will need to merge due to rho1 or rho3 + end if + end if + end if + end if + if ( test ) then +! By default merge Y & Z, rho2 or rho3 + if ( n >= 3 ) then + if ( runs(n-3) % len < runs(n-1) % len ) then + r = n - 3 +! |X| < |Z| => merge X & Y, rho1 + return + end if + end if + r = n - 2 +! |Y| <= |Z| => merge Y & Z, rho4 + return + else + r = -1 + end if + + end function collapse + + + pure subroutine insert_head( array ) +! Inserts `array(0)` into the pre-sorted sequence `array(1:)` so that the +! whole `array(0:)` becomes sorted, copying the first element into +! a temporary variable, iterating until the right place for it is found. +! copying every traversed element into the slot preceding it, and finally, +! copying data from the temporary variable into the resulting hole. + + character(len=*), intent(inout) :: array(0:) + + character(len=len(array)) :: tmp + integer(int_size) :: i + + tmp = array(0) + find_hole: do i=1, size(array, kind=int_size)-1 + if ( array(i) <= tmp ) exit find_hole + array(i-1) = array(i) + end do find_hole + array(i-1) = tmp + + end subroutine insert_head + + + subroutine merge_sort( array, buf ) +! The Rust merge sort borrows some (but not all) of the ideas from TimSort, +! which is described in detail at +! (http://svn.python.org/projects/python/trunk/Objects/listsort.txt). +! +! The algorithm identifies strictly descending and non-descending +! subsequences, which are called natural runs. Where these runs are less +! than a minimum run size they are padded by adding additional samples +! using an insertion sort. The merge process is driven by a stack of +! pending unmerged runs. Each newly found run is pushed onto the stack, +! and then pairs of adjacentd runs are merged until these two invariants +! are satisfied: +! +! 1. for every `i` in `1..size(runs)-1`: `runs(i - 1)%len > runs(i)%len` +! 2. for every `i` in `2..size(runs)-1`: `runs(i - 2)%len > +! runs(i - 1)%len + runs(i)%len` +! +! The invariants ensure that the total running time is `O(n log n)` +! worst-case. + + character(len=*), intent(inout) :: array(0:) + character(len=len(array)), intent(inout) :: buf(0:) + + integer(int_size) :: array_size, finish, min_run, r, r_count, & + start + type(run_type) :: runs(0:max_merge_stack-1), left, right + + array_size = size(array, kind=int_size) + +! Very short runs are extended using insertion sort to span at least +! min_run elements. Slices of up to this length are sorted using insertion +! sort. + min_run = calc_min_run( array_size ) + + if ( array_size <= min_run ) then + if ( array_size >= 2 ) call insertion_sort( array ) + return + end if + +! Following Rust sort, natural runs in `array` are identified by traversing +! it backwards. By traversing it backward, merges more often go in the +! opposite direction (forwards). According to developers of Rust sort, +! merging forwards is slightly faster than merging backwards. Therefore +! identifying runs by traversing backwards should improve performance. + r_count = 0 + finish = array_size - 1 + do while ( finish >= 0 ) +! Find the next natural run, and reverse it if it's strictly descending. + start = finish + if ( start > 0 ) then + start = start - 1 + if ( array(start+1) > array(start) ) then + Descending: do while ( start > 0 ) + if ( array(start) <= array(start-1) ) & + exit Descending + start = start - 1 + end do Descending + call reverse_segment( array(start:finish) ) + else + Ascending: do while( start > 0 ) + if ( array(start) > array(start-1) ) exit Ascending + start = start - 1 + end do Ascending + end if + end if + +! If the run is too short insert some more elements using an insertion sort. + Insert: do while ( start > 0 ) + if ( finish - start >= min_run - 1 ) exit Insert + start = start - 1 + call insert_head( array(start:finish) ) + end do Insert + if ( start == 0 .and. finish == array_size - 1 ) return + + runs(r_count) = run_type( base = start, & + len = finish - start + 1 ) + finish = start-1 + r_count = r_count + 1 + +! Determine whether pairs of adjacent runs need to be merged to satisfy +! the invariants, and, if so, merge them. + Merge_loop: do + r = collapse( runs(0:r_count - 1) ) + if ( r < 0 .or. r_count <= 1 ) exit Merge_loop + left = runs( r + 1 ) + right = runs( r ) + call merge( array( left % base: & + right % base + right % len - 1 ), & + left % len, buf ) + + runs(r) = run_type( base = left % base, & + len = left % len + right % len ) + if ( r == r_count - 3 ) runs(r+1) = runs(r+2) + r_count = r_count - 1 + + end do Merge_loop + end do + if ( r_count /= 1 ) & + error stop "MERGE_SORT completed without RUN COUNT == 1." + + end subroutine merge_sort + + + pure subroutine merge( array, mid, buf ) +! Merges the two non-decreasing runs `ARRAY(0:MID-1)` and `ARRAY(MID:)` +! using `BUF` as temporary storage, and stores the merged runs into +! `ARRAY(0:)`. `MID` must be > 0, and < `SIZE(ARRAY)-1`. Buffer `BUF` +! must be long enough to hold the shorter of the two runs. + character(len=*), intent(inout) :: array(0:) + integer(int_size), intent(in) :: mid + character(len=len(array)), intent(inout) :: buf(0:) + + integer(int_size) :: array_len, i, j, k + + array_len = size(array, kind=int_size) + +! Merge first copies the shorter run into `buf`. Then, depending on which +! run was shorter, it traces the copied run and the longer run forwards +! (or backwards), comparing their next unprocessed elements and then +! copying the lesser (or greater) one into `array`. + + if ( mid <= array_len - mid ) then ! The left run is shorter. + buf(0:mid-1) = array(0:mid-1) + i = 0 + j = mid + merge_lower: do k = 0, array_len-1 + if ( buf(i) >= array(j) ) then + array(k) = buf(i) + i = i + 1 + if ( i >= mid ) exit merge_lower + else + array(k) = array(j) + j = j + 1 + if ( j >= array_len ) then + array(k+1:) = buf(i:mid-1) + exit merge_lower + end if + end if + end do merge_lower + else ! The right run is shorter ! check that it is stable + buf(0:array_len-mid-1) = array(mid:array_len-1) + i = mid - 1 + j = array_len - mid -1 + merge_upper: do k = array_len-1, 0, -1 + if ( buf(j) <= array(i) ) then + array(k) = buf(j) + j = j - 1 + if ( j < 0 ) exit merge_upper + else + array(k) = array(i) + i = i - 1 + if ( i < 0 ) then + array(0:k-1) = buf(0:j) + exit merge_upper + end if + end if + end do merge_upper + end if + end subroutine merge + + + pure subroutine reverse_segment( array ) +! Reverse a segment of an array in place + character(len=*), intent(inout) :: array(0:) + + integer(int_size) :: lo, hi + character(len=len(array)) :: temp + + lo = 0 + hi = size( array, kind=int_size ) - 1 + do while( lo < hi ) + temp = array(lo) + array(lo) = array(hi) + array(hi) = temp + lo = lo + 1 + hi = hi - 1 + end do + + end subroutine reverse_segment + + end subroutine char_decrease_ord_sort + +end submodule stdlib_sorting_ord_sort + diff --git a/src/fpm/stdlib_sorting_sort.f90 b/src/fpm/stdlib_sorting_sort.f90 new file mode 100644 index 000000000..4d1e2801a --- /dev/null +++ b/src/fpm/stdlib_sorting_sort.f90 @@ -0,0 +1,3188 @@ + + +!! Licensing: +!! +!! This file is subjec† both to the Fortran Standard Library license, and +!! to additional licensing requirements as it contains translations of +!! other software. +!! +!! The Fortran Standard Library, including this file, is distributed under +!! the MIT license that should be included with the library's distribution. +!! +!! Copyright (c) 2021 Fortran stdlib developers +!! +!! Permission is hereby granted, free of charge, to any person obtaining a +!! copy of this software and associated documentation files (the +!! "Software"), to deal in the Software without restriction, including +!! without limitation the rights to use, copy, modify, merge, publish, +!! distribute, sublicense, and/or sellcopies of the Software, and to permit +!! persons to whom the Software is furnished to do so, subject to the +!! following conditions: +!! +!! The above copyright notice and this permission notice shall be included +!! in all copies or substantial portions of the Software. +!! +!! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS +!! OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +!! MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +!! IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +!! CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +!! TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +!! SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +!! +!! The generic subroutine, `SORT`, is substantially a +!! translation to Fortran 2008, of the `introsort` of David Musser. +!! David Musser has given permission to include a variant of `introsort` +!! in the Fortran Standard Library under the MIT license provided +!! we cite: +!! +!! Musser, D.R., “Introspective Sorting and Selection Algorithms,” +!! Software—Practice and Experience, Vol. 27(8), 983–993 (August 1997). +!! +!! as the official source of the algorithm. + +submodule(stdlib_sorting) stdlib_sorting_sort +!! This submodule implements the overloaded sorting subroutine `SORT` +!! that can be used to sort four kinds of `INTEGER` arrays and three kinds +!! of `REAL` arrays. Sorting is in order of increasing value, with the worst +!! case run time performance of `O(N Ln(N))`. +!! +!! `SORT` uses the `INTROSORT` sorting algorithm of David Musser, +!! http://www.cs.rpi.edu/~musser/gp/introsort.ps. `introsort` is a hybrid +!! unstable comparison algorithm combining `quicksort`, `insertion sort`, and +!! `heap sort`. While this algorithm is always O(N Ln(N)) it is relatively +!! fast on randomly ordered data, but inconsistent in performance on partly +!! sorted data, sometimes having `merge sort` performance, sometimes having +!! better than `quicksort` performance. + + implicit none + +contains + + pure module subroutine int8_sort( array, reverse ) + integer(int8), intent(inout) :: array(0:) + logical, intent(in), optional :: reverse + + logical :: reverse_ + + reverse_ = .false. + if(present(reverse)) reverse_ = reverse + + if(reverse_)then + call int8_decrease_sort(array) + else + call int8_increase_sort(array) + endif + end subroutine int8_sort + pure module subroutine int16_sort( array, reverse ) + integer(int16), intent(inout) :: array(0:) + logical, intent(in), optional :: reverse + + logical :: reverse_ + + reverse_ = .false. + if(present(reverse)) reverse_ = reverse + + if(reverse_)then + call int16_decrease_sort(array) + else + call int16_increase_sort(array) + endif + end subroutine int16_sort + pure module subroutine int32_sort( array, reverse ) + integer(int32), intent(inout) :: array(0:) + logical, intent(in), optional :: reverse + + logical :: reverse_ + + reverse_ = .false. + if(present(reverse)) reverse_ = reverse + + if(reverse_)then + call int32_decrease_sort(array) + else + call int32_increase_sort(array) + endif + end subroutine int32_sort + pure module subroutine int64_sort( array, reverse ) + integer(int64), intent(inout) :: array(0:) + logical, intent(in), optional :: reverse + + logical :: reverse_ + + reverse_ = .false. + if(present(reverse)) reverse_ = reverse + + if(reverse_)then + call int64_decrease_sort(array) + else + call int64_increase_sort(array) + endif + end subroutine int64_sort + pure module subroutine sp_sort( array, reverse ) + real(sp), intent(inout) :: array(0:) + logical, intent(in), optional :: reverse + + logical :: reverse_ + + reverse_ = .false. + if(present(reverse)) reverse_ = reverse + + if(reverse_)then + call sp_decrease_sort(array) + else + call sp_increase_sort(array) + endif + end subroutine sp_sort + pure module subroutine dp_sort( array, reverse ) + real(dp), intent(inout) :: array(0:) + logical, intent(in), optional :: reverse + + logical :: reverse_ + + reverse_ = .false. + if(present(reverse)) reverse_ = reverse + + if(reverse_)then + call dp_decrease_sort(array) + else + call dp_increase_sort(array) + endif + end subroutine dp_sort + pure module subroutine qp_sort( array, reverse ) + real(qp), intent(inout) :: array(0:) + logical, intent(in), optional :: reverse + + logical :: reverse_ + + reverse_ = .false. + if(present(reverse)) reverse_ = reverse + + if(reverse_)then + call qp_decrease_sort(array) + else + call qp_increase_sort(array) + endif + end subroutine qp_sort + pure module subroutine string_type_sort( array, reverse ) + type(string_type), intent(inout) :: array(0:) + logical, intent(in), optional :: reverse + + logical :: reverse_ + + reverse_ = .false. + if(present(reverse)) reverse_ = reverse + + if(reverse_)then + call string_type_decrease_sort(array) + else + call string_type_increase_sort(array) + endif + end subroutine string_type_sort + + + pure subroutine int8_increase_sort( array ) +! `int8_increase_sort( array )` sorts the input `ARRAY` of type `integer(int8)` +! using a hybrid sort based on the `introsort` of David Musser. As with +! `introsort`, `int8_increase_sort( array )` is an unstable hybrid comparison +! algorithm using `quicksort` for the main body of the sort tree, +! supplemented by `insertion sort` for the outer branches, but if +! `quicksort` is converging too slowly the algorithm resorts +! to `heapsort`. The algorithm is of order O(N Ln(N)) for all inputs. +! Because it relies on `quicksort`, the coefficient of the O(N Ln(N)) +! behavior is typically small compared to other sorting algorithms. + + integer(int8), intent(inout) :: array(0:) + + integer(int32) :: depth_limit + + depth_limit = 2 * int( floor( log( real( size( array, kind=int_size), & + kind=dp) ) / log(2.0_dp) ), & + kind=int32 ) + call introsort(array, depth_limit) + + contains + + pure recursive subroutine introsort( array, depth_limit ) +! It devolves to `insertionsort` if the remaining number of elements +! is fewer than or equal to `INSERT_SIZE`, `heapsort` if the completion +! of the `quicksort` is too slow as estimated from `DEPTH_LIMIT`, +! otherwise sorting is done by a `quicksort`. + integer(int8), intent(inout) :: array(0:) + integer(int32), intent(in) :: depth_limit + + integer(int_size), parameter :: insert_size = 16_int_size + integer(int_size) :: index + + if ( size(array, kind=int_size) <= insert_size ) then + ! May be best at the end of SORT processing the whole array + ! See Musser, D.R., “Introspective Sorting and Selection + ! Algorithms,” Software—Practice and Experience, Vol. 27(8), + ! 983–993 (August 1997). + + call insertion_sort( array ) + else if ( depth_limit == 0 ) then + call heap_sort( array ) + else + call partition( array, index ) + call introsort( array(0:index-1), depth_limit-1 ) + call introsort( array(index+1:), depth_limit-1 ) + end if + + end subroutine introsort + + + pure subroutine partition( array, index ) +! quicksort partition using median of three. + integer(int8), intent(inout) :: array(0:) + integer(int_size), intent(out) :: index + + integer(int8) :: u, v, w, x, y + integer(int_size) :: i, j + +! Determine median of three and exchange it with the end. + u = array( 0 ) + v = array( size(array, kind=int_size)/2-1 ) + w = array( size(array, kind=int_size)-1 ) + if ( (u > v) .neqv. (u > w) ) then + x = u + y = array(0) + array(0) = array( size( array, kind=int_size ) - 1 ) + array( size( array, kind=int_size ) - 1 ) = y + else if ( (v < u) .neqv. (v < w) ) then + x = v + y = array(size( array, kind=int_size )/2-1) + array( size( array, kind=int_size )/2-1 ) = & + array( size( array, kind=int_size )-1 ) + array( size( array, kind=int_size )-1 ) = y + else + x = w + end if +! Partition the array. + i = -1_int_size + do j = 0_int_size, size(array, kind=int_size)-2 + if ( array(j) <= x ) then + i = i + 1 + y = array(i) + array(i) = array(j) + array(j) = y + end if + end do + y = array(i+1) + array(i+1) = array(size(array, kind=int_size)-1) + array(size(array, kind=int_size)-1) = y + index = i + 1 + + end subroutine partition + + pure subroutine insertion_sort( array ) +! Bog standard insertion sort. + integer(int8), intent(inout) :: array(0:) + + integer(int_size) :: i, j + integer(int8) :: key + + do j=1_int_size, size(array, kind=int_size)-1 + key = array(j) + i = j - 1 + do while( i >= 0 ) + if ( array(i) <= key ) exit + array(i+1) = array(i) + i = i - 1 + end do + array(i+1) = key + end do + + end subroutine insertion_sort + + pure subroutine heap_sort( array ) +! A bog standard heap sort + integer(int8), intent(inout) :: array(0:) + + integer(int_size) :: i, heap_size + integer(int8) :: y + + heap_size = size( array, kind=int_size ) +! Build the max heap + do i = (heap_size-2)/2_int_size, 0_int_size, -1_int_size + call max_heapify( array, i, heap_size ) + end do + do i = heap_size-1, 1_int_size, -1_int_size +! Swap the first element with the current final element + y = array(0) + array(0) = array(i) + array(i) = y +! Sift down using max_heapify + call max_heapify( array, 0_int_size, i ) + end do + + end subroutine heap_sort + + pure recursive subroutine max_heapify( array, i, heap_size ) +! Transform the array into a max heap + integer(int8), intent(inout) :: array(0:) + integer(int_size), intent(in) :: i, heap_size + + integer(int_size) :: l, r, largest + integer(int8) :: y + + largest = i + l = 2_int_size * i + 1_int_size + r = l + 1_int_size + if ( l < heap_size ) then + if ( array(l) > array(largest) ) largest = l + end if + if ( r < heap_size ) then + if ( array(r) > array(largest) ) largest = r + end if + if ( largest /= i ) then + y = array(i) + array(i) = array(largest) + array(largest) = y + call max_heapify( array, largest, heap_size ) + end if + + end subroutine max_heapify + + end subroutine int8_increase_sort + + + pure subroutine int16_increase_sort( array ) +! `int16_increase_sort( array )` sorts the input `ARRAY` of type `integer(int16)` +! using a hybrid sort based on the `introsort` of David Musser. As with +! `introsort`, `int16_increase_sort( array )` is an unstable hybrid comparison +! algorithm using `quicksort` for the main body of the sort tree, +! supplemented by `insertion sort` for the outer branches, but if +! `quicksort` is converging too slowly the algorithm resorts +! to `heapsort`. The algorithm is of order O(N Ln(N)) for all inputs. +! Because it relies on `quicksort`, the coefficient of the O(N Ln(N)) +! behavior is typically small compared to other sorting algorithms. + + integer(int16), intent(inout) :: array(0:) + + integer(int32) :: depth_limit + + depth_limit = 2 * int( floor( log( real( size( array, kind=int_size), & + kind=dp) ) / log(2.0_dp) ), & + kind=int32 ) + call introsort(array, depth_limit) + + contains + + pure recursive subroutine introsort( array, depth_limit ) +! It devolves to `insertionsort` if the remaining number of elements +! is fewer than or equal to `INSERT_SIZE`, `heapsort` if the completion +! of the `quicksort` is too slow as estimated from `DEPTH_LIMIT`, +! otherwise sorting is done by a `quicksort`. + integer(int16), intent(inout) :: array(0:) + integer(int32), intent(in) :: depth_limit + + integer(int_size), parameter :: insert_size = 16_int_size + integer(int_size) :: index + + if ( size(array, kind=int_size) <= insert_size ) then + ! May be best at the end of SORT processing the whole array + ! See Musser, D.R., “Introspective Sorting and Selection + ! Algorithms,” Software—Practice and Experience, Vol. 27(8), + ! 983–993 (August 1997). + + call insertion_sort( array ) + else if ( depth_limit == 0 ) then + call heap_sort( array ) + else + call partition( array, index ) + call introsort( array(0:index-1), depth_limit-1 ) + call introsort( array(index+1:), depth_limit-1 ) + end if + + end subroutine introsort + + + pure subroutine partition( array, index ) +! quicksort partition using median of three. + integer(int16), intent(inout) :: array(0:) + integer(int_size), intent(out) :: index + + integer(int16) :: u, v, w, x, y + integer(int_size) :: i, j + +! Determine median of three and exchange it with the end. + u = array( 0 ) + v = array( size(array, kind=int_size)/2-1 ) + w = array( size(array, kind=int_size)-1 ) + if ( (u > v) .neqv. (u > w) ) then + x = u + y = array(0) + array(0) = array( size( array, kind=int_size ) - 1 ) + array( size( array, kind=int_size ) - 1 ) = y + else if ( (v < u) .neqv. (v < w) ) then + x = v + y = array(size( array, kind=int_size )/2-1) + array( size( array, kind=int_size )/2-1 ) = & + array( size( array, kind=int_size )-1 ) + array( size( array, kind=int_size )-1 ) = y + else + x = w + end if +! Partition the array. + i = -1_int_size + do j = 0_int_size, size(array, kind=int_size)-2 + if ( array(j) <= x ) then + i = i + 1 + y = array(i) + array(i) = array(j) + array(j) = y + end if + end do + y = array(i+1) + array(i+1) = array(size(array, kind=int_size)-1) + array(size(array, kind=int_size)-1) = y + index = i + 1 + + end subroutine partition + + pure subroutine insertion_sort( array ) +! Bog standard insertion sort. + integer(int16), intent(inout) :: array(0:) + + integer(int_size) :: i, j + integer(int16) :: key + + do j=1_int_size, size(array, kind=int_size)-1 + key = array(j) + i = j - 1 + do while( i >= 0 ) + if ( array(i) <= key ) exit + array(i+1) = array(i) + i = i - 1 + end do + array(i+1) = key + end do + + end subroutine insertion_sort + + pure subroutine heap_sort( array ) +! A bog standard heap sort + integer(int16), intent(inout) :: array(0:) + + integer(int_size) :: i, heap_size + integer(int16) :: y + + heap_size = size( array, kind=int_size ) +! Build the max heap + do i = (heap_size-2)/2_int_size, 0_int_size, -1_int_size + call max_heapify( array, i, heap_size ) + end do + do i = heap_size-1, 1_int_size, -1_int_size +! Swap the first element with the current final element + y = array(0) + array(0) = array(i) + array(i) = y +! Sift down using max_heapify + call max_heapify( array, 0_int_size, i ) + end do + + end subroutine heap_sort + + pure recursive subroutine max_heapify( array, i, heap_size ) +! Transform the array into a max heap + integer(int16), intent(inout) :: array(0:) + integer(int_size), intent(in) :: i, heap_size + + integer(int_size) :: l, r, largest + integer(int16) :: y + + largest = i + l = 2_int_size * i + 1_int_size + r = l + 1_int_size + if ( l < heap_size ) then + if ( array(l) > array(largest) ) largest = l + end if + if ( r < heap_size ) then + if ( array(r) > array(largest) ) largest = r + end if + if ( largest /= i ) then + y = array(i) + array(i) = array(largest) + array(largest) = y + call max_heapify( array, largest, heap_size ) + end if + + end subroutine max_heapify + + end subroutine int16_increase_sort + + + pure subroutine int32_increase_sort( array ) +! `int32_increase_sort( array )` sorts the input `ARRAY` of type `integer(int32)` +! using a hybrid sort based on the `introsort` of David Musser. As with +! `introsort`, `int32_increase_sort( array )` is an unstable hybrid comparison +! algorithm using `quicksort` for the main body of the sort tree, +! supplemented by `insertion sort` for the outer branches, but if +! `quicksort` is converging too slowly the algorithm resorts +! to `heapsort`. The algorithm is of order O(N Ln(N)) for all inputs. +! Because it relies on `quicksort`, the coefficient of the O(N Ln(N)) +! behavior is typically small compared to other sorting algorithms. + + integer(int32), intent(inout) :: array(0:) + + integer(int32) :: depth_limit + + depth_limit = 2 * int( floor( log( real( size( array, kind=int_size), & + kind=dp) ) / log(2.0_dp) ), & + kind=int32 ) + call introsort(array, depth_limit) + + contains + + pure recursive subroutine introsort( array, depth_limit ) +! It devolves to `insertionsort` if the remaining number of elements +! is fewer than or equal to `INSERT_SIZE`, `heapsort` if the completion +! of the `quicksort` is too slow as estimated from `DEPTH_LIMIT`, +! otherwise sorting is done by a `quicksort`. + integer(int32), intent(inout) :: array(0:) + integer(int32), intent(in) :: depth_limit + + integer(int_size), parameter :: insert_size = 16_int_size + integer(int_size) :: index + + if ( size(array, kind=int_size) <= insert_size ) then + ! May be best at the end of SORT processing the whole array + ! See Musser, D.R., “Introspective Sorting and Selection + ! Algorithms,” Software—Practice and Experience, Vol. 27(8), + ! 983–993 (August 1997). + + call insertion_sort( array ) + else if ( depth_limit == 0 ) then + call heap_sort( array ) + else + call partition( array, index ) + call introsort( array(0:index-1), depth_limit-1 ) + call introsort( array(index+1:), depth_limit-1 ) + end if + + end subroutine introsort + + + pure subroutine partition( array, index ) +! quicksort partition using median of three. + integer(int32), intent(inout) :: array(0:) + integer(int_size), intent(out) :: index + + integer(int32) :: u, v, w, x, y + integer(int_size) :: i, j + +! Determine median of three and exchange it with the end. + u = array( 0 ) + v = array( size(array, kind=int_size)/2-1 ) + w = array( size(array, kind=int_size)-1 ) + if ( (u > v) .neqv. (u > w) ) then + x = u + y = array(0) + array(0) = array( size( array, kind=int_size ) - 1 ) + array( size( array, kind=int_size ) - 1 ) = y + else if ( (v < u) .neqv. (v < w) ) then + x = v + y = array(size( array, kind=int_size )/2-1) + array( size( array, kind=int_size )/2-1 ) = & + array( size( array, kind=int_size )-1 ) + array( size( array, kind=int_size )-1 ) = y + else + x = w + end if +! Partition the array. + i = -1_int_size + do j = 0_int_size, size(array, kind=int_size)-2 + if ( array(j) <= x ) then + i = i + 1 + y = array(i) + array(i) = array(j) + array(j) = y + end if + end do + y = array(i+1) + array(i+1) = array(size(array, kind=int_size)-1) + array(size(array, kind=int_size)-1) = y + index = i + 1 + + end subroutine partition + + pure subroutine insertion_sort( array ) +! Bog standard insertion sort. + integer(int32), intent(inout) :: array(0:) + + integer(int_size) :: i, j + integer(int32) :: key + + do j=1_int_size, size(array, kind=int_size)-1 + key = array(j) + i = j - 1 + do while( i >= 0 ) + if ( array(i) <= key ) exit + array(i+1) = array(i) + i = i - 1 + end do + array(i+1) = key + end do + + end subroutine insertion_sort + + pure subroutine heap_sort( array ) +! A bog standard heap sort + integer(int32), intent(inout) :: array(0:) + + integer(int_size) :: i, heap_size + integer(int32) :: y + + heap_size = size( array, kind=int_size ) +! Build the max heap + do i = (heap_size-2)/2_int_size, 0_int_size, -1_int_size + call max_heapify( array, i, heap_size ) + end do + do i = heap_size-1, 1_int_size, -1_int_size +! Swap the first element with the current final element + y = array(0) + array(0) = array(i) + array(i) = y +! Sift down using max_heapify + call max_heapify( array, 0_int_size, i ) + end do + + end subroutine heap_sort + + pure recursive subroutine max_heapify( array, i, heap_size ) +! Transform the array into a max heap + integer(int32), intent(inout) :: array(0:) + integer(int_size), intent(in) :: i, heap_size + + integer(int_size) :: l, r, largest + integer(int32) :: y + + largest = i + l = 2_int_size * i + 1_int_size + r = l + 1_int_size + if ( l < heap_size ) then + if ( array(l) > array(largest) ) largest = l + end if + if ( r < heap_size ) then + if ( array(r) > array(largest) ) largest = r + end if + if ( largest /= i ) then + y = array(i) + array(i) = array(largest) + array(largest) = y + call max_heapify( array, largest, heap_size ) + end if + + end subroutine max_heapify + + end subroutine int32_increase_sort + + + pure subroutine int64_increase_sort( array ) +! `int64_increase_sort( array )` sorts the input `ARRAY` of type `integer(int64)` +! using a hybrid sort based on the `introsort` of David Musser. As with +! `introsort`, `int64_increase_sort( array )` is an unstable hybrid comparison +! algorithm using `quicksort` for the main body of the sort tree, +! supplemented by `insertion sort` for the outer branches, but if +! `quicksort` is converging too slowly the algorithm resorts +! to `heapsort`. The algorithm is of order O(N Ln(N)) for all inputs. +! Because it relies on `quicksort`, the coefficient of the O(N Ln(N)) +! behavior is typically small compared to other sorting algorithms. + + integer(int64), intent(inout) :: array(0:) + + integer(int32) :: depth_limit + + depth_limit = 2 * int( floor( log( real( size( array, kind=int_size), & + kind=dp) ) / log(2.0_dp) ), & + kind=int32 ) + call introsort(array, depth_limit) + + contains + + pure recursive subroutine introsort( array, depth_limit ) +! It devolves to `insertionsort` if the remaining number of elements +! is fewer than or equal to `INSERT_SIZE`, `heapsort` if the completion +! of the `quicksort` is too slow as estimated from `DEPTH_LIMIT`, +! otherwise sorting is done by a `quicksort`. + integer(int64), intent(inout) :: array(0:) + integer(int32), intent(in) :: depth_limit + + integer(int_size), parameter :: insert_size = 16_int_size + integer(int_size) :: index + + if ( size(array, kind=int_size) <= insert_size ) then + ! May be best at the end of SORT processing the whole array + ! See Musser, D.R., “Introspective Sorting and Selection + ! Algorithms,” Software—Practice and Experience, Vol. 27(8), + ! 983–993 (August 1997). + + call insertion_sort( array ) + else if ( depth_limit == 0 ) then + call heap_sort( array ) + else + call partition( array, index ) + call introsort( array(0:index-1), depth_limit-1 ) + call introsort( array(index+1:), depth_limit-1 ) + end if + + end subroutine introsort + + + pure subroutine partition( array, index ) +! quicksort partition using median of three. + integer(int64), intent(inout) :: array(0:) + integer(int_size), intent(out) :: index + + integer(int64) :: u, v, w, x, y + integer(int_size) :: i, j + +! Determine median of three and exchange it with the end. + u = array( 0 ) + v = array( size(array, kind=int_size)/2-1 ) + w = array( size(array, kind=int_size)-1 ) + if ( (u > v) .neqv. (u > w) ) then + x = u + y = array(0) + array(0) = array( size( array, kind=int_size ) - 1 ) + array( size( array, kind=int_size ) - 1 ) = y + else if ( (v < u) .neqv. (v < w) ) then + x = v + y = array(size( array, kind=int_size )/2-1) + array( size( array, kind=int_size )/2-1 ) = & + array( size( array, kind=int_size )-1 ) + array( size( array, kind=int_size )-1 ) = y + else + x = w + end if +! Partition the array. + i = -1_int_size + do j = 0_int_size, size(array, kind=int_size)-2 + if ( array(j) <= x ) then + i = i + 1 + y = array(i) + array(i) = array(j) + array(j) = y + end if + end do + y = array(i+1) + array(i+1) = array(size(array, kind=int_size)-1) + array(size(array, kind=int_size)-1) = y + index = i + 1 + + end subroutine partition + + pure subroutine insertion_sort( array ) +! Bog standard insertion sort. + integer(int64), intent(inout) :: array(0:) + + integer(int_size) :: i, j + integer(int64) :: key + + do j=1_int_size, size(array, kind=int_size)-1 + key = array(j) + i = j - 1 + do while( i >= 0 ) + if ( array(i) <= key ) exit + array(i+1) = array(i) + i = i - 1 + end do + array(i+1) = key + end do + + end subroutine insertion_sort + + pure subroutine heap_sort( array ) +! A bog standard heap sort + integer(int64), intent(inout) :: array(0:) + + integer(int_size) :: i, heap_size + integer(int64) :: y + + heap_size = size( array, kind=int_size ) +! Build the max heap + do i = (heap_size-2)/2_int_size, 0_int_size, -1_int_size + call max_heapify( array, i, heap_size ) + end do + do i = heap_size-1, 1_int_size, -1_int_size +! Swap the first element with the current final element + y = array(0) + array(0) = array(i) + array(i) = y +! Sift down using max_heapify + call max_heapify( array, 0_int_size, i ) + end do + + end subroutine heap_sort + + pure recursive subroutine max_heapify( array, i, heap_size ) +! Transform the array into a max heap + integer(int64), intent(inout) :: array(0:) + integer(int_size), intent(in) :: i, heap_size + + integer(int_size) :: l, r, largest + integer(int64) :: y + + largest = i + l = 2_int_size * i + 1_int_size + r = l + 1_int_size + if ( l < heap_size ) then + if ( array(l) > array(largest) ) largest = l + end if + if ( r < heap_size ) then + if ( array(r) > array(largest) ) largest = r + end if + if ( largest /= i ) then + y = array(i) + array(i) = array(largest) + array(largest) = y + call max_heapify( array, largest, heap_size ) + end if + + end subroutine max_heapify + + end subroutine int64_increase_sort + + + pure subroutine sp_increase_sort( array ) +! `sp_increase_sort( array )` sorts the input `ARRAY` of type `real(sp)` +! using a hybrid sort based on the `introsort` of David Musser. As with +! `introsort`, `sp_increase_sort( array )` is an unstable hybrid comparison +! algorithm using `quicksort` for the main body of the sort tree, +! supplemented by `insertion sort` for the outer branches, but if +! `quicksort` is converging too slowly the algorithm resorts +! to `heapsort`. The algorithm is of order O(N Ln(N)) for all inputs. +! Because it relies on `quicksort`, the coefficient of the O(N Ln(N)) +! behavior is typically small compared to other sorting algorithms. + + real(sp), intent(inout) :: array(0:) + + integer(int32) :: depth_limit + + depth_limit = 2 * int( floor( log( real( size( array, kind=int_size), & + kind=dp) ) / log(2.0_dp) ), & + kind=int32 ) + call introsort(array, depth_limit) + + contains + + pure recursive subroutine introsort( array, depth_limit ) +! It devolves to `insertionsort` if the remaining number of elements +! is fewer than or equal to `INSERT_SIZE`, `heapsort` if the completion +! of the `quicksort` is too slow as estimated from `DEPTH_LIMIT`, +! otherwise sorting is done by a `quicksort`. + real(sp), intent(inout) :: array(0:) + integer(int32), intent(in) :: depth_limit + + integer(int_size), parameter :: insert_size = 16_int_size + integer(int_size) :: index + + if ( size(array, kind=int_size) <= insert_size ) then + ! May be best at the end of SORT processing the whole array + ! See Musser, D.R., “Introspective Sorting and Selection + ! Algorithms,” Software—Practice and Experience, Vol. 27(8), + ! 983–993 (August 1997). + + call insertion_sort( array ) + else if ( depth_limit == 0 ) then + call heap_sort( array ) + else + call partition( array, index ) + call introsort( array(0:index-1), depth_limit-1 ) + call introsort( array(index+1:), depth_limit-1 ) + end if + + end subroutine introsort + + + pure subroutine partition( array, index ) +! quicksort partition using median of three. + real(sp), intent(inout) :: array(0:) + integer(int_size), intent(out) :: index + + real(sp) :: u, v, w, x, y + integer(int_size) :: i, j + +! Determine median of three and exchange it with the end. + u = array( 0 ) + v = array( size(array, kind=int_size)/2-1 ) + w = array( size(array, kind=int_size)-1 ) + if ( (u > v) .neqv. (u > w) ) then + x = u + y = array(0) + array(0) = array( size( array, kind=int_size ) - 1 ) + array( size( array, kind=int_size ) - 1 ) = y + else if ( (v < u) .neqv. (v < w) ) then + x = v + y = array(size( array, kind=int_size )/2-1) + array( size( array, kind=int_size )/2-1 ) = & + array( size( array, kind=int_size )-1 ) + array( size( array, kind=int_size )-1 ) = y + else + x = w + end if +! Partition the array. + i = -1_int_size + do j = 0_int_size, size(array, kind=int_size)-2 + if ( array(j) <= x ) then + i = i + 1 + y = array(i) + array(i) = array(j) + array(j) = y + end if + end do + y = array(i+1) + array(i+1) = array(size(array, kind=int_size)-1) + array(size(array, kind=int_size)-1) = y + index = i + 1 + + end subroutine partition + + pure subroutine insertion_sort( array ) +! Bog standard insertion sort. + real(sp), intent(inout) :: array(0:) + + integer(int_size) :: i, j + real(sp) :: key + + do j=1_int_size, size(array, kind=int_size)-1 + key = array(j) + i = j - 1 + do while( i >= 0 ) + if ( array(i) <= key ) exit + array(i+1) = array(i) + i = i - 1 + end do + array(i+1) = key + end do + + end subroutine insertion_sort + + pure subroutine heap_sort( array ) +! A bog standard heap sort + real(sp), intent(inout) :: array(0:) + + integer(int_size) :: i, heap_size + real(sp) :: y + + heap_size = size( array, kind=int_size ) +! Build the max heap + do i = (heap_size-2)/2_int_size, 0_int_size, -1_int_size + call max_heapify( array, i, heap_size ) + end do + do i = heap_size-1, 1_int_size, -1_int_size +! Swap the first element with the current final element + y = array(0) + array(0) = array(i) + array(i) = y +! Sift down using max_heapify + call max_heapify( array, 0_int_size, i ) + end do + + end subroutine heap_sort + + pure recursive subroutine max_heapify( array, i, heap_size ) +! Transform the array into a max heap + real(sp), intent(inout) :: array(0:) + integer(int_size), intent(in) :: i, heap_size + + integer(int_size) :: l, r, largest + real(sp) :: y + + largest = i + l = 2_int_size * i + 1_int_size + r = l + 1_int_size + if ( l < heap_size ) then + if ( array(l) > array(largest) ) largest = l + end if + if ( r < heap_size ) then + if ( array(r) > array(largest) ) largest = r + end if + if ( largest /= i ) then + y = array(i) + array(i) = array(largest) + array(largest) = y + call max_heapify( array, largest, heap_size ) + end if + + end subroutine max_heapify + + end subroutine sp_increase_sort + + + pure subroutine dp_increase_sort( array ) +! `dp_increase_sort( array )` sorts the input `ARRAY` of type `real(dp)` +! using a hybrid sort based on the `introsort` of David Musser. As with +! `introsort`, `dp_increase_sort( array )` is an unstable hybrid comparison +! algorithm using `quicksort` for the main body of the sort tree, +! supplemented by `insertion sort` for the outer branches, but if +! `quicksort` is converging too slowly the algorithm resorts +! to `heapsort`. The algorithm is of order O(N Ln(N)) for all inputs. +! Because it relies on `quicksort`, the coefficient of the O(N Ln(N)) +! behavior is typically small compared to other sorting algorithms. + + real(dp), intent(inout) :: array(0:) + + integer(int32) :: depth_limit + + depth_limit = 2 * int( floor( log( real( size( array, kind=int_size), & + kind=dp) ) / log(2.0_dp) ), & + kind=int32 ) + call introsort(array, depth_limit) + + contains + + pure recursive subroutine introsort( array, depth_limit ) +! It devolves to `insertionsort` if the remaining number of elements +! is fewer than or equal to `INSERT_SIZE`, `heapsort` if the completion +! of the `quicksort` is too slow as estimated from `DEPTH_LIMIT`, +! otherwise sorting is done by a `quicksort`. + real(dp), intent(inout) :: array(0:) + integer(int32), intent(in) :: depth_limit + + integer(int_size), parameter :: insert_size = 16_int_size + integer(int_size) :: index + + if ( size(array, kind=int_size) <= insert_size ) then + ! May be best at the end of SORT processing the whole array + ! See Musser, D.R., “Introspective Sorting and Selection + ! Algorithms,” Software—Practice and Experience, Vol. 27(8), + ! 983–993 (August 1997). + + call insertion_sort( array ) + else if ( depth_limit == 0 ) then + call heap_sort( array ) + else + call partition( array, index ) + call introsort( array(0:index-1), depth_limit-1 ) + call introsort( array(index+1:), depth_limit-1 ) + end if + + end subroutine introsort + + + pure subroutine partition( array, index ) +! quicksort partition using median of three. + real(dp), intent(inout) :: array(0:) + integer(int_size), intent(out) :: index + + real(dp) :: u, v, w, x, y + integer(int_size) :: i, j + +! Determine median of three and exchange it with the end. + u = array( 0 ) + v = array( size(array, kind=int_size)/2-1 ) + w = array( size(array, kind=int_size)-1 ) + if ( (u > v) .neqv. (u > w) ) then + x = u + y = array(0) + array(0) = array( size( array, kind=int_size ) - 1 ) + array( size( array, kind=int_size ) - 1 ) = y + else if ( (v < u) .neqv. (v < w) ) then + x = v + y = array(size( array, kind=int_size )/2-1) + array( size( array, kind=int_size )/2-1 ) = & + array( size( array, kind=int_size )-1 ) + array( size( array, kind=int_size )-1 ) = y + else + x = w + end if +! Partition the array. + i = -1_int_size + do j = 0_int_size, size(array, kind=int_size)-2 + if ( array(j) <= x ) then + i = i + 1 + y = array(i) + array(i) = array(j) + array(j) = y + end if + end do + y = array(i+1) + array(i+1) = array(size(array, kind=int_size)-1) + array(size(array, kind=int_size)-1) = y + index = i + 1 + + end subroutine partition + + pure subroutine insertion_sort( array ) +! Bog standard insertion sort. + real(dp), intent(inout) :: array(0:) + + integer(int_size) :: i, j + real(dp) :: key + + do j=1_int_size, size(array, kind=int_size)-1 + key = array(j) + i = j - 1 + do while( i >= 0 ) + if ( array(i) <= key ) exit + array(i+1) = array(i) + i = i - 1 + end do + array(i+1) = key + end do + + end subroutine insertion_sort + + pure subroutine heap_sort( array ) +! A bog standard heap sort + real(dp), intent(inout) :: array(0:) + + integer(int_size) :: i, heap_size + real(dp) :: y + + heap_size = size( array, kind=int_size ) +! Build the max heap + do i = (heap_size-2)/2_int_size, 0_int_size, -1_int_size + call max_heapify( array, i, heap_size ) + end do + do i = heap_size-1, 1_int_size, -1_int_size +! Swap the first element with the current final element + y = array(0) + array(0) = array(i) + array(i) = y +! Sift down using max_heapify + call max_heapify( array, 0_int_size, i ) + end do + + end subroutine heap_sort + + pure recursive subroutine max_heapify( array, i, heap_size ) +! Transform the array into a max heap + real(dp), intent(inout) :: array(0:) + integer(int_size), intent(in) :: i, heap_size + + integer(int_size) :: l, r, largest + real(dp) :: y + + largest = i + l = 2_int_size * i + 1_int_size + r = l + 1_int_size + if ( l < heap_size ) then + if ( array(l) > array(largest) ) largest = l + end if + if ( r < heap_size ) then + if ( array(r) > array(largest) ) largest = r + end if + if ( largest /= i ) then + y = array(i) + array(i) = array(largest) + array(largest) = y + call max_heapify( array, largest, heap_size ) + end if + + end subroutine max_heapify + + end subroutine dp_increase_sort + + + pure subroutine qp_increase_sort( array ) +! `qp_increase_sort( array )` sorts the input `ARRAY` of type `real(qp)` +! using a hybrid sort based on the `introsort` of David Musser. As with +! `introsort`, `qp_increase_sort( array )` is an unstable hybrid comparison +! algorithm using `quicksort` for the main body of the sort tree, +! supplemented by `insertion sort` for the outer branches, but if +! `quicksort` is converging too slowly the algorithm resorts +! to `heapsort`. The algorithm is of order O(N Ln(N)) for all inputs. +! Because it relies on `quicksort`, the coefficient of the O(N Ln(N)) +! behavior is typically small compared to other sorting algorithms. + + real(qp), intent(inout) :: array(0:) + + integer(int32) :: depth_limit + + depth_limit = 2 * int( floor( log( real( size( array, kind=int_size), & + kind=dp) ) / log(2.0_dp) ), & + kind=int32 ) + call introsort(array, depth_limit) + + contains + + pure recursive subroutine introsort( array, depth_limit ) +! It devolves to `insertionsort` if the remaining number of elements +! is fewer than or equal to `INSERT_SIZE`, `heapsort` if the completion +! of the `quicksort` is too slow as estimated from `DEPTH_LIMIT`, +! otherwise sorting is done by a `quicksort`. + real(qp), intent(inout) :: array(0:) + integer(int32), intent(in) :: depth_limit + + integer(int_size), parameter :: insert_size = 16_int_size + integer(int_size) :: index + + if ( size(array, kind=int_size) <= insert_size ) then + ! May be best at the end of SORT processing the whole array + ! See Musser, D.R., “Introspective Sorting and Selection + ! Algorithms,” Software—Practice and Experience, Vol. 27(8), + ! 983–993 (August 1997). + + call insertion_sort( array ) + else if ( depth_limit == 0 ) then + call heap_sort( array ) + else + call partition( array, index ) + call introsort( array(0:index-1), depth_limit-1 ) + call introsort( array(index+1:), depth_limit-1 ) + end if + + end subroutine introsort + + + pure subroutine partition( array, index ) +! quicksort partition using median of three. + real(qp), intent(inout) :: array(0:) + integer(int_size), intent(out) :: index + + real(qp) :: u, v, w, x, y + integer(int_size) :: i, j + +! Determine median of three and exchange it with the end. + u = array( 0 ) + v = array( size(array, kind=int_size)/2-1 ) + w = array( size(array, kind=int_size)-1 ) + if ( (u > v) .neqv. (u > w) ) then + x = u + y = array(0) + array(0) = array( size( array, kind=int_size ) - 1 ) + array( size( array, kind=int_size ) - 1 ) = y + else if ( (v < u) .neqv. (v < w) ) then + x = v + y = array(size( array, kind=int_size )/2-1) + array( size( array, kind=int_size )/2-1 ) = & + array( size( array, kind=int_size )-1 ) + array( size( array, kind=int_size )-1 ) = y + else + x = w + end if +! Partition the array. + i = -1_int_size + do j = 0_int_size, size(array, kind=int_size)-2 + if ( array(j) <= x ) then + i = i + 1 + y = array(i) + array(i) = array(j) + array(j) = y + end if + end do + y = array(i+1) + array(i+1) = array(size(array, kind=int_size)-1) + array(size(array, kind=int_size)-1) = y + index = i + 1 + + end subroutine partition + + pure subroutine insertion_sort( array ) +! Bog standard insertion sort. + real(qp), intent(inout) :: array(0:) + + integer(int_size) :: i, j + real(qp) :: key + + do j=1_int_size, size(array, kind=int_size)-1 + key = array(j) + i = j - 1 + do while( i >= 0 ) + if ( array(i) <= key ) exit + array(i+1) = array(i) + i = i - 1 + end do + array(i+1) = key + end do + + end subroutine insertion_sort + + pure subroutine heap_sort( array ) +! A bog standard heap sort + real(qp), intent(inout) :: array(0:) + + integer(int_size) :: i, heap_size + real(qp) :: y + + heap_size = size( array, kind=int_size ) +! Build the max heap + do i = (heap_size-2)/2_int_size, 0_int_size, -1_int_size + call max_heapify( array, i, heap_size ) + end do + do i = heap_size-1, 1_int_size, -1_int_size +! Swap the first element with the current final element + y = array(0) + array(0) = array(i) + array(i) = y +! Sift down using max_heapify + call max_heapify( array, 0_int_size, i ) + end do + + end subroutine heap_sort + + pure recursive subroutine max_heapify( array, i, heap_size ) +! Transform the array into a max heap + real(qp), intent(inout) :: array(0:) + integer(int_size), intent(in) :: i, heap_size + + integer(int_size) :: l, r, largest + real(qp) :: y + + largest = i + l = 2_int_size * i + 1_int_size + r = l + 1_int_size + if ( l < heap_size ) then + if ( array(l) > array(largest) ) largest = l + end if + if ( r < heap_size ) then + if ( array(r) > array(largest) ) largest = r + end if + if ( largest /= i ) then + y = array(i) + array(i) = array(largest) + array(largest) = y + call max_heapify( array, largest, heap_size ) + end if + + end subroutine max_heapify + + end subroutine qp_increase_sort + + + pure subroutine string_type_increase_sort( array ) +! `string_type_increase_sort( array )` sorts the input `ARRAY` of type `type(string_type)` +! using a hybrid sort based on the `introsort` of David Musser. As with +! `introsort`, `string_type_increase_sort( array )` is an unstable hybrid comparison +! algorithm using `quicksort` for the main body of the sort tree, +! supplemented by `insertion sort` for the outer branches, but if +! `quicksort` is converging too slowly the algorithm resorts +! to `heapsort`. The algorithm is of order O(N Ln(N)) for all inputs. +! Because it relies on `quicksort`, the coefficient of the O(N Ln(N)) +! behavior is typically small compared to other sorting algorithms. + + type(string_type), intent(inout) :: array(0:) + + integer(int32) :: depth_limit + + depth_limit = 2 * int( floor( log( real( size( array, kind=int_size), & + kind=dp) ) / log(2.0_dp) ), & + kind=int32 ) + call introsort(array, depth_limit) + + contains + + pure recursive subroutine introsort( array, depth_limit ) +! It devolves to `insertionsort` if the remaining number of elements +! is fewer than or equal to `INSERT_SIZE`, `heapsort` if the completion +! of the `quicksort` is too slow as estimated from `DEPTH_LIMIT`, +! otherwise sorting is done by a `quicksort`. + type(string_type), intent(inout) :: array(0:) + integer(int32), intent(in) :: depth_limit + + integer(int_size), parameter :: insert_size = 16_int_size + integer(int_size) :: index + + if ( size(array, kind=int_size) <= insert_size ) then + ! May be best at the end of SORT processing the whole array + ! See Musser, D.R., “Introspective Sorting and Selection + ! Algorithms,” Software—Practice and Experience, Vol. 27(8), + ! 983–993 (August 1997). + + call insertion_sort( array ) + else if ( depth_limit == 0 ) then + call heap_sort( array ) + else + call partition( array, index ) + call introsort( array(0:index-1), depth_limit-1 ) + call introsort( array(index+1:), depth_limit-1 ) + end if + + end subroutine introsort + + + pure subroutine partition( array, index ) +! quicksort partition using median of three. + type(string_type), intent(inout) :: array(0:) + integer(int_size), intent(out) :: index + + type(string_type) :: u, v, w, x, y + integer(int_size) :: i, j + +! Determine median of three and exchange it with the end. + u = array( 0 ) + v = array( size(array, kind=int_size)/2-1 ) + w = array( size(array, kind=int_size)-1 ) + if ( (u > v) .neqv. (u > w) ) then + x = u + y = array(0) + array(0) = array( size( array, kind=int_size ) - 1 ) + array( size( array, kind=int_size ) - 1 ) = y + else if ( (v < u) .neqv. (v < w) ) then + x = v + y = array(size( array, kind=int_size )/2-1) + array( size( array, kind=int_size )/2-1 ) = & + array( size( array, kind=int_size )-1 ) + array( size( array, kind=int_size )-1 ) = y + else + x = w + end if +! Partition the array. + i = -1_int_size + do j = 0_int_size, size(array, kind=int_size)-2 + if ( array(j) <= x ) then + i = i + 1 + y = array(i) + array(i) = array(j) + array(j) = y + end if + end do + y = array(i+1) + array(i+1) = array(size(array, kind=int_size)-1) + array(size(array, kind=int_size)-1) = y + index = i + 1 + + end subroutine partition + + pure subroutine insertion_sort( array ) +! Bog standard insertion sort. + type(string_type), intent(inout) :: array(0:) + + integer(int_size) :: i, j + type(string_type) :: key + + do j=1_int_size, size(array, kind=int_size)-1 + key = array(j) + i = j - 1 + do while( i >= 0 ) + if ( array(i) <= key ) exit + array(i+1) = array(i) + i = i - 1 + end do + array(i+1) = key + end do + + end subroutine insertion_sort + + pure subroutine heap_sort( array ) +! A bog standard heap sort + type(string_type), intent(inout) :: array(0:) + + integer(int_size) :: i, heap_size + type(string_type) :: y + + heap_size = size( array, kind=int_size ) +! Build the max heap + do i = (heap_size-2)/2_int_size, 0_int_size, -1_int_size + call max_heapify( array, i, heap_size ) + end do + do i = heap_size-1, 1_int_size, -1_int_size +! Swap the first element with the current final element + y = array(0) + array(0) = array(i) + array(i) = y +! Sift down using max_heapify + call max_heapify( array, 0_int_size, i ) + end do + + end subroutine heap_sort + + pure recursive subroutine max_heapify( array, i, heap_size ) +! Transform the array into a max heap + type(string_type), intent(inout) :: array(0:) + integer(int_size), intent(in) :: i, heap_size + + integer(int_size) :: l, r, largest + type(string_type) :: y + + largest = i + l = 2_int_size * i + 1_int_size + r = l + 1_int_size + if ( l < heap_size ) then + if ( array(l) > array(largest) ) largest = l + end if + if ( r < heap_size ) then + if ( array(r) > array(largest) ) largest = r + end if + if ( largest /= i ) then + y = array(i) + array(i) = array(largest) + array(largest) = y + call max_heapify( array, largest, heap_size ) + end if + + end subroutine max_heapify + + end subroutine string_type_increase_sort + + + pure subroutine int8_decrease_sort( array ) +! `int8_decrease_sort( array )` sorts the input `ARRAY` of type `integer(int8)` +! using a hybrid sort based on the `introsort` of David Musser. As with +! `introsort`, `int8_decrease_sort( array )` is an unstable hybrid comparison +! algorithm using `quicksort` for the main body of the sort tree, +! supplemented by `insertion sort` for the outer branches, but if +! `quicksort` is converging too slowly the algorithm resorts +! to `heapsort`. The algorithm is of order O(N Ln(N)) for all inputs. +! Because it relies on `quicksort`, the coefficient of the O(N Ln(N)) +! behavior is typically small compared to other sorting algorithms. + + integer(int8), intent(inout) :: array(0:) + + integer(int32) :: depth_limit + + depth_limit = 2 * int( floor( log( real( size( array, kind=int_size), & + kind=dp) ) / log(2.0_dp) ), & + kind=int32 ) + call introsort(array, depth_limit) + + contains + + pure recursive subroutine introsort( array, depth_limit ) +! It devolves to `insertionsort` if the remaining number of elements +! is fewer than or equal to `INSERT_SIZE`, `heapsort` if the completion +! of the `quicksort` is too slow as estimated from `DEPTH_LIMIT`, +! otherwise sorting is done by a `quicksort`. + integer(int8), intent(inout) :: array(0:) + integer(int32), intent(in) :: depth_limit + + integer(int_size), parameter :: insert_size = 16_int_size + integer(int_size) :: index + + if ( size(array, kind=int_size) <= insert_size ) then + ! May be best at the end of SORT processing the whole array + ! See Musser, D.R., “Introspective Sorting and Selection + ! Algorithms,” Software—Practice and Experience, Vol. 27(8), + ! 983–993 (August 1997). + + call insertion_sort( array ) + else if ( depth_limit == 0 ) then + call heap_sort( array ) + else + call partition( array, index ) + call introsort( array(0:index-1), depth_limit-1 ) + call introsort( array(index+1:), depth_limit-1 ) + end if + + end subroutine introsort + + + pure subroutine partition( array, index ) +! quicksort partition using median of three. + integer(int8), intent(inout) :: array(0:) + integer(int_size), intent(out) :: index + + integer(int8) :: u, v, w, x, y + integer(int_size) :: i, j + +! Determine median of three and exchange it with the end. + u = array( 0 ) + v = array( size(array, kind=int_size)/2-1 ) + w = array( size(array, kind=int_size)-1 ) + if ( (u < v) .neqv. (u < w) ) then + x = u + y = array(0) + array(0) = array( size( array, kind=int_size ) - 1 ) + array( size( array, kind=int_size ) - 1 ) = y + else if ( (v > u) .neqv. (v > w) ) then + x = v + y = array(size( array, kind=int_size )/2-1) + array( size( array, kind=int_size )/2-1 ) = & + array( size( array, kind=int_size )-1 ) + array( size( array, kind=int_size )-1 ) = y + else + x = w + end if +! Partition the array. + i = -1_int_size + do j = 0_int_size, size(array, kind=int_size)-2 + if ( array(j) >= x ) then + i = i + 1 + y = array(i) + array(i) = array(j) + array(j) = y + end if + end do + y = array(i+1) + array(i+1) = array(size(array, kind=int_size)-1) + array(size(array, kind=int_size)-1) = y + index = i + 1 + + end subroutine partition + + pure subroutine insertion_sort( array ) +! Bog standard insertion sort. + integer(int8), intent(inout) :: array(0:) + + integer(int_size) :: i, j + integer(int8) :: key + + do j=1_int_size, size(array, kind=int_size)-1 + key = array(j) + i = j - 1 + do while( i >= 0 ) + if ( array(i) >= key ) exit + array(i+1) = array(i) + i = i - 1 + end do + array(i+1) = key + end do + + end subroutine insertion_sort + + pure subroutine heap_sort( array ) +! A bog standard heap sort + integer(int8), intent(inout) :: array(0:) + + integer(int_size) :: i, heap_size + integer(int8) :: y + + heap_size = size( array, kind=int_size ) +! Build the max heap + do i = (heap_size-2)/2_int_size, 0_int_size, -1_int_size + call max_heapify( array, i, heap_size ) + end do + do i = heap_size-1, 1_int_size, -1_int_size +! Swap the first element with the current final element + y = array(0) + array(0) = array(i) + array(i) = y +! Sift down using max_heapify + call max_heapify( array, 0_int_size, i ) + end do + + end subroutine heap_sort + + pure recursive subroutine max_heapify( array, i, heap_size ) +! Transform the array into a max heap + integer(int8), intent(inout) :: array(0:) + integer(int_size), intent(in) :: i, heap_size + + integer(int_size) :: l, r, largest + integer(int8) :: y + + largest = i + l = 2_int_size * i + 1_int_size + r = l + 1_int_size + if ( l < heap_size ) then + if ( array(l) < array(largest) ) largest = l + end if + if ( r < heap_size ) then + if ( array(r) < array(largest) ) largest = r + end if + if ( largest /= i ) then + y = array(i) + array(i) = array(largest) + array(largest) = y + call max_heapify( array, largest, heap_size ) + end if + + end subroutine max_heapify + + end subroutine int8_decrease_sort + + + pure subroutine int16_decrease_sort( array ) +! `int16_decrease_sort( array )` sorts the input `ARRAY` of type `integer(int16)` +! using a hybrid sort based on the `introsort` of David Musser. As with +! `introsort`, `int16_decrease_sort( array )` is an unstable hybrid comparison +! algorithm using `quicksort` for the main body of the sort tree, +! supplemented by `insertion sort` for the outer branches, but if +! `quicksort` is converging too slowly the algorithm resorts +! to `heapsort`. The algorithm is of order O(N Ln(N)) for all inputs. +! Because it relies on `quicksort`, the coefficient of the O(N Ln(N)) +! behavior is typically small compared to other sorting algorithms. + + integer(int16), intent(inout) :: array(0:) + + integer(int32) :: depth_limit + + depth_limit = 2 * int( floor( log( real( size( array, kind=int_size), & + kind=dp) ) / log(2.0_dp) ), & + kind=int32 ) + call introsort(array, depth_limit) + + contains + + pure recursive subroutine introsort( array, depth_limit ) +! It devolves to `insertionsort` if the remaining number of elements +! is fewer than or equal to `INSERT_SIZE`, `heapsort` if the completion +! of the `quicksort` is too slow as estimated from `DEPTH_LIMIT`, +! otherwise sorting is done by a `quicksort`. + integer(int16), intent(inout) :: array(0:) + integer(int32), intent(in) :: depth_limit + + integer(int_size), parameter :: insert_size = 16_int_size + integer(int_size) :: index + + if ( size(array, kind=int_size) <= insert_size ) then + ! May be best at the end of SORT processing the whole array + ! See Musser, D.R., “Introspective Sorting and Selection + ! Algorithms,” Software—Practice and Experience, Vol. 27(8), + ! 983–993 (August 1997). + + call insertion_sort( array ) + else if ( depth_limit == 0 ) then + call heap_sort( array ) + else + call partition( array, index ) + call introsort( array(0:index-1), depth_limit-1 ) + call introsort( array(index+1:), depth_limit-1 ) + end if + + end subroutine introsort + + + pure subroutine partition( array, index ) +! quicksort partition using median of three. + integer(int16), intent(inout) :: array(0:) + integer(int_size), intent(out) :: index + + integer(int16) :: u, v, w, x, y + integer(int_size) :: i, j + +! Determine median of three and exchange it with the end. + u = array( 0 ) + v = array( size(array, kind=int_size)/2-1 ) + w = array( size(array, kind=int_size)-1 ) + if ( (u < v) .neqv. (u < w) ) then + x = u + y = array(0) + array(0) = array( size( array, kind=int_size ) - 1 ) + array( size( array, kind=int_size ) - 1 ) = y + else if ( (v > u) .neqv. (v > w) ) then + x = v + y = array(size( array, kind=int_size )/2-1) + array( size( array, kind=int_size )/2-1 ) = & + array( size( array, kind=int_size )-1 ) + array( size( array, kind=int_size )-1 ) = y + else + x = w + end if +! Partition the array. + i = -1_int_size + do j = 0_int_size, size(array, kind=int_size)-2 + if ( array(j) >= x ) then + i = i + 1 + y = array(i) + array(i) = array(j) + array(j) = y + end if + end do + y = array(i+1) + array(i+1) = array(size(array, kind=int_size)-1) + array(size(array, kind=int_size)-1) = y + index = i + 1 + + end subroutine partition + + pure subroutine insertion_sort( array ) +! Bog standard insertion sort. + integer(int16), intent(inout) :: array(0:) + + integer(int_size) :: i, j + integer(int16) :: key + + do j=1_int_size, size(array, kind=int_size)-1 + key = array(j) + i = j - 1 + do while( i >= 0 ) + if ( array(i) >= key ) exit + array(i+1) = array(i) + i = i - 1 + end do + array(i+1) = key + end do + + end subroutine insertion_sort + + pure subroutine heap_sort( array ) +! A bog standard heap sort + integer(int16), intent(inout) :: array(0:) + + integer(int_size) :: i, heap_size + integer(int16) :: y + + heap_size = size( array, kind=int_size ) +! Build the max heap + do i = (heap_size-2)/2_int_size, 0_int_size, -1_int_size + call max_heapify( array, i, heap_size ) + end do + do i = heap_size-1, 1_int_size, -1_int_size +! Swap the first element with the current final element + y = array(0) + array(0) = array(i) + array(i) = y +! Sift down using max_heapify + call max_heapify( array, 0_int_size, i ) + end do + + end subroutine heap_sort + + pure recursive subroutine max_heapify( array, i, heap_size ) +! Transform the array into a max heap + integer(int16), intent(inout) :: array(0:) + integer(int_size), intent(in) :: i, heap_size + + integer(int_size) :: l, r, largest + integer(int16) :: y + + largest = i + l = 2_int_size * i + 1_int_size + r = l + 1_int_size + if ( l < heap_size ) then + if ( array(l) < array(largest) ) largest = l + end if + if ( r < heap_size ) then + if ( array(r) < array(largest) ) largest = r + end if + if ( largest /= i ) then + y = array(i) + array(i) = array(largest) + array(largest) = y + call max_heapify( array, largest, heap_size ) + end if + + end subroutine max_heapify + + end subroutine int16_decrease_sort + + + pure subroutine int32_decrease_sort( array ) +! `int32_decrease_sort( array )` sorts the input `ARRAY` of type `integer(int32)` +! using a hybrid sort based on the `introsort` of David Musser. As with +! `introsort`, `int32_decrease_sort( array )` is an unstable hybrid comparison +! algorithm using `quicksort` for the main body of the sort tree, +! supplemented by `insertion sort` for the outer branches, but if +! `quicksort` is converging too slowly the algorithm resorts +! to `heapsort`. The algorithm is of order O(N Ln(N)) for all inputs. +! Because it relies on `quicksort`, the coefficient of the O(N Ln(N)) +! behavior is typically small compared to other sorting algorithms. + + integer(int32), intent(inout) :: array(0:) + + integer(int32) :: depth_limit + + depth_limit = 2 * int( floor( log( real( size( array, kind=int_size), & + kind=dp) ) / log(2.0_dp) ), & + kind=int32 ) + call introsort(array, depth_limit) + + contains + + pure recursive subroutine introsort( array, depth_limit ) +! It devolves to `insertionsort` if the remaining number of elements +! is fewer than or equal to `INSERT_SIZE`, `heapsort` if the completion +! of the `quicksort` is too slow as estimated from `DEPTH_LIMIT`, +! otherwise sorting is done by a `quicksort`. + integer(int32), intent(inout) :: array(0:) + integer(int32), intent(in) :: depth_limit + + integer(int_size), parameter :: insert_size = 16_int_size + integer(int_size) :: index + + if ( size(array, kind=int_size) <= insert_size ) then + ! May be best at the end of SORT processing the whole array + ! See Musser, D.R., “Introspective Sorting and Selection + ! Algorithms,” Software—Practice and Experience, Vol. 27(8), + ! 983–993 (August 1997). + + call insertion_sort( array ) + else if ( depth_limit == 0 ) then + call heap_sort( array ) + else + call partition( array, index ) + call introsort( array(0:index-1), depth_limit-1 ) + call introsort( array(index+1:), depth_limit-1 ) + end if + + end subroutine introsort + + + pure subroutine partition( array, index ) +! quicksort partition using median of three. + integer(int32), intent(inout) :: array(0:) + integer(int_size), intent(out) :: index + + integer(int32) :: u, v, w, x, y + integer(int_size) :: i, j + +! Determine median of three and exchange it with the end. + u = array( 0 ) + v = array( size(array, kind=int_size)/2-1 ) + w = array( size(array, kind=int_size)-1 ) + if ( (u < v) .neqv. (u < w) ) then + x = u + y = array(0) + array(0) = array( size( array, kind=int_size ) - 1 ) + array( size( array, kind=int_size ) - 1 ) = y + else if ( (v > u) .neqv. (v > w) ) then + x = v + y = array(size( array, kind=int_size )/2-1) + array( size( array, kind=int_size )/2-1 ) = & + array( size( array, kind=int_size )-1 ) + array( size( array, kind=int_size )-1 ) = y + else + x = w + end if +! Partition the array. + i = -1_int_size + do j = 0_int_size, size(array, kind=int_size)-2 + if ( array(j) >= x ) then + i = i + 1 + y = array(i) + array(i) = array(j) + array(j) = y + end if + end do + y = array(i+1) + array(i+1) = array(size(array, kind=int_size)-1) + array(size(array, kind=int_size)-1) = y + index = i + 1 + + end subroutine partition + + pure subroutine insertion_sort( array ) +! Bog standard insertion sort. + integer(int32), intent(inout) :: array(0:) + + integer(int_size) :: i, j + integer(int32) :: key + + do j=1_int_size, size(array, kind=int_size)-1 + key = array(j) + i = j - 1 + do while( i >= 0 ) + if ( array(i) >= key ) exit + array(i+1) = array(i) + i = i - 1 + end do + array(i+1) = key + end do + + end subroutine insertion_sort + + pure subroutine heap_sort( array ) +! A bog standard heap sort + integer(int32), intent(inout) :: array(0:) + + integer(int_size) :: i, heap_size + integer(int32) :: y + + heap_size = size( array, kind=int_size ) +! Build the max heap + do i = (heap_size-2)/2_int_size, 0_int_size, -1_int_size + call max_heapify( array, i, heap_size ) + end do + do i = heap_size-1, 1_int_size, -1_int_size +! Swap the first element with the current final element + y = array(0) + array(0) = array(i) + array(i) = y +! Sift down using max_heapify + call max_heapify( array, 0_int_size, i ) + end do + + end subroutine heap_sort + + pure recursive subroutine max_heapify( array, i, heap_size ) +! Transform the array into a max heap + integer(int32), intent(inout) :: array(0:) + integer(int_size), intent(in) :: i, heap_size + + integer(int_size) :: l, r, largest + integer(int32) :: y + + largest = i + l = 2_int_size * i + 1_int_size + r = l + 1_int_size + if ( l < heap_size ) then + if ( array(l) < array(largest) ) largest = l + end if + if ( r < heap_size ) then + if ( array(r) < array(largest) ) largest = r + end if + if ( largest /= i ) then + y = array(i) + array(i) = array(largest) + array(largest) = y + call max_heapify( array, largest, heap_size ) + end if + + end subroutine max_heapify + + end subroutine int32_decrease_sort + + + pure subroutine int64_decrease_sort( array ) +! `int64_decrease_sort( array )` sorts the input `ARRAY` of type `integer(int64)` +! using a hybrid sort based on the `introsort` of David Musser. As with +! `introsort`, `int64_decrease_sort( array )` is an unstable hybrid comparison +! algorithm using `quicksort` for the main body of the sort tree, +! supplemented by `insertion sort` for the outer branches, but if +! `quicksort` is converging too slowly the algorithm resorts +! to `heapsort`. The algorithm is of order O(N Ln(N)) for all inputs. +! Because it relies on `quicksort`, the coefficient of the O(N Ln(N)) +! behavior is typically small compared to other sorting algorithms. + + integer(int64), intent(inout) :: array(0:) + + integer(int32) :: depth_limit + + depth_limit = 2 * int( floor( log( real( size( array, kind=int_size), & + kind=dp) ) / log(2.0_dp) ), & + kind=int32 ) + call introsort(array, depth_limit) + + contains + + pure recursive subroutine introsort( array, depth_limit ) +! It devolves to `insertionsort` if the remaining number of elements +! is fewer than or equal to `INSERT_SIZE`, `heapsort` if the completion +! of the `quicksort` is too slow as estimated from `DEPTH_LIMIT`, +! otherwise sorting is done by a `quicksort`. + integer(int64), intent(inout) :: array(0:) + integer(int32), intent(in) :: depth_limit + + integer(int_size), parameter :: insert_size = 16_int_size + integer(int_size) :: index + + if ( size(array, kind=int_size) <= insert_size ) then + ! May be best at the end of SORT processing the whole array + ! See Musser, D.R., “Introspective Sorting and Selection + ! Algorithms,” Software—Practice and Experience, Vol. 27(8), + ! 983–993 (August 1997). + + call insertion_sort( array ) + else if ( depth_limit == 0 ) then + call heap_sort( array ) + else + call partition( array, index ) + call introsort( array(0:index-1), depth_limit-1 ) + call introsort( array(index+1:), depth_limit-1 ) + end if + + end subroutine introsort + + + pure subroutine partition( array, index ) +! quicksort partition using median of three. + integer(int64), intent(inout) :: array(0:) + integer(int_size), intent(out) :: index + + integer(int64) :: u, v, w, x, y + integer(int_size) :: i, j + +! Determine median of three and exchange it with the end. + u = array( 0 ) + v = array( size(array, kind=int_size)/2-1 ) + w = array( size(array, kind=int_size)-1 ) + if ( (u < v) .neqv. (u < w) ) then + x = u + y = array(0) + array(0) = array( size( array, kind=int_size ) - 1 ) + array( size( array, kind=int_size ) - 1 ) = y + else if ( (v > u) .neqv. (v > w) ) then + x = v + y = array(size( array, kind=int_size )/2-1) + array( size( array, kind=int_size )/2-1 ) = & + array( size( array, kind=int_size )-1 ) + array( size( array, kind=int_size )-1 ) = y + else + x = w + end if +! Partition the array. + i = -1_int_size + do j = 0_int_size, size(array, kind=int_size)-2 + if ( array(j) >= x ) then + i = i + 1 + y = array(i) + array(i) = array(j) + array(j) = y + end if + end do + y = array(i+1) + array(i+1) = array(size(array, kind=int_size)-1) + array(size(array, kind=int_size)-1) = y + index = i + 1 + + end subroutine partition + + pure subroutine insertion_sort( array ) +! Bog standard insertion sort. + integer(int64), intent(inout) :: array(0:) + + integer(int_size) :: i, j + integer(int64) :: key + + do j=1_int_size, size(array, kind=int_size)-1 + key = array(j) + i = j - 1 + do while( i >= 0 ) + if ( array(i) >= key ) exit + array(i+1) = array(i) + i = i - 1 + end do + array(i+1) = key + end do + + end subroutine insertion_sort + + pure subroutine heap_sort( array ) +! A bog standard heap sort + integer(int64), intent(inout) :: array(0:) + + integer(int_size) :: i, heap_size + integer(int64) :: y + + heap_size = size( array, kind=int_size ) +! Build the max heap + do i = (heap_size-2)/2_int_size, 0_int_size, -1_int_size + call max_heapify( array, i, heap_size ) + end do + do i = heap_size-1, 1_int_size, -1_int_size +! Swap the first element with the current final element + y = array(0) + array(0) = array(i) + array(i) = y +! Sift down using max_heapify + call max_heapify( array, 0_int_size, i ) + end do + + end subroutine heap_sort + + pure recursive subroutine max_heapify( array, i, heap_size ) +! Transform the array into a max heap + integer(int64), intent(inout) :: array(0:) + integer(int_size), intent(in) :: i, heap_size + + integer(int_size) :: l, r, largest + integer(int64) :: y + + largest = i + l = 2_int_size * i + 1_int_size + r = l + 1_int_size + if ( l < heap_size ) then + if ( array(l) < array(largest) ) largest = l + end if + if ( r < heap_size ) then + if ( array(r) < array(largest) ) largest = r + end if + if ( largest /= i ) then + y = array(i) + array(i) = array(largest) + array(largest) = y + call max_heapify( array, largest, heap_size ) + end if + + end subroutine max_heapify + + end subroutine int64_decrease_sort + + + pure subroutine sp_decrease_sort( array ) +! `sp_decrease_sort( array )` sorts the input `ARRAY` of type `real(sp)` +! using a hybrid sort based on the `introsort` of David Musser. As with +! `introsort`, `sp_decrease_sort( array )` is an unstable hybrid comparison +! algorithm using `quicksort` for the main body of the sort tree, +! supplemented by `insertion sort` for the outer branches, but if +! `quicksort` is converging too slowly the algorithm resorts +! to `heapsort`. The algorithm is of order O(N Ln(N)) for all inputs. +! Because it relies on `quicksort`, the coefficient of the O(N Ln(N)) +! behavior is typically small compared to other sorting algorithms. + + real(sp), intent(inout) :: array(0:) + + integer(int32) :: depth_limit + + depth_limit = 2 * int( floor( log( real( size( array, kind=int_size), & + kind=dp) ) / log(2.0_dp) ), & + kind=int32 ) + call introsort(array, depth_limit) + + contains + + pure recursive subroutine introsort( array, depth_limit ) +! It devolves to `insertionsort` if the remaining number of elements +! is fewer than or equal to `INSERT_SIZE`, `heapsort` if the completion +! of the `quicksort` is too slow as estimated from `DEPTH_LIMIT`, +! otherwise sorting is done by a `quicksort`. + real(sp), intent(inout) :: array(0:) + integer(int32), intent(in) :: depth_limit + + integer(int_size), parameter :: insert_size = 16_int_size + integer(int_size) :: index + + if ( size(array, kind=int_size) <= insert_size ) then + ! May be best at the end of SORT processing the whole array + ! See Musser, D.R., “Introspective Sorting and Selection + ! Algorithms,” Software—Practice and Experience, Vol. 27(8), + ! 983–993 (August 1997). + + call insertion_sort( array ) + else if ( depth_limit == 0 ) then + call heap_sort( array ) + else + call partition( array, index ) + call introsort( array(0:index-1), depth_limit-1 ) + call introsort( array(index+1:), depth_limit-1 ) + end if + + end subroutine introsort + + + pure subroutine partition( array, index ) +! quicksort partition using median of three. + real(sp), intent(inout) :: array(0:) + integer(int_size), intent(out) :: index + + real(sp) :: u, v, w, x, y + integer(int_size) :: i, j + +! Determine median of three and exchange it with the end. + u = array( 0 ) + v = array( size(array, kind=int_size)/2-1 ) + w = array( size(array, kind=int_size)-1 ) + if ( (u < v) .neqv. (u < w) ) then + x = u + y = array(0) + array(0) = array( size( array, kind=int_size ) - 1 ) + array( size( array, kind=int_size ) - 1 ) = y + else if ( (v > u) .neqv. (v > w) ) then + x = v + y = array(size( array, kind=int_size )/2-1) + array( size( array, kind=int_size )/2-1 ) = & + array( size( array, kind=int_size )-1 ) + array( size( array, kind=int_size )-1 ) = y + else + x = w + end if +! Partition the array. + i = -1_int_size + do j = 0_int_size, size(array, kind=int_size)-2 + if ( array(j) >= x ) then + i = i + 1 + y = array(i) + array(i) = array(j) + array(j) = y + end if + end do + y = array(i+1) + array(i+1) = array(size(array, kind=int_size)-1) + array(size(array, kind=int_size)-1) = y + index = i + 1 + + end subroutine partition + + pure subroutine insertion_sort( array ) +! Bog standard insertion sort. + real(sp), intent(inout) :: array(0:) + + integer(int_size) :: i, j + real(sp) :: key + + do j=1_int_size, size(array, kind=int_size)-1 + key = array(j) + i = j - 1 + do while( i >= 0 ) + if ( array(i) >= key ) exit + array(i+1) = array(i) + i = i - 1 + end do + array(i+1) = key + end do + + end subroutine insertion_sort + + pure subroutine heap_sort( array ) +! A bog standard heap sort + real(sp), intent(inout) :: array(0:) + + integer(int_size) :: i, heap_size + real(sp) :: y + + heap_size = size( array, kind=int_size ) +! Build the max heap + do i = (heap_size-2)/2_int_size, 0_int_size, -1_int_size + call max_heapify( array, i, heap_size ) + end do + do i = heap_size-1, 1_int_size, -1_int_size +! Swap the first element with the current final element + y = array(0) + array(0) = array(i) + array(i) = y +! Sift down using max_heapify + call max_heapify( array, 0_int_size, i ) + end do + + end subroutine heap_sort + + pure recursive subroutine max_heapify( array, i, heap_size ) +! Transform the array into a max heap + real(sp), intent(inout) :: array(0:) + integer(int_size), intent(in) :: i, heap_size + + integer(int_size) :: l, r, largest + real(sp) :: y + + largest = i + l = 2_int_size * i + 1_int_size + r = l + 1_int_size + if ( l < heap_size ) then + if ( array(l) < array(largest) ) largest = l + end if + if ( r < heap_size ) then + if ( array(r) < array(largest) ) largest = r + end if + if ( largest /= i ) then + y = array(i) + array(i) = array(largest) + array(largest) = y + call max_heapify( array, largest, heap_size ) + end if + + end subroutine max_heapify + + end subroutine sp_decrease_sort + + + pure subroutine dp_decrease_sort( array ) +! `dp_decrease_sort( array )` sorts the input `ARRAY` of type `real(dp)` +! using a hybrid sort based on the `introsort` of David Musser. As with +! `introsort`, `dp_decrease_sort( array )` is an unstable hybrid comparison +! algorithm using `quicksort` for the main body of the sort tree, +! supplemented by `insertion sort` for the outer branches, but if +! `quicksort` is converging too slowly the algorithm resorts +! to `heapsort`. The algorithm is of order O(N Ln(N)) for all inputs. +! Because it relies on `quicksort`, the coefficient of the O(N Ln(N)) +! behavior is typically small compared to other sorting algorithms. + + real(dp), intent(inout) :: array(0:) + + integer(int32) :: depth_limit + + depth_limit = 2 * int( floor( log( real( size( array, kind=int_size), & + kind=dp) ) / log(2.0_dp) ), & + kind=int32 ) + call introsort(array, depth_limit) + + contains + + pure recursive subroutine introsort( array, depth_limit ) +! It devolves to `insertionsort` if the remaining number of elements +! is fewer than or equal to `INSERT_SIZE`, `heapsort` if the completion +! of the `quicksort` is too slow as estimated from `DEPTH_LIMIT`, +! otherwise sorting is done by a `quicksort`. + real(dp), intent(inout) :: array(0:) + integer(int32), intent(in) :: depth_limit + + integer(int_size), parameter :: insert_size = 16_int_size + integer(int_size) :: index + + if ( size(array, kind=int_size) <= insert_size ) then + ! May be best at the end of SORT processing the whole array + ! See Musser, D.R., “Introspective Sorting and Selection + ! Algorithms,” Software—Practice and Experience, Vol. 27(8), + ! 983–993 (August 1997). + + call insertion_sort( array ) + else if ( depth_limit == 0 ) then + call heap_sort( array ) + else + call partition( array, index ) + call introsort( array(0:index-1), depth_limit-1 ) + call introsort( array(index+1:), depth_limit-1 ) + end if + + end subroutine introsort + + + pure subroutine partition( array, index ) +! quicksort partition using median of three. + real(dp), intent(inout) :: array(0:) + integer(int_size), intent(out) :: index + + real(dp) :: u, v, w, x, y + integer(int_size) :: i, j + +! Determine median of three and exchange it with the end. + u = array( 0 ) + v = array( size(array, kind=int_size)/2-1 ) + w = array( size(array, kind=int_size)-1 ) + if ( (u < v) .neqv. (u < w) ) then + x = u + y = array(0) + array(0) = array( size( array, kind=int_size ) - 1 ) + array( size( array, kind=int_size ) - 1 ) = y + else if ( (v > u) .neqv. (v > w) ) then + x = v + y = array(size( array, kind=int_size )/2-1) + array( size( array, kind=int_size )/2-1 ) = & + array( size( array, kind=int_size )-1 ) + array( size( array, kind=int_size )-1 ) = y + else + x = w + end if +! Partition the array. + i = -1_int_size + do j = 0_int_size, size(array, kind=int_size)-2 + if ( array(j) >= x ) then + i = i + 1 + y = array(i) + array(i) = array(j) + array(j) = y + end if + end do + y = array(i+1) + array(i+1) = array(size(array, kind=int_size)-1) + array(size(array, kind=int_size)-1) = y + index = i + 1 + + end subroutine partition + + pure subroutine insertion_sort( array ) +! Bog standard insertion sort. + real(dp), intent(inout) :: array(0:) + + integer(int_size) :: i, j + real(dp) :: key + + do j=1_int_size, size(array, kind=int_size)-1 + key = array(j) + i = j - 1 + do while( i >= 0 ) + if ( array(i) >= key ) exit + array(i+1) = array(i) + i = i - 1 + end do + array(i+1) = key + end do + + end subroutine insertion_sort + + pure subroutine heap_sort( array ) +! A bog standard heap sort + real(dp), intent(inout) :: array(0:) + + integer(int_size) :: i, heap_size + real(dp) :: y + + heap_size = size( array, kind=int_size ) +! Build the max heap + do i = (heap_size-2)/2_int_size, 0_int_size, -1_int_size + call max_heapify( array, i, heap_size ) + end do + do i = heap_size-1, 1_int_size, -1_int_size +! Swap the first element with the current final element + y = array(0) + array(0) = array(i) + array(i) = y +! Sift down using max_heapify + call max_heapify( array, 0_int_size, i ) + end do + + end subroutine heap_sort + + pure recursive subroutine max_heapify( array, i, heap_size ) +! Transform the array into a max heap + real(dp), intent(inout) :: array(0:) + integer(int_size), intent(in) :: i, heap_size + + integer(int_size) :: l, r, largest + real(dp) :: y + + largest = i + l = 2_int_size * i + 1_int_size + r = l + 1_int_size + if ( l < heap_size ) then + if ( array(l) < array(largest) ) largest = l + end if + if ( r < heap_size ) then + if ( array(r) < array(largest) ) largest = r + end if + if ( largest /= i ) then + y = array(i) + array(i) = array(largest) + array(largest) = y + call max_heapify( array, largest, heap_size ) + end if + + end subroutine max_heapify + + end subroutine dp_decrease_sort + + + pure subroutine qp_decrease_sort( array ) +! `qp_decrease_sort( array )` sorts the input `ARRAY` of type `real(qp)` +! using a hybrid sort based on the `introsort` of David Musser. As with +! `introsort`, `qp_decrease_sort( array )` is an unstable hybrid comparison +! algorithm using `quicksort` for the main body of the sort tree, +! supplemented by `insertion sort` for the outer branches, but if +! `quicksort` is converging too slowly the algorithm resorts +! to `heapsort`. The algorithm is of order O(N Ln(N)) for all inputs. +! Because it relies on `quicksort`, the coefficient of the O(N Ln(N)) +! behavior is typically small compared to other sorting algorithms. + + real(qp), intent(inout) :: array(0:) + + integer(int32) :: depth_limit + + depth_limit = 2 * int( floor( log( real( size( array, kind=int_size), & + kind=dp) ) / log(2.0_dp) ), & + kind=int32 ) + call introsort(array, depth_limit) + + contains + + pure recursive subroutine introsort( array, depth_limit ) +! It devolves to `insertionsort` if the remaining number of elements +! is fewer than or equal to `INSERT_SIZE`, `heapsort` if the completion +! of the `quicksort` is too slow as estimated from `DEPTH_LIMIT`, +! otherwise sorting is done by a `quicksort`. + real(qp), intent(inout) :: array(0:) + integer(int32), intent(in) :: depth_limit + + integer(int_size), parameter :: insert_size = 16_int_size + integer(int_size) :: index + + if ( size(array, kind=int_size) <= insert_size ) then + ! May be best at the end of SORT processing the whole array + ! See Musser, D.R., “Introspective Sorting and Selection + ! Algorithms,” Software—Practice and Experience, Vol. 27(8), + ! 983–993 (August 1997). + + call insertion_sort( array ) + else if ( depth_limit == 0 ) then + call heap_sort( array ) + else + call partition( array, index ) + call introsort( array(0:index-1), depth_limit-1 ) + call introsort( array(index+1:), depth_limit-1 ) + end if + + end subroutine introsort + + + pure subroutine partition( array, index ) +! quicksort partition using median of three. + real(qp), intent(inout) :: array(0:) + integer(int_size), intent(out) :: index + + real(qp) :: u, v, w, x, y + integer(int_size) :: i, j + +! Determine median of three and exchange it with the end. + u = array( 0 ) + v = array( size(array, kind=int_size)/2-1 ) + w = array( size(array, kind=int_size)-1 ) + if ( (u < v) .neqv. (u < w) ) then + x = u + y = array(0) + array(0) = array( size( array, kind=int_size ) - 1 ) + array( size( array, kind=int_size ) - 1 ) = y + else if ( (v > u) .neqv. (v > w) ) then + x = v + y = array(size( array, kind=int_size )/2-1) + array( size( array, kind=int_size )/2-1 ) = & + array( size( array, kind=int_size )-1 ) + array( size( array, kind=int_size )-1 ) = y + else + x = w + end if +! Partition the array. + i = -1_int_size + do j = 0_int_size, size(array, kind=int_size)-2 + if ( array(j) >= x ) then + i = i + 1 + y = array(i) + array(i) = array(j) + array(j) = y + end if + end do + y = array(i+1) + array(i+1) = array(size(array, kind=int_size)-1) + array(size(array, kind=int_size)-1) = y + index = i + 1 + + end subroutine partition + + pure subroutine insertion_sort( array ) +! Bog standard insertion sort. + real(qp), intent(inout) :: array(0:) + + integer(int_size) :: i, j + real(qp) :: key + + do j=1_int_size, size(array, kind=int_size)-1 + key = array(j) + i = j - 1 + do while( i >= 0 ) + if ( array(i) >= key ) exit + array(i+1) = array(i) + i = i - 1 + end do + array(i+1) = key + end do + + end subroutine insertion_sort + + pure subroutine heap_sort( array ) +! A bog standard heap sort + real(qp), intent(inout) :: array(0:) + + integer(int_size) :: i, heap_size + real(qp) :: y + + heap_size = size( array, kind=int_size ) +! Build the max heap + do i = (heap_size-2)/2_int_size, 0_int_size, -1_int_size + call max_heapify( array, i, heap_size ) + end do + do i = heap_size-1, 1_int_size, -1_int_size +! Swap the first element with the current final element + y = array(0) + array(0) = array(i) + array(i) = y +! Sift down using max_heapify + call max_heapify( array, 0_int_size, i ) + end do + + end subroutine heap_sort + + pure recursive subroutine max_heapify( array, i, heap_size ) +! Transform the array into a max heap + real(qp), intent(inout) :: array(0:) + integer(int_size), intent(in) :: i, heap_size + + integer(int_size) :: l, r, largest + real(qp) :: y + + largest = i + l = 2_int_size * i + 1_int_size + r = l + 1_int_size + if ( l < heap_size ) then + if ( array(l) < array(largest) ) largest = l + end if + if ( r < heap_size ) then + if ( array(r) < array(largest) ) largest = r + end if + if ( largest /= i ) then + y = array(i) + array(i) = array(largest) + array(largest) = y + call max_heapify( array, largest, heap_size ) + end if + + end subroutine max_heapify + + end subroutine qp_decrease_sort + + + pure subroutine string_type_decrease_sort( array ) +! `string_type_decrease_sort( array )` sorts the input `ARRAY` of type `type(string_type)` +! using a hybrid sort based on the `introsort` of David Musser. As with +! `introsort`, `string_type_decrease_sort( array )` is an unstable hybrid comparison +! algorithm using `quicksort` for the main body of the sort tree, +! supplemented by `insertion sort` for the outer branches, but if +! `quicksort` is converging too slowly the algorithm resorts +! to `heapsort`. The algorithm is of order O(N Ln(N)) for all inputs. +! Because it relies on `quicksort`, the coefficient of the O(N Ln(N)) +! behavior is typically small compared to other sorting algorithms. + + type(string_type), intent(inout) :: array(0:) + + integer(int32) :: depth_limit + + depth_limit = 2 * int( floor( log( real( size( array, kind=int_size), & + kind=dp) ) / log(2.0_dp) ), & + kind=int32 ) + call introsort(array, depth_limit) + + contains + + pure recursive subroutine introsort( array, depth_limit ) +! It devolves to `insertionsort` if the remaining number of elements +! is fewer than or equal to `INSERT_SIZE`, `heapsort` if the completion +! of the `quicksort` is too slow as estimated from `DEPTH_LIMIT`, +! otherwise sorting is done by a `quicksort`. + type(string_type), intent(inout) :: array(0:) + integer(int32), intent(in) :: depth_limit + + integer(int_size), parameter :: insert_size = 16_int_size + integer(int_size) :: index + + if ( size(array, kind=int_size) <= insert_size ) then + ! May be best at the end of SORT processing the whole array + ! See Musser, D.R., “Introspective Sorting and Selection + ! Algorithms,” Software—Practice and Experience, Vol. 27(8), + ! 983–993 (August 1997). + + call insertion_sort( array ) + else if ( depth_limit == 0 ) then + call heap_sort( array ) + else + call partition( array, index ) + call introsort( array(0:index-1), depth_limit-1 ) + call introsort( array(index+1:), depth_limit-1 ) + end if + + end subroutine introsort + + + pure subroutine partition( array, index ) +! quicksort partition using median of three. + type(string_type), intent(inout) :: array(0:) + integer(int_size), intent(out) :: index + + type(string_type) :: u, v, w, x, y + integer(int_size) :: i, j + +! Determine median of three and exchange it with the end. + u = array( 0 ) + v = array( size(array, kind=int_size)/2-1 ) + w = array( size(array, kind=int_size)-1 ) + if ( (u < v) .neqv. (u < w) ) then + x = u + y = array(0) + array(0) = array( size( array, kind=int_size ) - 1 ) + array( size( array, kind=int_size ) - 1 ) = y + else if ( (v > u) .neqv. (v > w) ) then + x = v + y = array(size( array, kind=int_size )/2-1) + array( size( array, kind=int_size )/2-1 ) = & + array( size( array, kind=int_size )-1 ) + array( size( array, kind=int_size )-1 ) = y + else + x = w + end if +! Partition the array. + i = -1_int_size + do j = 0_int_size, size(array, kind=int_size)-2 + if ( array(j) >= x ) then + i = i + 1 + y = array(i) + array(i) = array(j) + array(j) = y + end if + end do + y = array(i+1) + array(i+1) = array(size(array, kind=int_size)-1) + array(size(array, kind=int_size)-1) = y + index = i + 1 + + end subroutine partition + + pure subroutine insertion_sort( array ) +! Bog standard insertion sort. + type(string_type), intent(inout) :: array(0:) + + integer(int_size) :: i, j + type(string_type) :: key + + do j=1_int_size, size(array, kind=int_size)-1 + key = array(j) + i = j - 1 + do while( i >= 0 ) + if ( array(i) >= key ) exit + array(i+1) = array(i) + i = i - 1 + end do + array(i+1) = key + end do + + end subroutine insertion_sort + + pure subroutine heap_sort( array ) +! A bog standard heap sort + type(string_type), intent(inout) :: array(0:) + + integer(int_size) :: i, heap_size + type(string_type) :: y + + heap_size = size( array, kind=int_size ) +! Build the max heap + do i = (heap_size-2)/2_int_size, 0_int_size, -1_int_size + call max_heapify( array, i, heap_size ) + end do + do i = heap_size-1, 1_int_size, -1_int_size +! Swap the first element with the current final element + y = array(0) + array(0) = array(i) + array(i) = y +! Sift down using max_heapify + call max_heapify( array, 0_int_size, i ) + end do + + end subroutine heap_sort + + pure recursive subroutine max_heapify( array, i, heap_size ) +! Transform the array into a max heap + type(string_type), intent(inout) :: array(0:) + integer(int_size), intent(in) :: i, heap_size + + integer(int_size) :: l, r, largest + type(string_type) :: y + + largest = i + l = 2_int_size * i + 1_int_size + r = l + 1_int_size + if ( l < heap_size ) then + if ( array(l) < array(largest) ) largest = l + end if + if ( r < heap_size ) then + if ( array(r) < array(largest) ) largest = r + end if + if ( largest /= i ) then + y = array(i) + array(i) = array(largest) + array(largest) = y + call max_heapify( array, largest, heap_size ) + end if + + end subroutine max_heapify + + end subroutine string_type_decrease_sort + + + + pure module subroutine char_sort( array, reverse ) + character(len=*), intent(inout) :: array(0:) + logical, intent(in), optional :: reverse + + logical :: reverse_ + + reverse_ = .false. + if(present(reverse)) reverse_ = reverse + + if(reverse_)then + call char_decrease_sort(array) + else + call char_increase_sort(array) + endif + end subroutine char_sort + + + + pure subroutine char_increase_sort( array ) +! `char_increase_sort( array )` sorts the input `ARRAY` of type `CHARACTER(*)` +! using a hybrid sort based on the `introsort` of David Musser. As with +! `introsort`, `char_increase_sort( array )` is an unstable hybrid comparison +! algorithm using `quicksort` for the main body of the sort tree, +! supplemented by `insertion sort` for the outer branches, but if +! `quicksort` is converging too slowly the algorithm resorts +! to `heapsort`. The algorithm is of order O(N Ln(N)) for all inputs. +! Because it relies on `quicksort`, the coefficient of the O(N Ln(N)) +! behavior is typically small compared to other sorting algorithms. + + character(len=*), intent(inout) :: array(0:) + + integer(int32) :: depth_limit + + depth_limit = 2 * int( floor( log( real( size( array, kind=int_size ), & + kind=dp) ) / log(2.0_dp) ), & + kind=int32 ) + call introsort(array, depth_limit) + + contains + + pure recursive subroutine introsort( array, depth_limit ) +! It devolves to `insertionsort` if the remaining number of elements +! is fewer than or equal to `INSERT_SIZE`, `heapsort` if the completion +! of the `quicksort` is too slow as estimated from `DEPTH_LIMIT`, +! otherwise sorting is done by a `quicksort`. + character(len=*), intent(inout) :: array(0:) + integer(int32), intent(in) :: depth_limit + + integer(int_size), parameter :: insert_size = 16_int_size + integer(int_size) :: index + + if ( size(array, kind=int_size) <= insert_size ) then + ! May be best at the end of SORT processing the whole array + ! See Musser, D.R., “Introspective Sorting and Selection + ! Algorithms,” Software—Practice and Experience, Vol. 27(8), + ! 983–993 (August 1997). + + call insertion_sort( array ) + else if ( depth_limit == 0 ) then + call heap_sort( array ) + else + call partition( array, index ) + call introsort( array(0:index-1), depth_limit-1 ) + call introsort( array(index+1:), depth_limit-1 ) + end if + + end subroutine introsort + + + pure subroutine partition( array, index ) +! quicksort partition using median of three. + character(len=*), intent(inout) :: array(0:) + integer(int_size), intent(out) :: index + + integer(int_size) :: i, j + character(len=len(array)) :: u, v, w, x, y + +! Determine median of three and exchange it with the end. + u = array( 0 ) + v = array( size(array, kind=int_size)/2-1 ) + w = array( size(array, kind=int_size)-1 ) + if ( (u > v) .neqv. (u > w) ) then + x = u + y = array(0) + array(0) = array( size( array, kind=int_size ) - 1 ) + array( size( array, kind=int_size ) - 1 ) = y + else if ( (v < u) .neqv. (v < w) ) then + x = v + y = array(size( array, kind=int_size )/2-1) + array( size( array, kind=int_size )/2-1 ) = & + array( size( array, kind=int_size )-1 ) + array( size( array, kind=int_size )-1 ) = y + else + x = w + end if +! Partition the array. + i = -1_int_size + do j = 0_int_size, size(array, kind=int_size)-2 + if ( array(j) <= x ) then + i = i + 1 + y = array(i) + array(i) = array(j) + array(j) = y + end if + end do + y = array(i+1) + array(i+1) = array(size(array, kind=int_size)-1) + array(size(array, kind=int_size)-1) = y + index = i + 1 + + end subroutine partition + + pure subroutine insertion_sort( array ) +! Bog standard insertion sort. + character(len=*), intent(inout) :: array(0:) + + integer(int_size) :: i, j + character(len=len(array)) :: key + + do j=1_int_size, size(array, kind=int_size)-1 + key = array(j) + i = j - 1 + do while( i >= 0 ) + if ( array(i) <= key ) exit + array(i+1) = array(i) + i = i - 1 + end do + array(i+1) = key + end do + + end subroutine insertion_sort + + pure subroutine heap_sort( array ) +! A bog standard heap sort + character(len=*), intent(inout) :: array(0:) + + integer(int_size) :: i, heap_size + character(len=len(array)) :: y + + heap_size = size( array, kind=int_size ) +! Build the max heap + do i = (heap_size-2)/2_int_size, 0_int_size, -1_int_size + call max_heapify( array, i, heap_size ) + end do + do i = heap_size-1, 1_int_size, -1_int_size +! Swap the first element with the current final element + y = array(0) + array(0) = array(i) + array(i) = y +! Sift down using max_heapify + call max_heapify( array, 0_int_size, i ) + end do + + end subroutine heap_sort + + pure recursive subroutine max_heapify( array, i, heap_size ) +! Transform the array into a max heap + character(len=*), intent(inout) :: array(0:) + integer(int_size), intent(in) :: i, heap_size + + integer(int_size) :: l, r, largest + character(len=len(array)) :: y + + largest = i + l = 2_int_size * i + 1_int_size + r = l + 1_int_size + if ( l < heap_size ) then + if ( array(l) > array(largest) ) largest = l + end if + if ( r < heap_size ) then + if ( array(r) > array(largest) ) largest = r + end if + if ( largest /= i ) then + y = array(i) + array(i) = array(largest) + array(largest) = y + call max_heapify( array, largest, heap_size ) + end if + + end subroutine max_heapify + + end subroutine char_increase_sort + pure subroutine char_decrease_sort( array ) +! `char_decrease_sort( array )` sorts the input `ARRAY` of type `CHARACTER(*)` +! using a hybrid sort based on the `introsort` of David Musser. As with +! `introsort`, `char_decrease_sort( array )` is an unstable hybrid comparison +! algorithm using `quicksort` for the main body of the sort tree, +! supplemented by `insertion sort` for the outer branches, but if +! `quicksort` is converging too slowly the algorithm resorts +! to `heapsort`. The algorithm is of order O(N Ln(N)) for all inputs. +! Because it relies on `quicksort`, the coefficient of the O(N Ln(N)) +! behavior is typically small compared to other sorting algorithms. + + character(len=*), intent(inout) :: array(0:) + + integer(int32) :: depth_limit + + depth_limit = 2 * int( floor( log( real( size( array, kind=int_size ), & + kind=dp) ) / log(2.0_dp) ), & + kind=int32 ) + call introsort(array, depth_limit) + + contains + + pure recursive subroutine introsort( array, depth_limit ) +! It devolves to `insertionsort` if the remaining number of elements +! is fewer than or equal to `INSERT_SIZE`, `heapsort` if the completion +! of the `quicksort` is too slow as estimated from `DEPTH_LIMIT`, +! otherwise sorting is done by a `quicksort`. + character(len=*), intent(inout) :: array(0:) + integer(int32), intent(in) :: depth_limit + + integer(int_size), parameter :: insert_size = 16_int_size + integer(int_size) :: index + + if ( size(array, kind=int_size) <= insert_size ) then + ! May be best at the end of SORT processing the whole array + ! See Musser, D.R., “Introspective Sorting and Selection + ! Algorithms,” Software—Practice and Experience, Vol. 27(8), + ! 983–993 (August 1997). + + call insertion_sort( array ) + else if ( depth_limit == 0 ) then + call heap_sort( array ) + else + call partition( array, index ) + call introsort( array(0:index-1), depth_limit-1 ) + call introsort( array(index+1:), depth_limit-1 ) + end if + + end subroutine introsort + + + pure subroutine partition( array, index ) +! quicksort partition using median of three. + character(len=*), intent(inout) :: array(0:) + integer(int_size), intent(out) :: index + + integer(int_size) :: i, j + character(len=len(array)) :: u, v, w, x, y + +! Determine median of three and exchange it with the end. + u = array( 0 ) + v = array( size(array, kind=int_size)/2-1 ) + w = array( size(array, kind=int_size)-1 ) + if ( (u < v) .neqv. (u < w) ) then + x = u + y = array(0) + array(0) = array( size( array, kind=int_size ) - 1 ) + array( size( array, kind=int_size ) - 1 ) = y + else if ( (v > u) .neqv. (v > w) ) then + x = v + y = array(size( array, kind=int_size )/2-1) + array( size( array, kind=int_size )/2-1 ) = & + array( size( array, kind=int_size )-1 ) + array( size( array, kind=int_size )-1 ) = y + else + x = w + end if +! Partition the array. + i = -1_int_size + do j = 0_int_size, size(array, kind=int_size)-2 + if ( array(j) >= x ) then + i = i + 1 + y = array(i) + array(i) = array(j) + array(j) = y + end if + end do + y = array(i+1) + array(i+1) = array(size(array, kind=int_size)-1) + array(size(array, kind=int_size)-1) = y + index = i + 1 + + end subroutine partition + + pure subroutine insertion_sort( array ) +! Bog standard insertion sort. + character(len=*), intent(inout) :: array(0:) + + integer(int_size) :: i, j + character(len=len(array)) :: key + + do j=1_int_size, size(array, kind=int_size)-1 + key = array(j) + i = j - 1 + do while( i >= 0 ) + if ( array(i) >= key ) exit + array(i+1) = array(i) + i = i - 1 + end do + array(i+1) = key + end do + + end subroutine insertion_sort + + pure subroutine heap_sort( array ) +! A bog standard heap sort + character(len=*), intent(inout) :: array(0:) + + integer(int_size) :: i, heap_size + character(len=len(array)) :: y + + heap_size = size( array, kind=int_size ) +! Build the max heap + do i = (heap_size-2)/2_int_size, 0_int_size, -1_int_size + call max_heapify( array, i, heap_size ) + end do + do i = heap_size-1, 1_int_size, -1_int_size +! Swap the first element with the current final element + y = array(0) + array(0) = array(i) + array(i) = y +! Sift down using max_heapify + call max_heapify( array, 0_int_size, i ) + end do + + end subroutine heap_sort + + pure recursive subroutine max_heapify( array, i, heap_size ) +! Transform the array into a max heap + character(len=*), intent(inout) :: array(0:) + integer(int_size), intent(in) :: i, heap_size + + integer(int_size) :: l, r, largest + character(len=len(array)) :: y + + largest = i + l = 2_int_size * i + 1_int_size + r = l + 1_int_size + if ( l < heap_size ) then + if ( array(l) < array(largest) ) largest = l + end if + if ( r < heap_size ) then + if ( array(r) < array(largest) ) largest = r + end if + if ( largest /= i ) then + y = array(i) + array(i) = array(largest) + array(largest) = y + call max_heapify( array, largest, heap_size ) + end if + + end subroutine max_heapify + + end subroutine char_decrease_sort + +end submodule stdlib_sorting_sort diff --git a/src/fpm/stdlib_sorting_sort_index.f90 b/src/fpm/stdlib_sorting_sort_index.f90 new file mode 100644 index 000000000..0b18ac36f --- /dev/null +++ b/src/fpm/stdlib_sorting_sort_index.f90 @@ -0,0 +1,3785 @@ + +!! Licensing: +!! +!! This file is subjec† both to the Fortran Standard Library license, and +!! to additional licensing requirements as it contains translations of +!! other software. +!! +!! The Fortran Standard Library, including this file, is distributed under +!! the MIT license that should be included with the library's distribution. +!! +!! Copyright (c) 2021 Fortran stdlib developers +!! +!! Permission is hereby granted, free of charge, to any person obtaining a +!! copy of this software and associated documentation files (the +!! "Software"), to deal in the Software without restriction, including +!! without limitation the rights to use, copy, modify, merge, publish, +!! distribute, sublicense, and/or sellcopies of the Software, and to permit +!! persons to whom the Software is furnished to do so, subject to the +!! following conditions: +!! +!! The above copyright notice and this permission notice shall be included +!! in all copies or substantial portions of the Software. +!! +!! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS +!! OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +!! MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +!! IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +!! CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +!! TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +!! SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +!! +!! The generic subroutine, `SORT_INDEX`, is substantially a translation to +!! Fortran 2008 of the `"Rust" sort` sorting routines in +!! [`slice.rs`](https://github.com/rust-lang/rust/blob/90eb44a5897c39e3dff9c7e48e3973671dcd9496/src/liballoc/slice.rs) +!! The `rust sort` implementation is distributed with the header: +!! +!! Copyright 2012-2015 The Rust Project Developers. See the COPYRIGHT +!! file at the top-level directory of this distribution and at +!! http://rust-lang.org/COPYRIGHT. +!! +!! Licensed under the Apache License, Version 2.0 or the MIT license +!! , at your +!! option. This file may not be copied, modified, or distributed +!! except according to those terms. +!! +!! so the license for the original`slice.rs` code is compatible with the use +!! of modified versions of the code in the Fortran Standard Library under +!! the MIT license. + +submodule(stdlib_sorting) stdlib_sorting_sort_index + + implicit none + +contains + + + module subroutine int8_sort_index( array, index, work, iwork, reverse ) +! A modification of `int8_ord_sort` to return an array of indices that +! would perform a stable sort of the `ARRAY` as input, and also sort `ARRAY` +! as desired. The indices by default +! correspond to a non-decreasing sort, but if the optional argument +! `REVERSE` is present with a value of `.TRUE.` the indices correspond to +! a non-increasing sort. The logic of the determination of indexing largely +! follows the `"Rust" sort` found in `slice.rs`: +! https://github.com/rust-lang/rust/blob/90eb44a5897c39e3dff9c7e48e3973671dcd9496/src/liballoc/slice.rs#L2159 +! The Rust version is a simplification of the Timsort algorithm described +! in https://svn.python.org/projects/python/trunk/Objects/listsort.txt, as +! it drops both the use of 'galloping' to identify bounds of regions to be +! sorted and the estimation of the optimal `run size`. However it remains +! a hybrid sorting algorithm combining an iterative Merge sort controlled +! by a stack of `RUNS` identified by regions of uniformly decreasing or +! non-decreasing sequences that may be expanded to a minimum run size, with +! an insertion sort. +! +! Note the Fortran implementation simplifies the logic as it only has to +! deal with Fortran arrays of intrinsic types and not the full generality +! of Rust's arrays and lists for arbitrary types. It also adds the +! estimation of the optimal `run size` as suggested in Tim Peters' +! original listsort.txt, and the optional `work` and `iwork` arraya to be +! used as scratch memory. + + integer(int8), intent(inout) :: array(0:) + integer(int_size), intent(out) :: index(0:) + integer(int8), intent(out), optional :: work(0:) + integer(int_size), intent(out), optional :: iwork(0:) + logical, intent(in), optional :: reverse + + integer(int_size) :: array_size, i, stat + integer(int8), allocatable :: buf(:) + integer(int_size), allocatable :: ibuf(:) + + array_size = size(array, kind=int_size) + + do i = 0, array_size-1 + index(i) = i+1 + end do + + if ( present(reverse) ) then + if ( reverse ) then + call reverse_segment( array, index ) + end if + end if + +! If necessary allocate buffers to serve as scratch memory. + if ( present(work) ) then + if ( size(work, kind=int_size) < array_size/2 ) then + error stop "work array is too small." + end if + if ( present(iwork) ) then + if ( size(iwork, kind=int_size) < array_size/2 ) then + error stop "iwork array is too small." + endif + call merge_sort( array, index, work, iwork ) + else + allocate( ibuf(0:array_size/2-1), stat=stat ) + if ( stat /= 0 ) error stop "Allocation of index buffer failed." + call merge_sort( array, index, work, ibuf ) + end if + else + allocate( buf(0:array_size/2-1), stat=stat ) + if ( stat /= 0 ) error stop "Allocation of array buffer failed." + if ( present(iwork) ) then + if ( size(iwork, kind=int_size) < array_size/2 ) then + error stop "iwork array is too small." + endif + call merge_sort( array, index, buf, iwork ) + else + allocate( ibuf(0:array_size/2-1), stat=stat ) + if ( stat /= 0 ) error stop "Allocation of index buffer failed." + call merge_sort( array, index, buf, ibuf ) + end if + end if + + if ( present(reverse) ) then + if ( reverse ) then + call reverse_segment( array, index ) + end if + end if + + contains + + pure function calc_min_run( n ) result(min_run) +!! Returns the minimum length of a run from 32-63 so that N/MIN_RUN is +!! less than or equal to a power of two. See +!! https://svn.python.org/projects/python/trunk/Objects/listsort.txt + integer(int_size) :: min_run + integer(int_size), intent(in) :: n + + integer(int_size) :: num, r + + num = n + r = 0_int_size + + do while( num >= 64 ) + r = ior( r, iand(num, 1_int_size) ) + num = ishft(num, -1_int_size) + end do + min_run = num + r + + end function calc_min_run + + + pure subroutine insertion_sort( array, index ) +! Sorts `ARRAY` using an insertion sort, while maintaining consistency in +! location of the indices in `INDEX` to the elements of `ARRAY`. + integer(int8), intent(inout) :: array(0:) + integer(int_size), intent(inout) :: index(0:) + + integer(int_size) :: i, j, key_index + integer(int8) :: key + + do j=1, size(array, kind=int_size)-1 + key = array(j) + key_index = index(j) + i = j - 1 + do while( i >= 0 ) + if ( array(i) <= key ) exit + array(i+1) = array(i) + index(i+1) = index(i) + i = i - 1 + end do + array(i+1) = key + index(i+1) = key_index + end do + + end subroutine insertion_sort + + + pure function collapse( runs ) result ( r ) +! Examine the stack of runs waiting to be merged, identifying adjacent runs +! to be merged until the stack invariants are restablished: +! +! 1. len(-3) > len(-2) + len(-1) +! 2. len(-2) > len(-1) + + integer(int_size) :: r + type(run_type), intent(in), target :: runs(0:) + + integer(int_size) :: n + logical :: test + + n = size(runs, kind=int_size) + test = .false. + if (n >= 2) then + if ( runs( n-1 ) % base == 0 .or. & + runs( n-2 ) % len <= runs(n-1) % len ) then + test = .true. + else if ( n >= 3 ) then ! X exists + if ( runs(n-3) % len <= & + runs(n-2) % len + runs(n-1) % len ) then + test = .true. +! |X| <= |Y| + |Z| => will need to merge due to rho1 or rho2 + else if( n >= 4 ) then + if ( runs(n-4) % len <= & + runs(n-3) % len + runs(n-2) % len ) then + test = .true. +! |W| <= |X| + |Y| => will need to merge due to rho1 or rho3 + end if + end if + end if + end if + if ( test ) then +! By default merge Y & Z, rho2 or rho3 + if ( n >= 3 ) then + if ( runs(n-3) % len < runs(n-1) % len ) then + r = n - 3 +! |X| < |Z| => merge X & Y, rho1 + return + end if + end if + r = n - 2 +! |Y| <= |Z| => merge Y & Z, rho4 + return + else + r = -1 + end if + + end function collapse + + + pure subroutine insert_head( array, index ) +! Inserts `array(0)` into the pre-sorted sequence `array(1:)` so that the +! whole `array(0:)` becomes sorted, copying the first element into +! a temporary variable, iterating until the right place for it is found. +! copying every traversed element into the slot preceding it, and finally, +! copying data from the temporary variable into the resulting hole. +! Consistency of the indices in `index` with the elements of `array` +! are maintained. + + integer(int8), intent(inout) :: array(0:) + integer(int_size), intent(inout) :: index(0:) + + integer(int8) :: tmp + integer(int_size) :: i, tmp_index + + tmp = array(0) + tmp_index = index(0) + find_hole: do i=1, size(array, kind=int_size)-1 + if ( array(i) >= tmp ) exit find_hole + array(i-1) = array(i) + index(i-1) = index(i) + end do find_hole + array(i-1) = tmp + index(i-1) = tmp_index + + end subroutine insert_head + + + subroutine merge_sort( array, index, buf, ibuf ) +! The Rust merge sort borrows some (but not all) of the ideas from TimSort, +! which is described in detail at +! (http://svn.python.org/projects/python/trunk/Objects/listsort.txt). +! +! The algorithm identifies strictly descending and non-descending +! subsequences, which are called natural runs. Where these runs are less +! than a minimum run size they are padded by adding additional samples +! using an insertion sort. The merge process is driven by a stack of +! pending unmerged runs. Each newly found run is pushed onto the stack, +! and then pairs of adjacentd runs are merged until these two invariants +! are satisfied: +! +! 1. for every `i` in `1..size(runs)-1`: `runs(i - 1)%len > runs(i)%len` +! 2. for every `i` in `2..size(runs)-1`: `runs(i - 2)%len > +! runs(i - 1)%len + runs(i)%len` +! +! The invariants ensure that the total running time is `O(n log n)` +! worst-case. Consistency of the indices in `index` with the elements of +! `array` are maintained. + + integer(int8), intent(inout) :: array(0:) + integer(int_size), intent(inout) :: index(0:) + integer(int8), intent(inout) :: buf(0:) + integer(int_size), intent(inout) :: ibuf(0:) + + integer(int_size) :: array_size, finish, min_run, r, r_count, & + start + type(run_type) :: runs(0:max_merge_stack-1), left, right + + array_size = size(array, kind=int_size) + +! Very short runs are extended using insertion sort to span at least this +! many elements. Slices of up to this length are sorted using insertion sort. + min_run = calc_min_run( array_size ) + + if ( array_size <= min_run ) then + if ( array_size >= 2 ) call insertion_sort( array, index ) + return + end if + + +! Following Rust sort, natural runs in `array` are identified by traversing +! it backwards. By traversing it backward, merges more often go in the +! opposite direction (forwards). According to developers of Rust sort, +! merging forwards is slightly faster than merging backwards. Therefore +! identifying runs by traversing backwards should improve performance. + r_count = 0 + finish = array_size - 1 + do while ( finish >= 0 ) +! Find the next natural run, and reverse it if it's strictly descending. + start = finish + if ( start > 0 ) then + start = start - 1 + if ( array(start+1) < array(start) ) then + Descending: do while ( start > 0 ) + if ( array(start) >= array(start-1) ) & + exit Descending + start = start - 1 + end do Descending + call reverse_segment( array(start:finish), & + index(start:finish) ) + else + Ascending: do while( start > 0 ) + if ( array(start) < array(start-1) ) exit Ascending + start = start - 1 + end do Ascending + end if + end if + +! If the run is too short insert some more elements using an insertion sort. + Insert: do while ( start > 0 ) + if ( finish - start >= min_run - 1 ) exit Insert + start = start - 1 + call insert_head( array(start:finish), index(start:finish) ) + end do Insert + if ( start == 0 .and. finish == array_size - 1 ) return + + runs(r_count) = run_type( base = start, & + len = finish - start + 1 ) + finish = start-1 + r_count = r_count + 1 + +! Determine whether pairs of adjacent runs need to be merged to satisfy +! the invariants, and, if so, merge them. + Merge_loop: do + r = collapse( runs(0:r_count - 1) ) + if ( r < 0 .or. r_count <= 1 ) exit Merge_loop + left = runs( r + 1 ) + right = runs( r ) + call merge( array( left % base: & + right % base + right % len - 1 ), & + left % len, buf, & + index( left % base: & + right % base + right % len - 1 ), ibuf ) + + runs(r) = run_type( base = left % base, & + len = left % len + right % len ) + if ( r == r_count - 3 ) runs(r+1) = runs(r+2) + r_count = r_count - 1 + + end do Merge_loop + end do + if ( r_count /= 1 ) & + error stop "MERGE_SORT completed without RUN COUNT == 1." + + end subroutine merge_sort + + + pure subroutine merge( array, mid, buf, index, ibuf ) +! Merges the two non-decreasing runs `ARRAY(0:MID-1)` and `ARRAY(MID:)` +! using `BUF` as temporary storage, and stores the merged runs into +! `ARRAY(0:)`. `MID` must be > 0, and < `SIZE(ARRAY)-1`. Buffer `BUF` +! must be long enough to hold the shorter of the two runs. + integer(int8), intent(inout) :: array(0:) + integer(int_size), intent(in) :: mid + integer(int8), intent(inout) :: buf(0:) + integer(int_size), intent(inout) :: index(0:) + integer(int_size), intent(inout) :: ibuf(0:) + + integer(int_size) :: array_len, i, j, k + + array_len = size(array, kind=int_size) + +! Merge first copies the shorter run into `buf`. Then, depending on which +! run was shorter, it traces the copied run and the longer run forwards +! (or backwards), comparing their next unprocessed elements and then +! copying the lesser (or greater) one into `array`. + + if ( mid <= array_len - mid ) then ! The left run is shorter. + buf(0:mid-1) = array(0:mid-1) + ibuf(0:mid-1) = index(0:mid-1) + i = 0 + j = mid + merge_lower: do k = 0, array_len-1 + if ( buf(i) <= array(j) ) then + array(k) = buf(i) + index(k) = ibuf(i) + i = i + 1 + if ( i >= mid ) exit merge_lower + else + array(k) = array(j) + index(k) = index(j) + j = j + 1 + if ( j >= array_len ) then + array(k+1:) = buf(i:mid-1) + index(k+1:) = ibuf(i:mid-1) + exit merge_lower + end if + end if + end do merge_lower + else ! The right run is shorter + buf(0:array_len-mid-1) = array(mid:array_len-1) + ibuf(0:array_len-mid-1) = index(mid:array_len-1) + i = mid - 1 + j = array_len - mid -1 + merge_upper: do k = array_len-1, 0, -1 + if ( buf(j) >= array(i) ) then + array(k) = buf(j) + index(k) = ibuf(j) + j = j - 1 + if ( j < 0 ) exit merge_upper + else + array(k) = array(i) + index(k) = index(i) + i = i - 1 + if ( i < 0 ) then + array(0:k-1) = buf(0:j) + index(0:k-1) = ibuf(0:j) + exit merge_upper + end if + end if + end do merge_upper + end if + end subroutine merge + + + pure subroutine reverse_segment( array, index ) +! Reverse a segment of an array in place + integer(int8), intent(inout) :: array(0:) + integer(int_size), intent(inout) :: index(0:) + + integer(int_size) :: itemp, lo, hi + integer(int8) :: temp + + lo = 0 + hi = size( array, kind=int_size ) - 1 + do while( lo < hi ) + temp = array(lo) + array(lo) = array(hi) + array(hi) = temp + itemp = index(lo) + index(lo) = index(hi) + index(hi) = itemp + lo = lo + 1 + hi = hi - 1 + end do + + end subroutine reverse_segment + + end subroutine int8_sort_index + + + module subroutine int16_sort_index( array, index, work, iwork, reverse ) +! A modification of `int16_ord_sort` to return an array of indices that +! would perform a stable sort of the `ARRAY` as input, and also sort `ARRAY` +! as desired. The indices by default +! correspond to a non-decreasing sort, but if the optional argument +! `REVERSE` is present with a value of `.TRUE.` the indices correspond to +! a non-increasing sort. The logic of the determination of indexing largely +! follows the `"Rust" sort` found in `slice.rs`: +! https://github.com/rust-lang/rust/blob/90eb44a5897c39e3dff9c7e48e3973671dcd9496/src/liballoc/slice.rs#L2159 +! The Rust version is a simplification of the Timsort algorithm described +! in https://svn.python.org/projects/python/trunk/Objects/listsort.txt, as +! it drops both the use of 'galloping' to identify bounds of regions to be +! sorted and the estimation of the optimal `run size`. However it remains +! a hybrid sorting algorithm combining an iterative Merge sort controlled +! by a stack of `RUNS` identified by regions of uniformly decreasing or +! non-decreasing sequences that may be expanded to a minimum run size, with +! an insertion sort. +! +! Note the Fortran implementation simplifies the logic as it only has to +! deal with Fortran arrays of intrinsic types and not the full generality +! of Rust's arrays and lists for arbitrary types. It also adds the +! estimation of the optimal `run size` as suggested in Tim Peters' +! original listsort.txt, and the optional `work` and `iwork` arraya to be +! used as scratch memory. + + integer(int16), intent(inout) :: array(0:) + integer(int_size), intent(out) :: index(0:) + integer(int16), intent(out), optional :: work(0:) + integer(int_size), intent(out), optional :: iwork(0:) + logical, intent(in), optional :: reverse + + integer(int_size) :: array_size, i, stat + integer(int16), allocatable :: buf(:) + integer(int_size), allocatable :: ibuf(:) + + array_size = size(array, kind=int_size) + + do i = 0, array_size-1 + index(i) = i+1 + end do + + if ( present(reverse) ) then + if ( reverse ) then + call reverse_segment( array, index ) + end if + end if + +! If necessary allocate buffers to serve as scratch memory. + if ( present(work) ) then + if ( size(work, kind=int_size) < array_size/2 ) then + error stop "work array is too small." + end if + if ( present(iwork) ) then + if ( size(iwork, kind=int_size) < array_size/2 ) then + error stop "iwork array is too small." + endif + call merge_sort( array, index, work, iwork ) + else + allocate( ibuf(0:array_size/2-1), stat=stat ) + if ( stat /= 0 ) error stop "Allocation of index buffer failed." + call merge_sort( array, index, work, ibuf ) + end if + else + allocate( buf(0:array_size/2-1), stat=stat ) + if ( stat /= 0 ) error stop "Allocation of array buffer failed." + if ( present(iwork) ) then + if ( size(iwork, kind=int_size) < array_size/2 ) then + error stop "iwork array is too small." + endif + call merge_sort( array, index, buf, iwork ) + else + allocate( ibuf(0:array_size/2-1), stat=stat ) + if ( stat /= 0 ) error stop "Allocation of index buffer failed." + call merge_sort( array, index, buf, ibuf ) + end if + end if + + if ( present(reverse) ) then + if ( reverse ) then + call reverse_segment( array, index ) + end if + end if + + contains + + pure function calc_min_run( n ) result(min_run) +!! Returns the minimum length of a run from 32-63 so that N/MIN_RUN is +!! less than or equal to a power of two. See +!! https://svn.python.org/projects/python/trunk/Objects/listsort.txt + integer(int_size) :: min_run + integer(int_size), intent(in) :: n + + integer(int_size) :: num, r + + num = n + r = 0_int_size + + do while( num >= 64 ) + r = ior( r, iand(num, 1_int_size) ) + num = ishft(num, -1_int_size) + end do + min_run = num + r + + end function calc_min_run + + + pure subroutine insertion_sort( array, index ) +! Sorts `ARRAY` using an insertion sort, while maintaining consistency in +! location of the indices in `INDEX` to the elements of `ARRAY`. + integer(int16), intent(inout) :: array(0:) + integer(int_size), intent(inout) :: index(0:) + + integer(int_size) :: i, j, key_index + integer(int16) :: key + + do j=1, size(array, kind=int_size)-1 + key = array(j) + key_index = index(j) + i = j - 1 + do while( i >= 0 ) + if ( array(i) <= key ) exit + array(i+1) = array(i) + index(i+1) = index(i) + i = i - 1 + end do + array(i+1) = key + index(i+1) = key_index + end do + + end subroutine insertion_sort + + + pure function collapse( runs ) result ( r ) +! Examine the stack of runs waiting to be merged, identifying adjacent runs +! to be merged until the stack invariants are restablished: +! +! 1. len(-3) > len(-2) + len(-1) +! 2. len(-2) > len(-1) + + integer(int_size) :: r + type(run_type), intent(in), target :: runs(0:) + + integer(int_size) :: n + logical :: test + + n = size(runs, kind=int_size) + test = .false. + if (n >= 2) then + if ( runs( n-1 ) % base == 0 .or. & + runs( n-2 ) % len <= runs(n-1) % len ) then + test = .true. + else if ( n >= 3 ) then ! X exists + if ( runs(n-3) % len <= & + runs(n-2) % len + runs(n-1) % len ) then + test = .true. +! |X| <= |Y| + |Z| => will need to merge due to rho1 or rho2 + else if( n >= 4 ) then + if ( runs(n-4) % len <= & + runs(n-3) % len + runs(n-2) % len ) then + test = .true. +! |W| <= |X| + |Y| => will need to merge due to rho1 or rho3 + end if + end if + end if + end if + if ( test ) then +! By default merge Y & Z, rho2 or rho3 + if ( n >= 3 ) then + if ( runs(n-3) % len < runs(n-1) % len ) then + r = n - 3 +! |X| < |Z| => merge X & Y, rho1 + return + end if + end if + r = n - 2 +! |Y| <= |Z| => merge Y & Z, rho4 + return + else + r = -1 + end if + + end function collapse + + + pure subroutine insert_head( array, index ) +! Inserts `array(0)` into the pre-sorted sequence `array(1:)` so that the +! whole `array(0:)` becomes sorted, copying the first element into +! a temporary variable, iterating until the right place for it is found. +! copying every traversed element into the slot preceding it, and finally, +! copying data from the temporary variable into the resulting hole. +! Consistency of the indices in `index` with the elements of `array` +! are maintained. + + integer(int16), intent(inout) :: array(0:) + integer(int_size), intent(inout) :: index(0:) + + integer(int16) :: tmp + integer(int_size) :: i, tmp_index + + tmp = array(0) + tmp_index = index(0) + find_hole: do i=1, size(array, kind=int_size)-1 + if ( array(i) >= tmp ) exit find_hole + array(i-1) = array(i) + index(i-1) = index(i) + end do find_hole + array(i-1) = tmp + index(i-1) = tmp_index + + end subroutine insert_head + + + subroutine merge_sort( array, index, buf, ibuf ) +! The Rust merge sort borrows some (but not all) of the ideas from TimSort, +! which is described in detail at +! (http://svn.python.org/projects/python/trunk/Objects/listsort.txt). +! +! The algorithm identifies strictly descending and non-descending +! subsequences, which are called natural runs. Where these runs are less +! than a minimum run size they are padded by adding additional samples +! using an insertion sort. The merge process is driven by a stack of +! pending unmerged runs. Each newly found run is pushed onto the stack, +! and then pairs of adjacentd runs are merged until these two invariants +! are satisfied: +! +! 1. for every `i` in `1..size(runs)-1`: `runs(i - 1)%len > runs(i)%len` +! 2. for every `i` in `2..size(runs)-1`: `runs(i - 2)%len > +! runs(i - 1)%len + runs(i)%len` +! +! The invariants ensure that the total running time is `O(n log n)` +! worst-case. Consistency of the indices in `index` with the elements of +! `array` are maintained. + + integer(int16), intent(inout) :: array(0:) + integer(int_size), intent(inout) :: index(0:) + integer(int16), intent(inout) :: buf(0:) + integer(int_size), intent(inout) :: ibuf(0:) + + integer(int_size) :: array_size, finish, min_run, r, r_count, & + start + type(run_type) :: runs(0:max_merge_stack-1), left, right + + array_size = size(array, kind=int_size) + +! Very short runs are extended using insertion sort to span at least this +! many elements. Slices of up to this length are sorted using insertion sort. + min_run = calc_min_run( array_size ) + + if ( array_size <= min_run ) then + if ( array_size >= 2 ) call insertion_sort( array, index ) + return + end if + + +! Following Rust sort, natural runs in `array` are identified by traversing +! it backwards. By traversing it backward, merges more often go in the +! opposite direction (forwards). According to developers of Rust sort, +! merging forwards is slightly faster than merging backwards. Therefore +! identifying runs by traversing backwards should improve performance. + r_count = 0 + finish = array_size - 1 + do while ( finish >= 0 ) +! Find the next natural run, and reverse it if it's strictly descending. + start = finish + if ( start > 0 ) then + start = start - 1 + if ( array(start+1) < array(start) ) then + Descending: do while ( start > 0 ) + if ( array(start) >= array(start-1) ) & + exit Descending + start = start - 1 + end do Descending + call reverse_segment( array(start:finish), & + index(start:finish) ) + else + Ascending: do while( start > 0 ) + if ( array(start) < array(start-1) ) exit Ascending + start = start - 1 + end do Ascending + end if + end if + +! If the run is too short insert some more elements using an insertion sort. + Insert: do while ( start > 0 ) + if ( finish - start >= min_run - 1 ) exit Insert + start = start - 1 + call insert_head( array(start:finish), index(start:finish) ) + end do Insert + if ( start == 0 .and. finish == array_size - 1 ) return + + runs(r_count) = run_type( base = start, & + len = finish - start + 1 ) + finish = start-1 + r_count = r_count + 1 + +! Determine whether pairs of adjacent runs need to be merged to satisfy +! the invariants, and, if so, merge them. + Merge_loop: do + r = collapse( runs(0:r_count - 1) ) + if ( r < 0 .or. r_count <= 1 ) exit Merge_loop + left = runs( r + 1 ) + right = runs( r ) + call merge( array( left % base: & + right % base + right % len - 1 ), & + left % len, buf, & + index( left % base: & + right % base + right % len - 1 ), ibuf ) + + runs(r) = run_type( base = left % base, & + len = left % len + right % len ) + if ( r == r_count - 3 ) runs(r+1) = runs(r+2) + r_count = r_count - 1 + + end do Merge_loop + end do + if ( r_count /= 1 ) & + error stop "MERGE_SORT completed without RUN COUNT == 1." + + end subroutine merge_sort + + + pure subroutine merge( array, mid, buf, index, ibuf ) +! Merges the two non-decreasing runs `ARRAY(0:MID-1)` and `ARRAY(MID:)` +! using `BUF` as temporary storage, and stores the merged runs into +! `ARRAY(0:)`. `MID` must be > 0, and < `SIZE(ARRAY)-1`. Buffer `BUF` +! must be long enough to hold the shorter of the two runs. + integer(int16), intent(inout) :: array(0:) + integer(int_size), intent(in) :: mid + integer(int16), intent(inout) :: buf(0:) + integer(int_size), intent(inout) :: index(0:) + integer(int_size), intent(inout) :: ibuf(0:) + + integer(int_size) :: array_len, i, j, k + + array_len = size(array, kind=int_size) + +! Merge first copies the shorter run into `buf`. Then, depending on which +! run was shorter, it traces the copied run and the longer run forwards +! (or backwards), comparing their next unprocessed elements and then +! copying the lesser (or greater) one into `array`. + + if ( mid <= array_len - mid ) then ! The left run is shorter. + buf(0:mid-1) = array(0:mid-1) + ibuf(0:mid-1) = index(0:mid-1) + i = 0 + j = mid + merge_lower: do k = 0, array_len-1 + if ( buf(i) <= array(j) ) then + array(k) = buf(i) + index(k) = ibuf(i) + i = i + 1 + if ( i >= mid ) exit merge_lower + else + array(k) = array(j) + index(k) = index(j) + j = j + 1 + if ( j >= array_len ) then + array(k+1:) = buf(i:mid-1) + index(k+1:) = ibuf(i:mid-1) + exit merge_lower + end if + end if + end do merge_lower + else ! The right run is shorter + buf(0:array_len-mid-1) = array(mid:array_len-1) + ibuf(0:array_len-mid-1) = index(mid:array_len-1) + i = mid - 1 + j = array_len - mid -1 + merge_upper: do k = array_len-1, 0, -1 + if ( buf(j) >= array(i) ) then + array(k) = buf(j) + index(k) = ibuf(j) + j = j - 1 + if ( j < 0 ) exit merge_upper + else + array(k) = array(i) + index(k) = index(i) + i = i - 1 + if ( i < 0 ) then + array(0:k-1) = buf(0:j) + index(0:k-1) = ibuf(0:j) + exit merge_upper + end if + end if + end do merge_upper + end if + end subroutine merge + + + pure subroutine reverse_segment( array, index ) +! Reverse a segment of an array in place + integer(int16), intent(inout) :: array(0:) + integer(int_size), intent(inout) :: index(0:) + + integer(int_size) :: itemp, lo, hi + integer(int16) :: temp + + lo = 0 + hi = size( array, kind=int_size ) - 1 + do while( lo < hi ) + temp = array(lo) + array(lo) = array(hi) + array(hi) = temp + itemp = index(lo) + index(lo) = index(hi) + index(hi) = itemp + lo = lo + 1 + hi = hi - 1 + end do + + end subroutine reverse_segment + + end subroutine int16_sort_index + + + module subroutine int32_sort_index( array, index, work, iwork, reverse ) +! A modification of `int32_ord_sort` to return an array of indices that +! would perform a stable sort of the `ARRAY` as input, and also sort `ARRAY` +! as desired. The indices by default +! correspond to a non-decreasing sort, but if the optional argument +! `REVERSE` is present with a value of `.TRUE.` the indices correspond to +! a non-increasing sort. The logic of the determination of indexing largely +! follows the `"Rust" sort` found in `slice.rs`: +! https://github.com/rust-lang/rust/blob/90eb44a5897c39e3dff9c7e48e3973671dcd9496/src/liballoc/slice.rs#L2159 +! The Rust version is a simplification of the Timsort algorithm described +! in https://svn.python.org/projects/python/trunk/Objects/listsort.txt, as +! it drops both the use of 'galloping' to identify bounds of regions to be +! sorted and the estimation of the optimal `run size`. However it remains +! a hybrid sorting algorithm combining an iterative Merge sort controlled +! by a stack of `RUNS` identified by regions of uniformly decreasing or +! non-decreasing sequences that may be expanded to a minimum run size, with +! an insertion sort. +! +! Note the Fortran implementation simplifies the logic as it only has to +! deal with Fortran arrays of intrinsic types and not the full generality +! of Rust's arrays and lists for arbitrary types. It also adds the +! estimation of the optimal `run size` as suggested in Tim Peters' +! original listsort.txt, and the optional `work` and `iwork` arraya to be +! used as scratch memory. + + integer(int32), intent(inout) :: array(0:) + integer(int_size), intent(out) :: index(0:) + integer(int32), intent(out), optional :: work(0:) + integer(int_size), intent(out), optional :: iwork(0:) + logical, intent(in), optional :: reverse + + integer(int_size) :: array_size, i, stat + integer(int32), allocatable :: buf(:) + integer(int_size), allocatable :: ibuf(:) + + array_size = size(array, kind=int_size) + + do i = 0, array_size-1 + index(i) = i+1 + end do + + if ( present(reverse) ) then + if ( reverse ) then + call reverse_segment( array, index ) + end if + end if + +! If necessary allocate buffers to serve as scratch memory. + if ( present(work) ) then + if ( size(work, kind=int_size) < array_size/2 ) then + error stop "work array is too small." + end if + if ( present(iwork) ) then + if ( size(iwork, kind=int_size) < array_size/2 ) then + error stop "iwork array is too small." + endif + call merge_sort( array, index, work, iwork ) + else + allocate( ibuf(0:array_size/2-1), stat=stat ) + if ( stat /= 0 ) error stop "Allocation of index buffer failed." + call merge_sort( array, index, work, ibuf ) + end if + else + allocate( buf(0:array_size/2-1), stat=stat ) + if ( stat /= 0 ) error stop "Allocation of array buffer failed." + if ( present(iwork) ) then + if ( size(iwork, kind=int_size) < array_size/2 ) then + error stop "iwork array is too small." + endif + call merge_sort( array, index, buf, iwork ) + else + allocate( ibuf(0:array_size/2-1), stat=stat ) + if ( stat /= 0 ) error stop "Allocation of index buffer failed." + call merge_sort( array, index, buf, ibuf ) + end if + end if + + if ( present(reverse) ) then + if ( reverse ) then + call reverse_segment( array, index ) + end if + end if + + contains + + pure function calc_min_run( n ) result(min_run) +!! Returns the minimum length of a run from 32-63 so that N/MIN_RUN is +!! less than or equal to a power of two. See +!! https://svn.python.org/projects/python/trunk/Objects/listsort.txt + integer(int_size) :: min_run + integer(int_size), intent(in) :: n + + integer(int_size) :: num, r + + num = n + r = 0_int_size + + do while( num >= 64 ) + r = ior( r, iand(num, 1_int_size) ) + num = ishft(num, -1_int_size) + end do + min_run = num + r + + end function calc_min_run + + + pure subroutine insertion_sort( array, index ) +! Sorts `ARRAY` using an insertion sort, while maintaining consistency in +! location of the indices in `INDEX` to the elements of `ARRAY`. + integer(int32), intent(inout) :: array(0:) + integer(int_size), intent(inout) :: index(0:) + + integer(int_size) :: i, j, key_index + integer(int32) :: key + + do j=1, size(array, kind=int_size)-1 + key = array(j) + key_index = index(j) + i = j - 1 + do while( i >= 0 ) + if ( array(i) <= key ) exit + array(i+1) = array(i) + index(i+1) = index(i) + i = i - 1 + end do + array(i+1) = key + index(i+1) = key_index + end do + + end subroutine insertion_sort + + + pure function collapse( runs ) result ( r ) +! Examine the stack of runs waiting to be merged, identifying adjacent runs +! to be merged until the stack invariants are restablished: +! +! 1. len(-3) > len(-2) + len(-1) +! 2. len(-2) > len(-1) + + integer(int_size) :: r + type(run_type), intent(in), target :: runs(0:) + + integer(int_size) :: n + logical :: test + + n = size(runs, kind=int_size) + test = .false. + if (n >= 2) then + if ( runs( n-1 ) % base == 0 .or. & + runs( n-2 ) % len <= runs(n-1) % len ) then + test = .true. + else if ( n >= 3 ) then ! X exists + if ( runs(n-3) % len <= & + runs(n-2) % len + runs(n-1) % len ) then + test = .true. +! |X| <= |Y| + |Z| => will need to merge due to rho1 or rho2 + else if( n >= 4 ) then + if ( runs(n-4) % len <= & + runs(n-3) % len + runs(n-2) % len ) then + test = .true. +! |W| <= |X| + |Y| => will need to merge due to rho1 or rho3 + end if + end if + end if + end if + if ( test ) then +! By default merge Y & Z, rho2 or rho3 + if ( n >= 3 ) then + if ( runs(n-3) % len < runs(n-1) % len ) then + r = n - 3 +! |X| < |Z| => merge X & Y, rho1 + return + end if + end if + r = n - 2 +! |Y| <= |Z| => merge Y & Z, rho4 + return + else + r = -1 + end if + + end function collapse + + + pure subroutine insert_head( array, index ) +! Inserts `array(0)` into the pre-sorted sequence `array(1:)` so that the +! whole `array(0:)` becomes sorted, copying the first element into +! a temporary variable, iterating until the right place for it is found. +! copying every traversed element into the slot preceding it, and finally, +! copying data from the temporary variable into the resulting hole. +! Consistency of the indices in `index` with the elements of `array` +! are maintained. + + integer(int32), intent(inout) :: array(0:) + integer(int_size), intent(inout) :: index(0:) + + integer(int32) :: tmp + integer(int_size) :: i, tmp_index + + tmp = array(0) + tmp_index = index(0) + find_hole: do i=1, size(array, kind=int_size)-1 + if ( array(i) >= tmp ) exit find_hole + array(i-1) = array(i) + index(i-1) = index(i) + end do find_hole + array(i-1) = tmp + index(i-1) = tmp_index + + end subroutine insert_head + + + subroutine merge_sort( array, index, buf, ibuf ) +! The Rust merge sort borrows some (but not all) of the ideas from TimSort, +! which is described in detail at +! (http://svn.python.org/projects/python/trunk/Objects/listsort.txt). +! +! The algorithm identifies strictly descending and non-descending +! subsequences, which are called natural runs. Where these runs are less +! than a minimum run size they are padded by adding additional samples +! using an insertion sort. The merge process is driven by a stack of +! pending unmerged runs. Each newly found run is pushed onto the stack, +! and then pairs of adjacentd runs are merged until these two invariants +! are satisfied: +! +! 1. for every `i` in `1..size(runs)-1`: `runs(i - 1)%len > runs(i)%len` +! 2. for every `i` in `2..size(runs)-1`: `runs(i - 2)%len > +! runs(i - 1)%len + runs(i)%len` +! +! The invariants ensure that the total running time is `O(n log n)` +! worst-case. Consistency of the indices in `index` with the elements of +! `array` are maintained. + + integer(int32), intent(inout) :: array(0:) + integer(int_size), intent(inout) :: index(0:) + integer(int32), intent(inout) :: buf(0:) + integer(int_size), intent(inout) :: ibuf(0:) + + integer(int_size) :: array_size, finish, min_run, r, r_count, & + start + type(run_type) :: runs(0:max_merge_stack-1), left, right + + array_size = size(array, kind=int_size) + +! Very short runs are extended using insertion sort to span at least this +! many elements. Slices of up to this length are sorted using insertion sort. + min_run = calc_min_run( array_size ) + + if ( array_size <= min_run ) then + if ( array_size >= 2 ) call insertion_sort( array, index ) + return + end if + + +! Following Rust sort, natural runs in `array` are identified by traversing +! it backwards. By traversing it backward, merges more often go in the +! opposite direction (forwards). According to developers of Rust sort, +! merging forwards is slightly faster than merging backwards. Therefore +! identifying runs by traversing backwards should improve performance. + r_count = 0 + finish = array_size - 1 + do while ( finish >= 0 ) +! Find the next natural run, and reverse it if it's strictly descending. + start = finish + if ( start > 0 ) then + start = start - 1 + if ( array(start+1) < array(start) ) then + Descending: do while ( start > 0 ) + if ( array(start) >= array(start-1) ) & + exit Descending + start = start - 1 + end do Descending + call reverse_segment( array(start:finish), & + index(start:finish) ) + else + Ascending: do while( start > 0 ) + if ( array(start) < array(start-1) ) exit Ascending + start = start - 1 + end do Ascending + end if + end if + +! If the run is too short insert some more elements using an insertion sort. + Insert: do while ( start > 0 ) + if ( finish - start >= min_run - 1 ) exit Insert + start = start - 1 + call insert_head( array(start:finish), index(start:finish) ) + end do Insert + if ( start == 0 .and. finish == array_size - 1 ) return + + runs(r_count) = run_type( base = start, & + len = finish - start + 1 ) + finish = start-1 + r_count = r_count + 1 + +! Determine whether pairs of adjacent runs need to be merged to satisfy +! the invariants, and, if so, merge them. + Merge_loop: do + r = collapse( runs(0:r_count - 1) ) + if ( r < 0 .or. r_count <= 1 ) exit Merge_loop + left = runs( r + 1 ) + right = runs( r ) + call merge( array( left % base: & + right % base + right % len - 1 ), & + left % len, buf, & + index( left % base: & + right % base + right % len - 1 ), ibuf ) + + runs(r) = run_type( base = left % base, & + len = left % len + right % len ) + if ( r == r_count - 3 ) runs(r+1) = runs(r+2) + r_count = r_count - 1 + + end do Merge_loop + end do + if ( r_count /= 1 ) & + error stop "MERGE_SORT completed without RUN COUNT == 1." + + end subroutine merge_sort + + + pure subroutine merge( array, mid, buf, index, ibuf ) +! Merges the two non-decreasing runs `ARRAY(0:MID-1)` and `ARRAY(MID:)` +! using `BUF` as temporary storage, and stores the merged runs into +! `ARRAY(0:)`. `MID` must be > 0, and < `SIZE(ARRAY)-1`. Buffer `BUF` +! must be long enough to hold the shorter of the two runs. + integer(int32), intent(inout) :: array(0:) + integer(int_size), intent(in) :: mid + integer(int32), intent(inout) :: buf(0:) + integer(int_size), intent(inout) :: index(0:) + integer(int_size), intent(inout) :: ibuf(0:) + + integer(int_size) :: array_len, i, j, k + + array_len = size(array, kind=int_size) + +! Merge first copies the shorter run into `buf`. Then, depending on which +! run was shorter, it traces the copied run and the longer run forwards +! (or backwards), comparing their next unprocessed elements and then +! copying the lesser (or greater) one into `array`. + + if ( mid <= array_len - mid ) then ! The left run is shorter. + buf(0:mid-1) = array(0:mid-1) + ibuf(0:mid-1) = index(0:mid-1) + i = 0 + j = mid + merge_lower: do k = 0, array_len-1 + if ( buf(i) <= array(j) ) then + array(k) = buf(i) + index(k) = ibuf(i) + i = i + 1 + if ( i >= mid ) exit merge_lower + else + array(k) = array(j) + index(k) = index(j) + j = j + 1 + if ( j >= array_len ) then + array(k+1:) = buf(i:mid-1) + index(k+1:) = ibuf(i:mid-1) + exit merge_lower + end if + end if + end do merge_lower + else ! The right run is shorter + buf(0:array_len-mid-1) = array(mid:array_len-1) + ibuf(0:array_len-mid-1) = index(mid:array_len-1) + i = mid - 1 + j = array_len - mid -1 + merge_upper: do k = array_len-1, 0, -1 + if ( buf(j) >= array(i) ) then + array(k) = buf(j) + index(k) = ibuf(j) + j = j - 1 + if ( j < 0 ) exit merge_upper + else + array(k) = array(i) + index(k) = index(i) + i = i - 1 + if ( i < 0 ) then + array(0:k-1) = buf(0:j) + index(0:k-1) = ibuf(0:j) + exit merge_upper + end if + end if + end do merge_upper + end if + end subroutine merge + + + pure subroutine reverse_segment( array, index ) +! Reverse a segment of an array in place + integer(int32), intent(inout) :: array(0:) + integer(int_size), intent(inout) :: index(0:) + + integer(int_size) :: itemp, lo, hi + integer(int32) :: temp + + lo = 0 + hi = size( array, kind=int_size ) - 1 + do while( lo < hi ) + temp = array(lo) + array(lo) = array(hi) + array(hi) = temp + itemp = index(lo) + index(lo) = index(hi) + index(hi) = itemp + lo = lo + 1 + hi = hi - 1 + end do + + end subroutine reverse_segment + + end subroutine int32_sort_index + + + module subroutine int64_sort_index( array, index, work, iwork, reverse ) +! A modification of `int64_ord_sort` to return an array of indices that +! would perform a stable sort of the `ARRAY` as input, and also sort `ARRAY` +! as desired. The indices by default +! correspond to a non-decreasing sort, but if the optional argument +! `REVERSE` is present with a value of `.TRUE.` the indices correspond to +! a non-increasing sort. The logic of the determination of indexing largely +! follows the `"Rust" sort` found in `slice.rs`: +! https://github.com/rust-lang/rust/blob/90eb44a5897c39e3dff9c7e48e3973671dcd9496/src/liballoc/slice.rs#L2159 +! The Rust version is a simplification of the Timsort algorithm described +! in https://svn.python.org/projects/python/trunk/Objects/listsort.txt, as +! it drops both the use of 'galloping' to identify bounds of regions to be +! sorted and the estimation of the optimal `run size`. However it remains +! a hybrid sorting algorithm combining an iterative Merge sort controlled +! by a stack of `RUNS` identified by regions of uniformly decreasing or +! non-decreasing sequences that may be expanded to a minimum run size, with +! an insertion sort. +! +! Note the Fortran implementation simplifies the logic as it only has to +! deal with Fortran arrays of intrinsic types and not the full generality +! of Rust's arrays and lists for arbitrary types. It also adds the +! estimation of the optimal `run size` as suggested in Tim Peters' +! original listsort.txt, and the optional `work` and `iwork` arraya to be +! used as scratch memory. + + integer(int64), intent(inout) :: array(0:) + integer(int_size), intent(out) :: index(0:) + integer(int64), intent(out), optional :: work(0:) + integer(int_size), intent(out), optional :: iwork(0:) + logical, intent(in), optional :: reverse + + integer(int_size) :: array_size, i, stat + integer(int64), allocatable :: buf(:) + integer(int_size), allocatable :: ibuf(:) + + array_size = size(array, kind=int_size) + + do i = 0, array_size-1 + index(i) = i+1 + end do + + if ( present(reverse) ) then + if ( reverse ) then + call reverse_segment( array, index ) + end if + end if + +! If necessary allocate buffers to serve as scratch memory. + if ( present(work) ) then + if ( size(work, kind=int_size) < array_size/2 ) then + error stop "work array is too small." + end if + if ( present(iwork) ) then + if ( size(iwork, kind=int_size) < array_size/2 ) then + error stop "iwork array is too small." + endif + call merge_sort( array, index, work, iwork ) + else + allocate( ibuf(0:array_size/2-1), stat=stat ) + if ( stat /= 0 ) error stop "Allocation of index buffer failed." + call merge_sort( array, index, work, ibuf ) + end if + else + allocate( buf(0:array_size/2-1), stat=stat ) + if ( stat /= 0 ) error stop "Allocation of array buffer failed." + if ( present(iwork) ) then + if ( size(iwork, kind=int_size) < array_size/2 ) then + error stop "iwork array is too small." + endif + call merge_sort( array, index, buf, iwork ) + else + allocate( ibuf(0:array_size/2-1), stat=stat ) + if ( stat /= 0 ) error stop "Allocation of index buffer failed." + call merge_sort( array, index, buf, ibuf ) + end if + end if + + if ( present(reverse) ) then + if ( reverse ) then + call reverse_segment( array, index ) + end if + end if + + contains + + pure function calc_min_run( n ) result(min_run) +!! Returns the minimum length of a run from 32-63 so that N/MIN_RUN is +!! less than or equal to a power of two. See +!! https://svn.python.org/projects/python/trunk/Objects/listsort.txt + integer(int_size) :: min_run + integer(int_size), intent(in) :: n + + integer(int_size) :: num, r + + num = n + r = 0_int_size + + do while( num >= 64 ) + r = ior( r, iand(num, 1_int_size) ) + num = ishft(num, -1_int_size) + end do + min_run = num + r + + end function calc_min_run + + + pure subroutine insertion_sort( array, index ) +! Sorts `ARRAY` using an insertion sort, while maintaining consistency in +! location of the indices in `INDEX` to the elements of `ARRAY`. + integer(int64), intent(inout) :: array(0:) + integer(int_size), intent(inout) :: index(0:) + + integer(int_size) :: i, j, key_index + integer(int64) :: key + + do j=1, size(array, kind=int_size)-1 + key = array(j) + key_index = index(j) + i = j - 1 + do while( i >= 0 ) + if ( array(i) <= key ) exit + array(i+1) = array(i) + index(i+1) = index(i) + i = i - 1 + end do + array(i+1) = key + index(i+1) = key_index + end do + + end subroutine insertion_sort + + + pure function collapse( runs ) result ( r ) +! Examine the stack of runs waiting to be merged, identifying adjacent runs +! to be merged until the stack invariants are restablished: +! +! 1. len(-3) > len(-2) + len(-1) +! 2. len(-2) > len(-1) + + integer(int_size) :: r + type(run_type), intent(in), target :: runs(0:) + + integer(int_size) :: n + logical :: test + + n = size(runs, kind=int_size) + test = .false. + if (n >= 2) then + if ( runs( n-1 ) % base == 0 .or. & + runs( n-2 ) % len <= runs(n-1) % len ) then + test = .true. + else if ( n >= 3 ) then ! X exists + if ( runs(n-3) % len <= & + runs(n-2) % len + runs(n-1) % len ) then + test = .true. +! |X| <= |Y| + |Z| => will need to merge due to rho1 or rho2 + else if( n >= 4 ) then + if ( runs(n-4) % len <= & + runs(n-3) % len + runs(n-2) % len ) then + test = .true. +! |W| <= |X| + |Y| => will need to merge due to rho1 or rho3 + end if + end if + end if + end if + if ( test ) then +! By default merge Y & Z, rho2 or rho3 + if ( n >= 3 ) then + if ( runs(n-3) % len < runs(n-1) % len ) then + r = n - 3 +! |X| < |Z| => merge X & Y, rho1 + return + end if + end if + r = n - 2 +! |Y| <= |Z| => merge Y & Z, rho4 + return + else + r = -1 + end if + + end function collapse + + + pure subroutine insert_head( array, index ) +! Inserts `array(0)` into the pre-sorted sequence `array(1:)` so that the +! whole `array(0:)` becomes sorted, copying the first element into +! a temporary variable, iterating until the right place for it is found. +! copying every traversed element into the slot preceding it, and finally, +! copying data from the temporary variable into the resulting hole. +! Consistency of the indices in `index` with the elements of `array` +! are maintained. + + integer(int64), intent(inout) :: array(0:) + integer(int_size), intent(inout) :: index(0:) + + integer(int64) :: tmp + integer(int_size) :: i, tmp_index + + tmp = array(0) + tmp_index = index(0) + find_hole: do i=1, size(array, kind=int_size)-1 + if ( array(i) >= tmp ) exit find_hole + array(i-1) = array(i) + index(i-1) = index(i) + end do find_hole + array(i-1) = tmp + index(i-1) = tmp_index + + end subroutine insert_head + + + subroutine merge_sort( array, index, buf, ibuf ) +! The Rust merge sort borrows some (but not all) of the ideas from TimSort, +! which is described in detail at +! (http://svn.python.org/projects/python/trunk/Objects/listsort.txt). +! +! The algorithm identifies strictly descending and non-descending +! subsequences, which are called natural runs. Where these runs are less +! than a minimum run size they are padded by adding additional samples +! using an insertion sort. The merge process is driven by a stack of +! pending unmerged runs. Each newly found run is pushed onto the stack, +! and then pairs of adjacentd runs are merged until these two invariants +! are satisfied: +! +! 1. for every `i` in `1..size(runs)-1`: `runs(i - 1)%len > runs(i)%len` +! 2. for every `i` in `2..size(runs)-1`: `runs(i - 2)%len > +! runs(i - 1)%len + runs(i)%len` +! +! The invariants ensure that the total running time is `O(n log n)` +! worst-case. Consistency of the indices in `index` with the elements of +! `array` are maintained. + + integer(int64), intent(inout) :: array(0:) + integer(int_size), intent(inout) :: index(0:) + integer(int64), intent(inout) :: buf(0:) + integer(int_size), intent(inout) :: ibuf(0:) + + integer(int_size) :: array_size, finish, min_run, r, r_count, & + start + type(run_type) :: runs(0:max_merge_stack-1), left, right + + array_size = size(array, kind=int_size) + +! Very short runs are extended using insertion sort to span at least this +! many elements. Slices of up to this length are sorted using insertion sort. + min_run = calc_min_run( array_size ) + + if ( array_size <= min_run ) then + if ( array_size >= 2 ) call insertion_sort( array, index ) + return + end if + + +! Following Rust sort, natural runs in `array` are identified by traversing +! it backwards. By traversing it backward, merges more often go in the +! opposite direction (forwards). According to developers of Rust sort, +! merging forwards is slightly faster than merging backwards. Therefore +! identifying runs by traversing backwards should improve performance. + r_count = 0 + finish = array_size - 1 + do while ( finish >= 0 ) +! Find the next natural run, and reverse it if it's strictly descending. + start = finish + if ( start > 0 ) then + start = start - 1 + if ( array(start+1) < array(start) ) then + Descending: do while ( start > 0 ) + if ( array(start) >= array(start-1) ) & + exit Descending + start = start - 1 + end do Descending + call reverse_segment( array(start:finish), & + index(start:finish) ) + else + Ascending: do while( start > 0 ) + if ( array(start) < array(start-1) ) exit Ascending + start = start - 1 + end do Ascending + end if + end if + +! If the run is too short insert some more elements using an insertion sort. + Insert: do while ( start > 0 ) + if ( finish - start >= min_run - 1 ) exit Insert + start = start - 1 + call insert_head( array(start:finish), index(start:finish) ) + end do Insert + if ( start == 0 .and. finish == array_size - 1 ) return + + runs(r_count) = run_type( base = start, & + len = finish - start + 1 ) + finish = start-1 + r_count = r_count + 1 + +! Determine whether pairs of adjacent runs need to be merged to satisfy +! the invariants, and, if so, merge them. + Merge_loop: do + r = collapse( runs(0:r_count - 1) ) + if ( r < 0 .or. r_count <= 1 ) exit Merge_loop + left = runs( r + 1 ) + right = runs( r ) + call merge( array( left % base: & + right % base + right % len - 1 ), & + left % len, buf, & + index( left % base: & + right % base + right % len - 1 ), ibuf ) + + runs(r) = run_type( base = left % base, & + len = left % len + right % len ) + if ( r == r_count - 3 ) runs(r+1) = runs(r+2) + r_count = r_count - 1 + + end do Merge_loop + end do + if ( r_count /= 1 ) & + error stop "MERGE_SORT completed without RUN COUNT == 1." + + end subroutine merge_sort + + + pure subroutine merge( array, mid, buf, index, ibuf ) +! Merges the two non-decreasing runs `ARRAY(0:MID-1)` and `ARRAY(MID:)` +! using `BUF` as temporary storage, and stores the merged runs into +! `ARRAY(0:)`. `MID` must be > 0, and < `SIZE(ARRAY)-1`. Buffer `BUF` +! must be long enough to hold the shorter of the two runs. + integer(int64), intent(inout) :: array(0:) + integer(int_size), intent(in) :: mid + integer(int64), intent(inout) :: buf(0:) + integer(int_size), intent(inout) :: index(0:) + integer(int_size), intent(inout) :: ibuf(0:) + + integer(int_size) :: array_len, i, j, k + + array_len = size(array, kind=int_size) + +! Merge first copies the shorter run into `buf`. Then, depending on which +! run was shorter, it traces the copied run and the longer run forwards +! (or backwards), comparing their next unprocessed elements and then +! copying the lesser (or greater) one into `array`. + + if ( mid <= array_len - mid ) then ! The left run is shorter. + buf(0:mid-1) = array(0:mid-1) + ibuf(0:mid-1) = index(0:mid-1) + i = 0 + j = mid + merge_lower: do k = 0, array_len-1 + if ( buf(i) <= array(j) ) then + array(k) = buf(i) + index(k) = ibuf(i) + i = i + 1 + if ( i >= mid ) exit merge_lower + else + array(k) = array(j) + index(k) = index(j) + j = j + 1 + if ( j >= array_len ) then + array(k+1:) = buf(i:mid-1) + index(k+1:) = ibuf(i:mid-1) + exit merge_lower + end if + end if + end do merge_lower + else ! The right run is shorter + buf(0:array_len-mid-1) = array(mid:array_len-1) + ibuf(0:array_len-mid-1) = index(mid:array_len-1) + i = mid - 1 + j = array_len - mid -1 + merge_upper: do k = array_len-1, 0, -1 + if ( buf(j) >= array(i) ) then + array(k) = buf(j) + index(k) = ibuf(j) + j = j - 1 + if ( j < 0 ) exit merge_upper + else + array(k) = array(i) + index(k) = index(i) + i = i - 1 + if ( i < 0 ) then + array(0:k-1) = buf(0:j) + index(0:k-1) = ibuf(0:j) + exit merge_upper + end if + end if + end do merge_upper + end if + end subroutine merge + + + pure subroutine reverse_segment( array, index ) +! Reverse a segment of an array in place + integer(int64), intent(inout) :: array(0:) + integer(int_size), intent(inout) :: index(0:) + + integer(int_size) :: itemp, lo, hi + integer(int64) :: temp + + lo = 0 + hi = size( array, kind=int_size ) - 1 + do while( lo < hi ) + temp = array(lo) + array(lo) = array(hi) + array(hi) = temp + itemp = index(lo) + index(lo) = index(hi) + index(hi) = itemp + lo = lo + 1 + hi = hi - 1 + end do + + end subroutine reverse_segment + + end subroutine int64_sort_index + + + module subroutine sp_sort_index( array, index, work, iwork, reverse ) +! A modification of `sp_ord_sort` to return an array of indices that +! would perform a stable sort of the `ARRAY` as input, and also sort `ARRAY` +! as desired. The indices by default +! correspond to a non-decreasing sort, but if the optional argument +! `REVERSE` is present with a value of `.TRUE.` the indices correspond to +! a non-increasing sort. The logic of the determination of indexing largely +! follows the `"Rust" sort` found in `slice.rs`: +! https://github.com/rust-lang/rust/blob/90eb44a5897c39e3dff9c7e48e3973671dcd9496/src/liballoc/slice.rs#L2159 +! The Rust version is a simplification of the Timsort algorithm described +! in https://svn.python.org/projects/python/trunk/Objects/listsort.txt, as +! it drops both the use of 'galloping' to identify bounds of regions to be +! sorted and the estimation of the optimal `run size`. However it remains +! a hybrid sorting algorithm combining an iterative Merge sort controlled +! by a stack of `RUNS` identified by regions of uniformly decreasing or +! non-decreasing sequences that may be expanded to a minimum run size, with +! an insertion sort. +! +! Note the Fortran implementation simplifies the logic as it only has to +! deal with Fortran arrays of intrinsic types and not the full generality +! of Rust's arrays and lists for arbitrary types. It also adds the +! estimation of the optimal `run size` as suggested in Tim Peters' +! original listsort.txt, and the optional `work` and `iwork` arraya to be +! used as scratch memory. + + real(sp), intent(inout) :: array(0:) + integer(int_size), intent(out) :: index(0:) + real(sp), intent(out), optional :: work(0:) + integer(int_size), intent(out), optional :: iwork(0:) + logical, intent(in), optional :: reverse + + integer(int_size) :: array_size, i, stat + real(sp), allocatable :: buf(:) + integer(int_size), allocatable :: ibuf(:) + + array_size = size(array, kind=int_size) + + do i = 0, array_size-1 + index(i) = i+1 + end do + + if ( present(reverse) ) then + if ( reverse ) then + call reverse_segment( array, index ) + end if + end if + +! If necessary allocate buffers to serve as scratch memory. + if ( present(work) ) then + if ( size(work, kind=int_size) < array_size/2 ) then + error stop "work array is too small." + end if + if ( present(iwork) ) then + if ( size(iwork, kind=int_size) < array_size/2 ) then + error stop "iwork array is too small." + endif + call merge_sort( array, index, work, iwork ) + else + allocate( ibuf(0:array_size/2-1), stat=stat ) + if ( stat /= 0 ) error stop "Allocation of index buffer failed." + call merge_sort( array, index, work, ibuf ) + end if + else + allocate( buf(0:array_size/2-1), stat=stat ) + if ( stat /= 0 ) error stop "Allocation of array buffer failed." + if ( present(iwork) ) then + if ( size(iwork, kind=int_size) < array_size/2 ) then + error stop "iwork array is too small." + endif + call merge_sort( array, index, buf, iwork ) + else + allocate( ibuf(0:array_size/2-1), stat=stat ) + if ( stat /= 0 ) error stop "Allocation of index buffer failed." + call merge_sort( array, index, buf, ibuf ) + end if + end if + + if ( present(reverse) ) then + if ( reverse ) then + call reverse_segment( array, index ) + end if + end if + + contains + + pure function calc_min_run( n ) result(min_run) +!! Returns the minimum length of a run from 32-63 so that N/MIN_RUN is +!! less than or equal to a power of two. See +!! https://svn.python.org/projects/python/trunk/Objects/listsort.txt + integer(int_size) :: min_run + integer(int_size), intent(in) :: n + + integer(int_size) :: num, r + + num = n + r = 0_int_size + + do while( num >= 64 ) + r = ior( r, iand(num, 1_int_size) ) + num = ishft(num, -1_int_size) + end do + min_run = num + r + + end function calc_min_run + + + pure subroutine insertion_sort( array, index ) +! Sorts `ARRAY` using an insertion sort, while maintaining consistency in +! location of the indices in `INDEX` to the elements of `ARRAY`. + real(sp), intent(inout) :: array(0:) + integer(int_size), intent(inout) :: index(0:) + + integer(int_size) :: i, j, key_index + real(sp) :: key + + do j=1, size(array, kind=int_size)-1 + key = array(j) + key_index = index(j) + i = j - 1 + do while( i >= 0 ) + if ( array(i) <= key ) exit + array(i+1) = array(i) + index(i+1) = index(i) + i = i - 1 + end do + array(i+1) = key + index(i+1) = key_index + end do + + end subroutine insertion_sort + + + pure function collapse( runs ) result ( r ) +! Examine the stack of runs waiting to be merged, identifying adjacent runs +! to be merged until the stack invariants are restablished: +! +! 1. len(-3) > len(-2) + len(-1) +! 2. len(-2) > len(-1) + + integer(int_size) :: r + type(run_type), intent(in), target :: runs(0:) + + integer(int_size) :: n + logical :: test + + n = size(runs, kind=int_size) + test = .false. + if (n >= 2) then + if ( runs( n-1 ) % base == 0 .or. & + runs( n-2 ) % len <= runs(n-1) % len ) then + test = .true. + else if ( n >= 3 ) then ! X exists + if ( runs(n-3) % len <= & + runs(n-2) % len + runs(n-1) % len ) then + test = .true. +! |X| <= |Y| + |Z| => will need to merge due to rho1 or rho2 + else if( n >= 4 ) then + if ( runs(n-4) % len <= & + runs(n-3) % len + runs(n-2) % len ) then + test = .true. +! |W| <= |X| + |Y| => will need to merge due to rho1 or rho3 + end if + end if + end if + end if + if ( test ) then +! By default merge Y & Z, rho2 or rho3 + if ( n >= 3 ) then + if ( runs(n-3) % len < runs(n-1) % len ) then + r = n - 3 +! |X| < |Z| => merge X & Y, rho1 + return + end if + end if + r = n - 2 +! |Y| <= |Z| => merge Y & Z, rho4 + return + else + r = -1 + end if + + end function collapse + + + pure subroutine insert_head( array, index ) +! Inserts `array(0)` into the pre-sorted sequence `array(1:)` so that the +! whole `array(0:)` becomes sorted, copying the first element into +! a temporary variable, iterating until the right place for it is found. +! copying every traversed element into the slot preceding it, and finally, +! copying data from the temporary variable into the resulting hole. +! Consistency of the indices in `index` with the elements of `array` +! are maintained. + + real(sp), intent(inout) :: array(0:) + integer(int_size), intent(inout) :: index(0:) + + real(sp) :: tmp + integer(int_size) :: i, tmp_index + + tmp = array(0) + tmp_index = index(0) + find_hole: do i=1, size(array, kind=int_size)-1 + if ( array(i) >= tmp ) exit find_hole + array(i-1) = array(i) + index(i-1) = index(i) + end do find_hole + array(i-1) = tmp + index(i-1) = tmp_index + + end subroutine insert_head + + + subroutine merge_sort( array, index, buf, ibuf ) +! The Rust merge sort borrows some (but not all) of the ideas from TimSort, +! which is described in detail at +! (http://svn.python.org/projects/python/trunk/Objects/listsort.txt). +! +! The algorithm identifies strictly descending and non-descending +! subsequences, which are called natural runs. Where these runs are less +! than a minimum run size they are padded by adding additional samples +! using an insertion sort. The merge process is driven by a stack of +! pending unmerged runs. Each newly found run is pushed onto the stack, +! and then pairs of adjacentd runs are merged until these two invariants +! are satisfied: +! +! 1. for every `i` in `1..size(runs)-1`: `runs(i - 1)%len > runs(i)%len` +! 2. for every `i` in `2..size(runs)-1`: `runs(i - 2)%len > +! runs(i - 1)%len + runs(i)%len` +! +! The invariants ensure that the total running time is `O(n log n)` +! worst-case. Consistency of the indices in `index` with the elements of +! `array` are maintained. + + real(sp), intent(inout) :: array(0:) + integer(int_size), intent(inout) :: index(0:) + real(sp), intent(inout) :: buf(0:) + integer(int_size), intent(inout) :: ibuf(0:) + + integer(int_size) :: array_size, finish, min_run, r, r_count, & + start + type(run_type) :: runs(0:max_merge_stack-1), left, right + + array_size = size(array, kind=int_size) + +! Very short runs are extended using insertion sort to span at least this +! many elements. Slices of up to this length are sorted using insertion sort. + min_run = calc_min_run( array_size ) + + if ( array_size <= min_run ) then + if ( array_size >= 2 ) call insertion_sort( array, index ) + return + end if + + +! Following Rust sort, natural runs in `array` are identified by traversing +! it backwards. By traversing it backward, merges more often go in the +! opposite direction (forwards). According to developers of Rust sort, +! merging forwards is slightly faster than merging backwards. Therefore +! identifying runs by traversing backwards should improve performance. + r_count = 0 + finish = array_size - 1 + do while ( finish >= 0 ) +! Find the next natural run, and reverse it if it's strictly descending. + start = finish + if ( start > 0 ) then + start = start - 1 + if ( array(start+1) < array(start) ) then + Descending: do while ( start > 0 ) + if ( array(start) >= array(start-1) ) & + exit Descending + start = start - 1 + end do Descending + call reverse_segment( array(start:finish), & + index(start:finish) ) + else + Ascending: do while( start > 0 ) + if ( array(start) < array(start-1) ) exit Ascending + start = start - 1 + end do Ascending + end if + end if + +! If the run is too short insert some more elements using an insertion sort. + Insert: do while ( start > 0 ) + if ( finish - start >= min_run - 1 ) exit Insert + start = start - 1 + call insert_head( array(start:finish), index(start:finish) ) + end do Insert + if ( start == 0 .and. finish == array_size - 1 ) return + + runs(r_count) = run_type( base = start, & + len = finish - start + 1 ) + finish = start-1 + r_count = r_count + 1 + +! Determine whether pairs of adjacent runs need to be merged to satisfy +! the invariants, and, if so, merge them. + Merge_loop: do + r = collapse( runs(0:r_count - 1) ) + if ( r < 0 .or. r_count <= 1 ) exit Merge_loop + left = runs( r + 1 ) + right = runs( r ) + call merge( array( left % base: & + right % base + right % len - 1 ), & + left % len, buf, & + index( left % base: & + right % base + right % len - 1 ), ibuf ) + + runs(r) = run_type( base = left % base, & + len = left % len + right % len ) + if ( r == r_count - 3 ) runs(r+1) = runs(r+2) + r_count = r_count - 1 + + end do Merge_loop + end do + if ( r_count /= 1 ) & + error stop "MERGE_SORT completed without RUN COUNT == 1." + + end subroutine merge_sort + + + pure subroutine merge( array, mid, buf, index, ibuf ) +! Merges the two non-decreasing runs `ARRAY(0:MID-1)` and `ARRAY(MID:)` +! using `BUF` as temporary storage, and stores the merged runs into +! `ARRAY(0:)`. `MID` must be > 0, and < `SIZE(ARRAY)-1`. Buffer `BUF` +! must be long enough to hold the shorter of the two runs. + real(sp), intent(inout) :: array(0:) + integer(int_size), intent(in) :: mid + real(sp), intent(inout) :: buf(0:) + integer(int_size), intent(inout) :: index(0:) + integer(int_size), intent(inout) :: ibuf(0:) + + integer(int_size) :: array_len, i, j, k + + array_len = size(array, kind=int_size) + +! Merge first copies the shorter run into `buf`. Then, depending on which +! run was shorter, it traces the copied run and the longer run forwards +! (or backwards), comparing their next unprocessed elements and then +! copying the lesser (or greater) one into `array`. + + if ( mid <= array_len - mid ) then ! The left run is shorter. + buf(0:mid-1) = array(0:mid-1) + ibuf(0:mid-1) = index(0:mid-1) + i = 0 + j = mid + merge_lower: do k = 0, array_len-1 + if ( buf(i) <= array(j) ) then + array(k) = buf(i) + index(k) = ibuf(i) + i = i + 1 + if ( i >= mid ) exit merge_lower + else + array(k) = array(j) + index(k) = index(j) + j = j + 1 + if ( j >= array_len ) then + array(k+1:) = buf(i:mid-1) + index(k+1:) = ibuf(i:mid-1) + exit merge_lower + end if + end if + end do merge_lower + else ! The right run is shorter + buf(0:array_len-mid-1) = array(mid:array_len-1) + ibuf(0:array_len-mid-1) = index(mid:array_len-1) + i = mid - 1 + j = array_len - mid -1 + merge_upper: do k = array_len-1, 0, -1 + if ( buf(j) >= array(i) ) then + array(k) = buf(j) + index(k) = ibuf(j) + j = j - 1 + if ( j < 0 ) exit merge_upper + else + array(k) = array(i) + index(k) = index(i) + i = i - 1 + if ( i < 0 ) then + array(0:k-1) = buf(0:j) + index(0:k-1) = ibuf(0:j) + exit merge_upper + end if + end if + end do merge_upper + end if + end subroutine merge + + + pure subroutine reverse_segment( array, index ) +! Reverse a segment of an array in place + real(sp), intent(inout) :: array(0:) + integer(int_size), intent(inout) :: index(0:) + + integer(int_size) :: itemp, lo, hi + real(sp) :: temp + + lo = 0 + hi = size( array, kind=int_size ) - 1 + do while( lo < hi ) + temp = array(lo) + array(lo) = array(hi) + array(hi) = temp + itemp = index(lo) + index(lo) = index(hi) + index(hi) = itemp + lo = lo + 1 + hi = hi - 1 + end do + + end subroutine reverse_segment + + end subroutine sp_sort_index + + + module subroutine dp_sort_index( array, index, work, iwork, reverse ) +! A modification of `dp_ord_sort` to return an array of indices that +! would perform a stable sort of the `ARRAY` as input, and also sort `ARRAY` +! as desired. The indices by default +! correspond to a non-decreasing sort, but if the optional argument +! `REVERSE` is present with a value of `.TRUE.` the indices correspond to +! a non-increasing sort. The logic of the determination of indexing largely +! follows the `"Rust" sort` found in `slice.rs`: +! https://github.com/rust-lang/rust/blob/90eb44a5897c39e3dff9c7e48e3973671dcd9496/src/liballoc/slice.rs#L2159 +! The Rust version is a simplification of the Timsort algorithm described +! in https://svn.python.org/projects/python/trunk/Objects/listsort.txt, as +! it drops both the use of 'galloping' to identify bounds of regions to be +! sorted and the estimation of the optimal `run size`. However it remains +! a hybrid sorting algorithm combining an iterative Merge sort controlled +! by a stack of `RUNS` identified by regions of uniformly decreasing or +! non-decreasing sequences that may be expanded to a minimum run size, with +! an insertion sort. +! +! Note the Fortran implementation simplifies the logic as it only has to +! deal with Fortran arrays of intrinsic types and not the full generality +! of Rust's arrays and lists for arbitrary types. It also adds the +! estimation of the optimal `run size` as suggested in Tim Peters' +! original listsort.txt, and the optional `work` and `iwork` arraya to be +! used as scratch memory. + + real(dp), intent(inout) :: array(0:) + integer(int_size), intent(out) :: index(0:) + real(dp), intent(out), optional :: work(0:) + integer(int_size), intent(out), optional :: iwork(0:) + logical, intent(in), optional :: reverse + + integer(int_size) :: array_size, i, stat + real(dp), allocatable :: buf(:) + integer(int_size), allocatable :: ibuf(:) + + array_size = size(array, kind=int_size) + + do i = 0, array_size-1 + index(i) = i+1 + end do + + if ( present(reverse) ) then + if ( reverse ) then + call reverse_segment( array, index ) + end if + end if + +! If necessary allocate buffers to serve as scratch memory. + if ( present(work) ) then + if ( size(work, kind=int_size) < array_size/2 ) then + error stop "work array is too small." + end if + if ( present(iwork) ) then + if ( size(iwork, kind=int_size) < array_size/2 ) then + error stop "iwork array is too small." + endif + call merge_sort( array, index, work, iwork ) + else + allocate( ibuf(0:array_size/2-1), stat=stat ) + if ( stat /= 0 ) error stop "Allocation of index buffer failed." + call merge_sort( array, index, work, ibuf ) + end if + else + allocate( buf(0:array_size/2-1), stat=stat ) + if ( stat /= 0 ) error stop "Allocation of array buffer failed." + if ( present(iwork) ) then + if ( size(iwork, kind=int_size) < array_size/2 ) then + error stop "iwork array is too small." + endif + call merge_sort( array, index, buf, iwork ) + else + allocate( ibuf(0:array_size/2-1), stat=stat ) + if ( stat /= 0 ) error stop "Allocation of index buffer failed." + call merge_sort( array, index, buf, ibuf ) + end if + end if + + if ( present(reverse) ) then + if ( reverse ) then + call reverse_segment( array, index ) + end if + end if + + contains + + pure function calc_min_run( n ) result(min_run) +!! Returns the minimum length of a run from 32-63 so that N/MIN_RUN is +!! less than or equal to a power of two. See +!! https://svn.python.org/projects/python/trunk/Objects/listsort.txt + integer(int_size) :: min_run + integer(int_size), intent(in) :: n + + integer(int_size) :: num, r + + num = n + r = 0_int_size + + do while( num >= 64 ) + r = ior( r, iand(num, 1_int_size) ) + num = ishft(num, -1_int_size) + end do + min_run = num + r + + end function calc_min_run + + + pure subroutine insertion_sort( array, index ) +! Sorts `ARRAY` using an insertion sort, while maintaining consistency in +! location of the indices in `INDEX` to the elements of `ARRAY`. + real(dp), intent(inout) :: array(0:) + integer(int_size), intent(inout) :: index(0:) + + integer(int_size) :: i, j, key_index + real(dp) :: key + + do j=1, size(array, kind=int_size)-1 + key = array(j) + key_index = index(j) + i = j - 1 + do while( i >= 0 ) + if ( array(i) <= key ) exit + array(i+1) = array(i) + index(i+1) = index(i) + i = i - 1 + end do + array(i+1) = key + index(i+1) = key_index + end do + + end subroutine insertion_sort + + + pure function collapse( runs ) result ( r ) +! Examine the stack of runs waiting to be merged, identifying adjacent runs +! to be merged until the stack invariants are restablished: +! +! 1. len(-3) > len(-2) + len(-1) +! 2. len(-2) > len(-1) + + integer(int_size) :: r + type(run_type), intent(in), target :: runs(0:) + + integer(int_size) :: n + logical :: test + + n = size(runs, kind=int_size) + test = .false. + if (n >= 2) then + if ( runs( n-1 ) % base == 0 .or. & + runs( n-2 ) % len <= runs(n-1) % len ) then + test = .true. + else if ( n >= 3 ) then ! X exists + if ( runs(n-3) % len <= & + runs(n-2) % len + runs(n-1) % len ) then + test = .true. +! |X| <= |Y| + |Z| => will need to merge due to rho1 or rho2 + else if( n >= 4 ) then + if ( runs(n-4) % len <= & + runs(n-3) % len + runs(n-2) % len ) then + test = .true. +! |W| <= |X| + |Y| => will need to merge due to rho1 or rho3 + end if + end if + end if + end if + if ( test ) then +! By default merge Y & Z, rho2 or rho3 + if ( n >= 3 ) then + if ( runs(n-3) % len < runs(n-1) % len ) then + r = n - 3 +! |X| < |Z| => merge X & Y, rho1 + return + end if + end if + r = n - 2 +! |Y| <= |Z| => merge Y & Z, rho4 + return + else + r = -1 + end if + + end function collapse + + + pure subroutine insert_head( array, index ) +! Inserts `array(0)` into the pre-sorted sequence `array(1:)` so that the +! whole `array(0:)` becomes sorted, copying the first element into +! a temporary variable, iterating until the right place for it is found. +! copying every traversed element into the slot preceding it, and finally, +! copying data from the temporary variable into the resulting hole. +! Consistency of the indices in `index` with the elements of `array` +! are maintained. + + real(dp), intent(inout) :: array(0:) + integer(int_size), intent(inout) :: index(0:) + + real(dp) :: tmp + integer(int_size) :: i, tmp_index + + tmp = array(0) + tmp_index = index(0) + find_hole: do i=1, size(array, kind=int_size)-1 + if ( array(i) >= tmp ) exit find_hole + array(i-1) = array(i) + index(i-1) = index(i) + end do find_hole + array(i-1) = tmp + index(i-1) = tmp_index + + end subroutine insert_head + + + subroutine merge_sort( array, index, buf, ibuf ) +! The Rust merge sort borrows some (but not all) of the ideas from TimSort, +! which is described in detail at +! (http://svn.python.org/projects/python/trunk/Objects/listsort.txt). +! +! The algorithm identifies strictly descending and non-descending +! subsequences, which are called natural runs. Where these runs are less +! than a minimum run size they are padded by adding additional samples +! using an insertion sort. The merge process is driven by a stack of +! pending unmerged runs. Each newly found run is pushed onto the stack, +! and then pairs of adjacentd runs are merged until these two invariants +! are satisfied: +! +! 1. for every `i` in `1..size(runs)-1`: `runs(i - 1)%len > runs(i)%len` +! 2. for every `i` in `2..size(runs)-1`: `runs(i - 2)%len > +! runs(i - 1)%len + runs(i)%len` +! +! The invariants ensure that the total running time is `O(n log n)` +! worst-case. Consistency of the indices in `index` with the elements of +! `array` are maintained. + + real(dp), intent(inout) :: array(0:) + integer(int_size), intent(inout) :: index(0:) + real(dp), intent(inout) :: buf(0:) + integer(int_size), intent(inout) :: ibuf(0:) + + integer(int_size) :: array_size, finish, min_run, r, r_count, & + start + type(run_type) :: runs(0:max_merge_stack-1), left, right + + array_size = size(array, kind=int_size) + +! Very short runs are extended using insertion sort to span at least this +! many elements. Slices of up to this length are sorted using insertion sort. + min_run = calc_min_run( array_size ) + + if ( array_size <= min_run ) then + if ( array_size >= 2 ) call insertion_sort( array, index ) + return + end if + + +! Following Rust sort, natural runs in `array` are identified by traversing +! it backwards. By traversing it backward, merges more often go in the +! opposite direction (forwards). According to developers of Rust sort, +! merging forwards is slightly faster than merging backwards. Therefore +! identifying runs by traversing backwards should improve performance. + r_count = 0 + finish = array_size - 1 + do while ( finish >= 0 ) +! Find the next natural run, and reverse it if it's strictly descending. + start = finish + if ( start > 0 ) then + start = start - 1 + if ( array(start+1) < array(start) ) then + Descending: do while ( start > 0 ) + if ( array(start) >= array(start-1) ) & + exit Descending + start = start - 1 + end do Descending + call reverse_segment( array(start:finish), & + index(start:finish) ) + else + Ascending: do while( start > 0 ) + if ( array(start) < array(start-1) ) exit Ascending + start = start - 1 + end do Ascending + end if + end if + +! If the run is too short insert some more elements using an insertion sort. + Insert: do while ( start > 0 ) + if ( finish - start >= min_run - 1 ) exit Insert + start = start - 1 + call insert_head( array(start:finish), index(start:finish) ) + end do Insert + if ( start == 0 .and. finish == array_size - 1 ) return + + runs(r_count) = run_type( base = start, & + len = finish - start + 1 ) + finish = start-1 + r_count = r_count + 1 + +! Determine whether pairs of adjacent runs need to be merged to satisfy +! the invariants, and, if so, merge them. + Merge_loop: do + r = collapse( runs(0:r_count - 1) ) + if ( r < 0 .or. r_count <= 1 ) exit Merge_loop + left = runs( r + 1 ) + right = runs( r ) + call merge( array( left % base: & + right % base + right % len - 1 ), & + left % len, buf, & + index( left % base: & + right % base + right % len - 1 ), ibuf ) + + runs(r) = run_type( base = left % base, & + len = left % len + right % len ) + if ( r == r_count - 3 ) runs(r+1) = runs(r+2) + r_count = r_count - 1 + + end do Merge_loop + end do + if ( r_count /= 1 ) & + error stop "MERGE_SORT completed without RUN COUNT == 1." + + end subroutine merge_sort + + + pure subroutine merge( array, mid, buf, index, ibuf ) +! Merges the two non-decreasing runs `ARRAY(0:MID-1)` and `ARRAY(MID:)` +! using `BUF` as temporary storage, and stores the merged runs into +! `ARRAY(0:)`. `MID` must be > 0, and < `SIZE(ARRAY)-1`. Buffer `BUF` +! must be long enough to hold the shorter of the two runs. + real(dp), intent(inout) :: array(0:) + integer(int_size), intent(in) :: mid + real(dp), intent(inout) :: buf(0:) + integer(int_size), intent(inout) :: index(0:) + integer(int_size), intent(inout) :: ibuf(0:) + + integer(int_size) :: array_len, i, j, k + + array_len = size(array, kind=int_size) + +! Merge first copies the shorter run into `buf`. Then, depending on which +! run was shorter, it traces the copied run and the longer run forwards +! (or backwards), comparing their next unprocessed elements and then +! copying the lesser (or greater) one into `array`. + + if ( mid <= array_len - mid ) then ! The left run is shorter. + buf(0:mid-1) = array(0:mid-1) + ibuf(0:mid-1) = index(0:mid-1) + i = 0 + j = mid + merge_lower: do k = 0, array_len-1 + if ( buf(i) <= array(j) ) then + array(k) = buf(i) + index(k) = ibuf(i) + i = i + 1 + if ( i >= mid ) exit merge_lower + else + array(k) = array(j) + index(k) = index(j) + j = j + 1 + if ( j >= array_len ) then + array(k+1:) = buf(i:mid-1) + index(k+1:) = ibuf(i:mid-1) + exit merge_lower + end if + end if + end do merge_lower + else ! The right run is shorter + buf(0:array_len-mid-1) = array(mid:array_len-1) + ibuf(0:array_len-mid-1) = index(mid:array_len-1) + i = mid - 1 + j = array_len - mid -1 + merge_upper: do k = array_len-1, 0, -1 + if ( buf(j) >= array(i) ) then + array(k) = buf(j) + index(k) = ibuf(j) + j = j - 1 + if ( j < 0 ) exit merge_upper + else + array(k) = array(i) + index(k) = index(i) + i = i - 1 + if ( i < 0 ) then + array(0:k-1) = buf(0:j) + index(0:k-1) = ibuf(0:j) + exit merge_upper + end if + end if + end do merge_upper + end if + end subroutine merge + + + pure subroutine reverse_segment( array, index ) +! Reverse a segment of an array in place + real(dp), intent(inout) :: array(0:) + integer(int_size), intent(inout) :: index(0:) + + integer(int_size) :: itemp, lo, hi + real(dp) :: temp + + lo = 0 + hi = size( array, kind=int_size ) - 1 + do while( lo < hi ) + temp = array(lo) + array(lo) = array(hi) + array(hi) = temp + itemp = index(lo) + index(lo) = index(hi) + index(hi) = itemp + lo = lo + 1 + hi = hi - 1 + end do + + end subroutine reverse_segment + + end subroutine dp_sort_index + + + module subroutine qp_sort_index( array, index, work, iwork, reverse ) +! A modification of `qp_ord_sort` to return an array of indices that +! would perform a stable sort of the `ARRAY` as input, and also sort `ARRAY` +! as desired. The indices by default +! correspond to a non-decreasing sort, but if the optional argument +! `REVERSE` is present with a value of `.TRUE.` the indices correspond to +! a non-increasing sort. The logic of the determination of indexing largely +! follows the `"Rust" sort` found in `slice.rs`: +! https://github.com/rust-lang/rust/blob/90eb44a5897c39e3dff9c7e48e3973671dcd9496/src/liballoc/slice.rs#L2159 +! The Rust version is a simplification of the Timsort algorithm described +! in https://svn.python.org/projects/python/trunk/Objects/listsort.txt, as +! it drops both the use of 'galloping' to identify bounds of regions to be +! sorted and the estimation of the optimal `run size`. However it remains +! a hybrid sorting algorithm combining an iterative Merge sort controlled +! by a stack of `RUNS` identified by regions of uniformly decreasing or +! non-decreasing sequences that may be expanded to a minimum run size, with +! an insertion sort. +! +! Note the Fortran implementation simplifies the logic as it only has to +! deal with Fortran arrays of intrinsic types and not the full generality +! of Rust's arrays and lists for arbitrary types. It also adds the +! estimation of the optimal `run size` as suggested in Tim Peters' +! original listsort.txt, and the optional `work` and `iwork` arraya to be +! used as scratch memory. + + real(qp), intent(inout) :: array(0:) + integer(int_size), intent(out) :: index(0:) + real(qp), intent(out), optional :: work(0:) + integer(int_size), intent(out), optional :: iwork(0:) + logical, intent(in), optional :: reverse + + integer(int_size) :: array_size, i, stat + real(qp), allocatable :: buf(:) + integer(int_size), allocatable :: ibuf(:) + + array_size = size(array, kind=int_size) + + do i = 0, array_size-1 + index(i) = i+1 + end do + + if ( present(reverse) ) then + if ( reverse ) then + call reverse_segment( array, index ) + end if + end if + +! If necessary allocate buffers to serve as scratch memory. + if ( present(work) ) then + if ( size(work, kind=int_size) < array_size/2 ) then + error stop "work array is too small." + end if + if ( present(iwork) ) then + if ( size(iwork, kind=int_size) < array_size/2 ) then + error stop "iwork array is too small." + endif + call merge_sort( array, index, work, iwork ) + else + allocate( ibuf(0:array_size/2-1), stat=stat ) + if ( stat /= 0 ) error stop "Allocation of index buffer failed." + call merge_sort( array, index, work, ibuf ) + end if + else + allocate( buf(0:array_size/2-1), stat=stat ) + if ( stat /= 0 ) error stop "Allocation of array buffer failed." + if ( present(iwork) ) then + if ( size(iwork, kind=int_size) < array_size/2 ) then + error stop "iwork array is too small." + endif + call merge_sort( array, index, buf, iwork ) + else + allocate( ibuf(0:array_size/2-1), stat=stat ) + if ( stat /= 0 ) error stop "Allocation of index buffer failed." + call merge_sort( array, index, buf, ibuf ) + end if + end if + + if ( present(reverse) ) then + if ( reverse ) then + call reverse_segment( array, index ) + end if + end if + + contains + + pure function calc_min_run( n ) result(min_run) +!! Returns the minimum length of a run from 32-63 so that N/MIN_RUN is +!! less than or equal to a power of two. See +!! https://svn.python.org/projects/python/trunk/Objects/listsort.txt + integer(int_size) :: min_run + integer(int_size), intent(in) :: n + + integer(int_size) :: num, r + + num = n + r = 0_int_size + + do while( num >= 64 ) + r = ior( r, iand(num, 1_int_size) ) + num = ishft(num, -1_int_size) + end do + min_run = num + r + + end function calc_min_run + + + pure subroutine insertion_sort( array, index ) +! Sorts `ARRAY` using an insertion sort, while maintaining consistency in +! location of the indices in `INDEX` to the elements of `ARRAY`. + real(qp), intent(inout) :: array(0:) + integer(int_size), intent(inout) :: index(0:) + + integer(int_size) :: i, j, key_index + real(qp) :: key + + do j=1, size(array, kind=int_size)-1 + key = array(j) + key_index = index(j) + i = j - 1 + do while( i >= 0 ) + if ( array(i) <= key ) exit + array(i+1) = array(i) + index(i+1) = index(i) + i = i - 1 + end do + array(i+1) = key + index(i+1) = key_index + end do + + end subroutine insertion_sort + + + pure function collapse( runs ) result ( r ) +! Examine the stack of runs waiting to be merged, identifying adjacent runs +! to be merged until the stack invariants are restablished: +! +! 1. len(-3) > len(-2) + len(-1) +! 2. len(-2) > len(-1) + + integer(int_size) :: r + type(run_type), intent(in), target :: runs(0:) + + integer(int_size) :: n + logical :: test + + n = size(runs, kind=int_size) + test = .false. + if (n >= 2) then + if ( runs( n-1 ) % base == 0 .or. & + runs( n-2 ) % len <= runs(n-1) % len ) then + test = .true. + else if ( n >= 3 ) then ! X exists + if ( runs(n-3) % len <= & + runs(n-2) % len + runs(n-1) % len ) then + test = .true. +! |X| <= |Y| + |Z| => will need to merge due to rho1 or rho2 + else if( n >= 4 ) then + if ( runs(n-4) % len <= & + runs(n-3) % len + runs(n-2) % len ) then + test = .true. +! |W| <= |X| + |Y| => will need to merge due to rho1 or rho3 + end if + end if + end if + end if + if ( test ) then +! By default merge Y & Z, rho2 or rho3 + if ( n >= 3 ) then + if ( runs(n-3) % len < runs(n-1) % len ) then + r = n - 3 +! |X| < |Z| => merge X & Y, rho1 + return + end if + end if + r = n - 2 +! |Y| <= |Z| => merge Y & Z, rho4 + return + else + r = -1 + end if + + end function collapse + + + pure subroutine insert_head( array, index ) +! Inserts `array(0)` into the pre-sorted sequence `array(1:)` so that the +! whole `array(0:)` becomes sorted, copying the first element into +! a temporary variable, iterating until the right place for it is found. +! copying every traversed element into the slot preceding it, and finally, +! copying data from the temporary variable into the resulting hole. +! Consistency of the indices in `index` with the elements of `array` +! are maintained. + + real(qp), intent(inout) :: array(0:) + integer(int_size), intent(inout) :: index(0:) + + real(qp) :: tmp + integer(int_size) :: i, tmp_index + + tmp = array(0) + tmp_index = index(0) + find_hole: do i=1, size(array, kind=int_size)-1 + if ( array(i) >= tmp ) exit find_hole + array(i-1) = array(i) + index(i-1) = index(i) + end do find_hole + array(i-1) = tmp + index(i-1) = tmp_index + + end subroutine insert_head + + + subroutine merge_sort( array, index, buf, ibuf ) +! The Rust merge sort borrows some (but not all) of the ideas from TimSort, +! which is described in detail at +! (http://svn.python.org/projects/python/trunk/Objects/listsort.txt). +! +! The algorithm identifies strictly descending and non-descending +! subsequences, which are called natural runs. Where these runs are less +! than a minimum run size they are padded by adding additional samples +! using an insertion sort. The merge process is driven by a stack of +! pending unmerged runs. Each newly found run is pushed onto the stack, +! and then pairs of adjacentd runs are merged until these two invariants +! are satisfied: +! +! 1. for every `i` in `1..size(runs)-1`: `runs(i - 1)%len > runs(i)%len` +! 2. for every `i` in `2..size(runs)-1`: `runs(i - 2)%len > +! runs(i - 1)%len + runs(i)%len` +! +! The invariants ensure that the total running time is `O(n log n)` +! worst-case. Consistency of the indices in `index` with the elements of +! `array` are maintained. + + real(qp), intent(inout) :: array(0:) + integer(int_size), intent(inout) :: index(0:) + real(qp), intent(inout) :: buf(0:) + integer(int_size), intent(inout) :: ibuf(0:) + + integer(int_size) :: array_size, finish, min_run, r, r_count, & + start + type(run_type) :: runs(0:max_merge_stack-1), left, right + + array_size = size(array, kind=int_size) + +! Very short runs are extended using insertion sort to span at least this +! many elements. Slices of up to this length are sorted using insertion sort. + min_run = calc_min_run( array_size ) + + if ( array_size <= min_run ) then + if ( array_size >= 2 ) call insertion_sort( array, index ) + return + end if + + +! Following Rust sort, natural runs in `array` are identified by traversing +! it backwards. By traversing it backward, merges more often go in the +! opposite direction (forwards). According to developers of Rust sort, +! merging forwards is slightly faster than merging backwards. Therefore +! identifying runs by traversing backwards should improve performance. + r_count = 0 + finish = array_size - 1 + do while ( finish >= 0 ) +! Find the next natural run, and reverse it if it's strictly descending. + start = finish + if ( start > 0 ) then + start = start - 1 + if ( array(start+1) < array(start) ) then + Descending: do while ( start > 0 ) + if ( array(start) >= array(start-1) ) & + exit Descending + start = start - 1 + end do Descending + call reverse_segment( array(start:finish), & + index(start:finish) ) + else + Ascending: do while( start > 0 ) + if ( array(start) < array(start-1) ) exit Ascending + start = start - 1 + end do Ascending + end if + end if + +! If the run is too short insert some more elements using an insertion sort. + Insert: do while ( start > 0 ) + if ( finish - start >= min_run - 1 ) exit Insert + start = start - 1 + call insert_head( array(start:finish), index(start:finish) ) + end do Insert + if ( start == 0 .and. finish == array_size - 1 ) return + + runs(r_count) = run_type( base = start, & + len = finish - start + 1 ) + finish = start-1 + r_count = r_count + 1 + +! Determine whether pairs of adjacent runs need to be merged to satisfy +! the invariants, and, if so, merge them. + Merge_loop: do + r = collapse( runs(0:r_count - 1) ) + if ( r < 0 .or. r_count <= 1 ) exit Merge_loop + left = runs( r + 1 ) + right = runs( r ) + call merge( array( left % base: & + right % base + right % len - 1 ), & + left % len, buf, & + index( left % base: & + right % base + right % len - 1 ), ibuf ) + + runs(r) = run_type( base = left % base, & + len = left % len + right % len ) + if ( r == r_count - 3 ) runs(r+1) = runs(r+2) + r_count = r_count - 1 + + end do Merge_loop + end do + if ( r_count /= 1 ) & + error stop "MERGE_SORT completed without RUN COUNT == 1." + + end subroutine merge_sort + + + pure subroutine merge( array, mid, buf, index, ibuf ) +! Merges the two non-decreasing runs `ARRAY(0:MID-1)` and `ARRAY(MID:)` +! using `BUF` as temporary storage, and stores the merged runs into +! `ARRAY(0:)`. `MID` must be > 0, and < `SIZE(ARRAY)-1`. Buffer `BUF` +! must be long enough to hold the shorter of the two runs. + real(qp), intent(inout) :: array(0:) + integer(int_size), intent(in) :: mid + real(qp), intent(inout) :: buf(0:) + integer(int_size), intent(inout) :: index(0:) + integer(int_size), intent(inout) :: ibuf(0:) + + integer(int_size) :: array_len, i, j, k + + array_len = size(array, kind=int_size) + +! Merge first copies the shorter run into `buf`. Then, depending on which +! run was shorter, it traces the copied run and the longer run forwards +! (or backwards), comparing their next unprocessed elements and then +! copying the lesser (or greater) one into `array`. + + if ( mid <= array_len - mid ) then ! The left run is shorter. + buf(0:mid-1) = array(0:mid-1) + ibuf(0:mid-1) = index(0:mid-1) + i = 0 + j = mid + merge_lower: do k = 0, array_len-1 + if ( buf(i) <= array(j) ) then + array(k) = buf(i) + index(k) = ibuf(i) + i = i + 1 + if ( i >= mid ) exit merge_lower + else + array(k) = array(j) + index(k) = index(j) + j = j + 1 + if ( j >= array_len ) then + array(k+1:) = buf(i:mid-1) + index(k+1:) = ibuf(i:mid-1) + exit merge_lower + end if + end if + end do merge_lower + else ! The right run is shorter + buf(0:array_len-mid-1) = array(mid:array_len-1) + ibuf(0:array_len-mid-1) = index(mid:array_len-1) + i = mid - 1 + j = array_len - mid -1 + merge_upper: do k = array_len-1, 0, -1 + if ( buf(j) >= array(i) ) then + array(k) = buf(j) + index(k) = ibuf(j) + j = j - 1 + if ( j < 0 ) exit merge_upper + else + array(k) = array(i) + index(k) = index(i) + i = i - 1 + if ( i < 0 ) then + array(0:k-1) = buf(0:j) + index(0:k-1) = ibuf(0:j) + exit merge_upper + end if + end if + end do merge_upper + end if + end subroutine merge + + + pure subroutine reverse_segment( array, index ) +! Reverse a segment of an array in place + real(qp), intent(inout) :: array(0:) + integer(int_size), intent(inout) :: index(0:) + + integer(int_size) :: itemp, lo, hi + real(qp) :: temp + + lo = 0 + hi = size( array, kind=int_size ) - 1 + do while( lo < hi ) + temp = array(lo) + array(lo) = array(hi) + array(hi) = temp + itemp = index(lo) + index(lo) = index(hi) + index(hi) = itemp + lo = lo + 1 + hi = hi - 1 + end do + + end subroutine reverse_segment + + end subroutine qp_sort_index + + + module subroutine string_type_sort_index( array, index, work, iwork, reverse ) +! A modification of `string_type_ord_sort` to return an array of indices that +! would perform a stable sort of the `ARRAY` as input, and also sort `ARRAY` +! as desired. The indices by default +! correspond to a non-decreasing sort, but if the optional argument +! `REVERSE` is present with a value of `.TRUE.` the indices correspond to +! a non-increasing sort. The logic of the determination of indexing largely +! follows the `"Rust" sort` found in `slice.rs`: +! https://github.com/rust-lang/rust/blob/90eb44a5897c39e3dff9c7e48e3973671dcd9496/src/liballoc/slice.rs#L2159 +! The Rust version is a simplification of the Timsort algorithm described +! in https://svn.python.org/projects/python/trunk/Objects/listsort.txt, as +! it drops both the use of 'galloping' to identify bounds of regions to be +! sorted and the estimation of the optimal `run size`. However it remains +! a hybrid sorting algorithm combining an iterative Merge sort controlled +! by a stack of `RUNS` identified by regions of uniformly decreasing or +! non-decreasing sequences that may be expanded to a minimum run size, with +! an insertion sort. +! +! Note the Fortran implementation simplifies the logic as it only has to +! deal with Fortran arrays of intrinsic types and not the full generality +! of Rust's arrays and lists for arbitrary types. It also adds the +! estimation of the optimal `run size` as suggested in Tim Peters' +! original listsort.txt, and the optional `work` and `iwork` arraya to be +! used as scratch memory. + + type(string_type), intent(inout) :: array(0:) + integer(int_size), intent(out) :: index(0:) + type(string_type), intent(out), optional :: work(0:) + integer(int_size), intent(out), optional :: iwork(0:) + logical, intent(in), optional :: reverse + + integer(int_size) :: array_size, i, stat + type(string_type), allocatable :: buf(:) + integer(int_size), allocatable :: ibuf(:) + + array_size = size(array, kind=int_size) + + do i = 0, array_size-1 + index(i) = i+1 + end do + + if ( present(reverse) ) then + if ( reverse ) then + call reverse_segment( array, index ) + end if + end if + +! If necessary allocate buffers to serve as scratch memory. + if ( present(work) ) then + if ( size(work, kind=int_size) < array_size/2 ) then + error stop "work array is too small." + end if + if ( present(iwork) ) then + if ( size(iwork, kind=int_size) < array_size/2 ) then + error stop "iwork array is too small." + endif + call merge_sort( array, index, work, iwork ) + else + allocate( ibuf(0:array_size/2-1), stat=stat ) + if ( stat /= 0 ) error stop "Allocation of index buffer failed." + call merge_sort( array, index, work, ibuf ) + end if + else + allocate( buf(0:array_size/2-1), stat=stat ) + if ( stat /= 0 ) error stop "Allocation of array buffer failed." + if ( present(iwork) ) then + if ( size(iwork, kind=int_size) < array_size/2 ) then + error stop "iwork array is too small." + endif + call merge_sort( array, index, buf, iwork ) + else + allocate( ibuf(0:array_size/2-1), stat=stat ) + if ( stat /= 0 ) error stop "Allocation of index buffer failed." + call merge_sort( array, index, buf, ibuf ) + end if + end if + + if ( present(reverse) ) then + if ( reverse ) then + call reverse_segment( array, index ) + end if + end if + + contains + + pure function calc_min_run( n ) result(min_run) +!! Returns the minimum length of a run from 32-63 so that N/MIN_RUN is +!! less than or equal to a power of two. See +!! https://svn.python.org/projects/python/trunk/Objects/listsort.txt + integer(int_size) :: min_run + integer(int_size), intent(in) :: n + + integer(int_size) :: num, r + + num = n + r = 0_int_size + + do while( num >= 64 ) + r = ior( r, iand(num, 1_int_size) ) + num = ishft(num, -1_int_size) + end do + min_run = num + r + + end function calc_min_run + + + pure subroutine insertion_sort( array, index ) +! Sorts `ARRAY` using an insertion sort, while maintaining consistency in +! location of the indices in `INDEX` to the elements of `ARRAY`. + type(string_type), intent(inout) :: array(0:) + integer(int_size), intent(inout) :: index(0:) + + integer(int_size) :: i, j, key_index + type(string_type) :: key + + do j=1, size(array, kind=int_size)-1 + key = array(j) + key_index = index(j) + i = j - 1 + do while( i >= 0 ) + if ( array(i) <= key ) exit + array(i+1) = array(i) + index(i+1) = index(i) + i = i - 1 + end do + array(i+1) = key + index(i+1) = key_index + end do + + end subroutine insertion_sort + + + pure function collapse( runs ) result ( r ) +! Examine the stack of runs waiting to be merged, identifying adjacent runs +! to be merged until the stack invariants are restablished: +! +! 1. len(-3) > len(-2) + len(-1) +! 2. len(-2) > len(-1) + + integer(int_size) :: r + type(run_type), intent(in), target :: runs(0:) + + integer(int_size) :: n + logical :: test + + n = size(runs, kind=int_size) + test = .false. + if (n >= 2) then + if ( runs( n-1 ) % base == 0 .or. & + runs( n-2 ) % len <= runs(n-1) % len ) then + test = .true. + else if ( n >= 3 ) then ! X exists + if ( runs(n-3) % len <= & + runs(n-2) % len + runs(n-1) % len ) then + test = .true. +! |X| <= |Y| + |Z| => will need to merge due to rho1 or rho2 + else if( n >= 4 ) then + if ( runs(n-4) % len <= & + runs(n-3) % len + runs(n-2) % len ) then + test = .true. +! |W| <= |X| + |Y| => will need to merge due to rho1 or rho3 + end if + end if + end if + end if + if ( test ) then +! By default merge Y & Z, rho2 or rho3 + if ( n >= 3 ) then + if ( runs(n-3) % len < runs(n-1) % len ) then + r = n - 3 +! |X| < |Z| => merge X & Y, rho1 + return + end if + end if + r = n - 2 +! |Y| <= |Z| => merge Y & Z, rho4 + return + else + r = -1 + end if + + end function collapse + + + pure subroutine insert_head( array, index ) +! Inserts `array(0)` into the pre-sorted sequence `array(1:)` so that the +! whole `array(0:)` becomes sorted, copying the first element into +! a temporary variable, iterating until the right place for it is found. +! copying every traversed element into the slot preceding it, and finally, +! copying data from the temporary variable into the resulting hole. +! Consistency of the indices in `index` with the elements of `array` +! are maintained. + + type(string_type), intent(inout) :: array(0:) + integer(int_size), intent(inout) :: index(0:) + + type(string_type) :: tmp + integer(int_size) :: i, tmp_index + + tmp = array(0) + tmp_index = index(0) + find_hole: do i=1, size(array, kind=int_size)-1 + if ( array(i) >= tmp ) exit find_hole + array(i-1) = array(i) + index(i-1) = index(i) + end do find_hole + array(i-1) = tmp + index(i-1) = tmp_index + + end subroutine insert_head + + + subroutine merge_sort( array, index, buf, ibuf ) +! The Rust merge sort borrows some (but not all) of the ideas from TimSort, +! which is described in detail at +! (http://svn.python.org/projects/python/trunk/Objects/listsort.txt). +! +! The algorithm identifies strictly descending and non-descending +! subsequences, which are called natural runs. Where these runs are less +! than a minimum run size they are padded by adding additional samples +! using an insertion sort. The merge process is driven by a stack of +! pending unmerged runs. Each newly found run is pushed onto the stack, +! and then pairs of adjacentd runs are merged until these two invariants +! are satisfied: +! +! 1. for every `i` in `1..size(runs)-1`: `runs(i - 1)%len > runs(i)%len` +! 2. for every `i` in `2..size(runs)-1`: `runs(i - 2)%len > +! runs(i - 1)%len + runs(i)%len` +! +! The invariants ensure that the total running time is `O(n log n)` +! worst-case. Consistency of the indices in `index` with the elements of +! `array` are maintained. + + type(string_type), intent(inout) :: array(0:) + integer(int_size), intent(inout) :: index(0:) + type(string_type), intent(inout) :: buf(0:) + integer(int_size), intent(inout) :: ibuf(0:) + + integer(int_size) :: array_size, finish, min_run, r, r_count, & + start + type(run_type) :: runs(0:max_merge_stack-1), left, right + + array_size = size(array, kind=int_size) + +! Very short runs are extended using insertion sort to span at least this +! many elements. Slices of up to this length are sorted using insertion sort. + min_run = calc_min_run( array_size ) + + if ( array_size <= min_run ) then + if ( array_size >= 2 ) call insertion_sort( array, index ) + return + end if + + +! Following Rust sort, natural runs in `array` are identified by traversing +! it backwards. By traversing it backward, merges more often go in the +! opposite direction (forwards). According to developers of Rust sort, +! merging forwards is slightly faster than merging backwards. Therefore +! identifying runs by traversing backwards should improve performance. + r_count = 0 + finish = array_size - 1 + do while ( finish >= 0 ) +! Find the next natural run, and reverse it if it's strictly descending. + start = finish + if ( start > 0 ) then + start = start - 1 + if ( array(start+1) < array(start) ) then + Descending: do while ( start > 0 ) + if ( array(start) >= array(start-1) ) & + exit Descending + start = start - 1 + end do Descending + call reverse_segment( array(start:finish), & + index(start:finish) ) + else + Ascending: do while( start > 0 ) + if ( array(start) < array(start-1) ) exit Ascending + start = start - 1 + end do Ascending + end if + end if + +! If the run is too short insert some more elements using an insertion sort. + Insert: do while ( start > 0 ) + if ( finish - start >= min_run - 1 ) exit Insert + start = start - 1 + call insert_head( array(start:finish), index(start:finish) ) + end do Insert + if ( start == 0 .and. finish == array_size - 1 ) return + + runs(r_count) = run_type( base = start, & + len = finish - start + 1 ) + finish = start-1 + r_count = r_count + 1 + +! Determine whether pairs of adjacent runs need to be merged to satisfy +! the invariants, and, if so, merge them. + Merge_loop: do + r = collapse( runs(0:r_count - 1) ) + if ( r < 0 .or. r_count <= 1 ) exit Merge_loop + left = runs( r + 1 ) + right = runs( r ) + call merge( array( left % base: & + right % base + right % len - 1 ), & + left % len, buf, & + index( left % base: & + right % base + right % len - 1 ), ibuf ) + + runs(r) = run_type( base = left % base, & + len = left % len + right % len ) + if ( r == r_count - 3 ) runs(r+1) = runs(r+2) + r_count = r_count - 1 + + end do Merge_loop + end do + if ( r_count /= 1 ) & + error stop "MERGE_SORT completed without RUN COUNT == 1." + + end subroutine merge_sort + + + pure subroutine merge( array, mid, buf, index, ibuf ) +! Merges the two non-decreasing runs `ARRAY(0:MID-1)` and `ARRAY(MID:)` +! using `BUF` as temporary storage, and stores the merged runs into +! `ARRAY(0:)`. `MID` must be > 0, and < `SIZE(ARRAY)-1`. Buffer `BUF` +! must be long enough to hold the shorter of the two runs. + type(string_type), intent(inout) :: array(0:) + integer(int_size), intent(in) :: mid + type(string_type), intent(inout) :: buf(0:) + integer(int_size), intent(inout) :: index(0:) + integer(int_size), intent(inout) :: ibuf(0:) + + integer(int_size) :: array_len, i, j, k + + array_len = size(array, kind=int_size) + +! Merge first copies the shorter run into `buf`. Then, depending on which +! run was shorter, it traces the copied run and the longer run forwards +! (or backwards), comparing their next unprocessed elements and then +! copying the lesser (or greater) one into `array`. + + if ( mid <= array_len - mid ) then ! The left run is shorter. + buf(0:mid-1) = array(0:mid-1) + ibuf(0:mid-1) = index(0:mid-1) + i = 0 + j = mid + merge_lower: do k = 0, array_len-1 + if ( buf(i) <= array(j) ) then + array(k) = buf(i) + index(k) = ibuf(i) + i = i + 1 + if ( i >= mid ) exit merge_lower + else + array(k) = array(j) + index(k) = index(j) + j = j + 1 + if ( j >= array_len ) then + array(k+1:) = buf(i:mid-1) + index(k+1:) = ibuf(i:mid-1) + exit merge_lower + end if + end if + end do merge_lower + else ! The right run is shorter + buf(0:array_len-mid-1) = array(mid:array_len-1) + ibuf(0:array_len-mid-1) = index(mid:array_len-1) + i = mid - 1 + j = array_len - mid -1 + merge_upper: do k = array_len-1, 0, -1 + if ( buf(j) >= array(i) ) then + array(k) = buf(j) + index(k) = ibuf(j) + j = j - 1 + if ( j < 0 ) exit merge_upper + else + array(k) = array(i) + index(k) = index(i) + i = i - 1 + if ( i < 0 ) then + array(0:k-1) = buf(0:j) + index(0:k-1) = ibuf(0:j) + exit merge_upper + end if + end if + end do merge_upper + end if + end subroutine merge + + + pure subroutine reverse_segment( array, index ) +! Reverse a segment of an array in place + type(string_type), intent(inout) :: array(0:) + integer(int_size), intent(inout) :: index(0:) + + integer(int_size) :: itemp, lo, hi + type(string_type) :: temp + + lo = 0 + hi = size( array, kind=int_size ) - 1 + do while( lo < hi ) + temp = array(lo) + array(lo) = array(hi) + array(hi) = temp + itemp = index(lo) + index(lo) = index(hi) + index(hi) = itemp + lo = lo + 1 + hi = hi - 1 + end do + + end subroutine reverse_segment + + end subroutine string_type_sort_index + + + + module subroutine char_sort_index( array, index, work, iwork, reverse ) +! A modification of `char_ord_sort` to return an array of indices that +! would perform a stable sort of the `ARRAY` as input, and also sort `ARRAY` +! as desired. The indices by default +! correspond to a non-decreasing sort, but if the optional argument +! `REVERSE` is present with a value of `.TRUE.` the indices correspond to +! a non-increasing sort. The logic of the determination of indexing largely +! follows the `"Rust" sort` found in `slice.rs`: +! https://github.com/rust-lang/rust/blob/90eb44a5897c39e3dff9c7e48e3973671dcd9496/src/liballoc/slice.rs#L2159 +! The Rust version is a simplification of the Timsort algorithm described +! in https://svn.python.org/projects/python/trunk/Objects/listsort.txt, as +! it drops both the use of 'galloping' to identify bounds of regions to be +! sorted and the estimation of the optimal `run size`. However it remains +! a hybrid sorting algorithm combining an iterative Merge sort controlled +! by a stack of `RUNS` identified by regions of uniformly decreasing or +! non-decreasing sequences that may be expanded to a minimum run size, with +! an insertion sort. +! +! Note the Fortran implementation simplifies the logic as it only has to +! deal with Fortran arrays of intrinsic types and not the full generality +! of Rust's arrays and lists for arbitrary types. It also adds the +! estimation of the optimal `run size` as suggested in Tim Peters' +! original listsort.txt, and the optional `work` and `iwork` arraya to be +! used as scratch memory. + + character(len=*), intent(inout) :: array(0:) + integer(int_size), intent(out) :: index(0:) + character(len=len(array)), intent(out), optional :: work(0:) + integer(int_size), intent(out), optional :: iwork(0:) + logical, intent(in), optional :: reverse + + integer(int_size) :: array_size, i, stat + character(len=:), allocatable :: buf(:) + integer(int_size), allocatable :: ibuf(:) + + array_size = size(array, kind=int_size) + + do i = 0, array_size-1 + index(i) = i+1 + end do + + if ( present(reverse) ) then + if ( reverse ) then + call reverse_segment( array, index ) + end if + end if + +! If necessary allocate buffers to serve as scratch memory. + if ( present(work) ) then + if ( present(iwork) ) then + call merge_sort( array, index, work, iwork ) + else + allocate( ibuf(0:array_size/2-1), stat=stat ) + if ( stat /= 0 ) error stop "Allocation of index buffer failed." + call merge_sort( array, index, work, ibuf ) + end if + else + allocate( character(len=len(array)) :: buf(0:array_size/2-1), & + stat=stat ) + if ( stat /= 0 ) error stop "Allocation of array buffer failed." + if ( present(iwork) ) then + call merge_sort( array, index, buf, iwork ) + else + allocate( ibuf(0:array_size/2-1), stat=stat ) + if ( stat /= 0 ) error stop "Allocation of index buffer failed." + call merge_sort( array, index, buf, ibuf ) + end if + end if + + if ( present(reverse) ) then + if ( reverse ) then + call reverse_segment( array, index ) + end if + end if + + contains + + pure function calc_min_run( n ) result(min_run) +!! Returns the minimum length of a run from 32-63 so that N/MIN_RUN is +!! less than or equal to a power of two. See +!! https://svn.python.org/projects/python/trunk/Objects/listsort.txt + integer(int_size) :: min_run + integer(int_size), intent(in) :: n + + integer(int_size) :: num, r + + num = n + r = 0_int_size + + do while( num >= 64 ) + r = ior( r, iand(num, 1_int_size) ) + num = ishft(num, -1_int_size) + end do + min_run = num + r + + end function calc_min_run + + + pure subroutine insertion_sort( array, index ) +! Sorts `ARRAY` using an insertion sort, while maintaining consistency in +! location of the indices in `INDEX` to the elements of `ARRAY`. + character(len=*), intent(inout) :: array(0:) + integer(int_size), intent(inout) :: index(0:) + + integer(int_size) :: i, j, key_index + character(len=len(array)) :: key + + do j=1, size(array, kind=int_size)-1 + key = array(j) + key_index = index(j) + i = j - 1 + do while( i >= 0 ) + if ( array(i) <= key ) exit + array(i+1) = array(i) + index(i+1) = index(i) + i = i - 1 + end do + array(i+1) = key + index(i+1) = key_index + end do + + end subroutine insertion_sort + + + pure function collapse( runs ) result ( r ) +! Examine the stack of runs waiting to be merged, identifying adjacent runs +! to be merged until the stack invariants are restablished: +! +! 1. len(-3) > len(-2) + len(-1) +! 2. len(-2) > len(-1) + + integer(int_size) :: r + type(run_type), intent(in), target :: runs(0:) + + integer(int_size) :: n + logical :: test + + n = size(runs, kind=int_size) + test = .false. + if (n >= 2) then + if ( runs( n-1 ) % base == 0 .or. & + runs( n-2 ) % len <= runs(n-1) % len ) then + test = .true. + else if ( n >= 3 ) then ! X exists + if ( runs(n-3) % len <= & + runs(n-2) % len + runs(n-1) % len ) then + test = .true. +! |X| <= |Y| + |Z| => will need to merge due to rho1 or rho2 + else if( n >= 4 ) then + if ( runs(n-4) % len <= & + runs(n-3) % len + runs(n-2) % len ) then + test = .true. +! |W| <= |X| + |Y| => will need to merge due to rho1 or rho3 + end if + end if + end if + end if + if ( test ) then +! By default merge Y & Z, rho2 or rho3 + if ( n >= 3 ) then + if ( runs(n-3) % len < runs(n-1) % len ) then + r = n - 3 +! |X| < |Z| => merge X & Y, rho1 + return + end if + end if + r = n - 2 +! |Y| <= |Z| => merge Y & Z, rho4 + return + else + r = -1 + end if + + end function collapse + + + pure subroutine insert_head( array, index ) +! Inserts `array(0)` into the pre-sorted sequence `array(1:)` so that the +! whole `array(0:)` becomes sorted, copying the first element into +! a temporary variable, iterating until the right place for it is found. +! copying every traversed element into the slot preceding it, and finally, +! copying data from the temporary variable into the resulting hole. +! Consistency of the indices in `index` with the elements of `array` +! are maintained. + + character(len=*), intent(inout) :: array(0:) + integer(int_size), intent(inout) :: index(0:) + + character(len=len(array)) :: tmp + integer(int_size) :: i, tmp_index + + tmp = array(0) + tmp_index = index(0) + find_hole: do i=1, size(array, kind=int_size)-1 + if ( array(i) >= tmp ) exit find_hole + array(i-1) = array(i) + index(i-1) = index(i) + end do find_hole + array(i-1) = tmp + index(i-1) = tmp_index + + end subroutine insert_head + + + subroutine merge_sort( array, index, buf, ibuf ) +! The Rust merge sort borrows some (but not all) of the ideas from TimSort, +! which is described in detail at +! (http://svn.python.org/projects/python/trunk/Objects/listsort.txt). +! +! The algorithm identifies strictly descending and non-descending +! subsequences, which are called natural runs. Where these runs are less +! than a minimum run size they are padded by adding additional samples +! using an insertion sort. The merge process is driven by a stack of +! pending unmerged runs. Each newly found run is pushed onto the stack, +! and then pairs of adjacentd runs are merged until these two invariants +! are satisfied: +! +! 1. for every `i` in `1..size(runs)-1`: `runs(i - 1)%len > runs(i)%len` +! 2. for every `i` in `2..size(runs)-1`: `runs(i - 2)%len > +! runs(i - 1)%len + runs(i)%len` +! +! The invariants ensure that the total running time is `O(n log n)` +! worst-case. Consistency of the indices in `index` with the elements of +! `array` are maintained. + + character(len=*), intent(inout) :: array(0:) + integer(int_size), intent(inout) :: index(0:) + character(len=len(array)), intent(inout) :: buf(0:) + integer(int_size), intent(inout) :: ibuf(0:) + + integer(int_size) :: array_size, finish, min_run, r, r_count, & + start + type(run_type) :: runs(0:max_merge_stack-1), left, right + + array_size = size(array, kind=int_size) + +! Very short runs are extended using insertion sort to span at least this +! many elements. Slices of up to this length are sorted using insertion sort. + min_run = calc_min_run( array_size ) + + if ( array_size <= min_run ) then + if ( array_size >= 2 ) call insertion_sort( array, index ) + return + end if + + +! Following Rust sort, natural runs in `array` are identified by traversing +! it backwards. By traversing it backward, merges more often go in the +! opposite direction (forwards). According to developers of Rust sort, +! merging forwards is slightly faster than merging backwards. Therefore +! identifying runs by traversing backwards should improve performance. + r_count = 0 + finish = array_size - 1 + do while ( finish >= 0 ) +! Find the next natural run, and reverse it if it's strictly descending. + start = finish + if ( start > 0 ) then + start = start - 1 + if ( array(start+1) < array(start) ) then + Descending: do while ( start > 0 ) + if ( array(start) >= array(start-1) ) & + exit Descending + start = start - 1 + end do Descending + call reverse_segment( array(start:finish), & + index(start:finish) ) + else + Ascending: do while( start > 0 ) + if ( array(start) < array(start-1) ) exit Ascending + start = start - 1 + end do Ascending + end if + end if + +! If the run is too short insert some more elements using an insertion sort. + Insert: do while ( start > 0 ) + if ( finish - start >= min_run - 1 ) exit Insert + start = start - 1 + call insert_head( array(start:finish), index(start:finish) ) + end do Insert + if ( start == 0 .and. finish == array_size - 1 ) return + + runs(r_count) = run_type( base = start, & + len = finish - start + 1 ) + finish = start-1 + r_count = r_count + 1 + +! Determine whether pairs of adjacent runs need to be merged to satisfy +! the invariants, and, if so, merge them. + Merge_loop: do + r = collapse( runs(0:r_count - 1) ) + if ( r < 0 .or. r_count <= 1 ) exit Merge_loop + left = runs( r + 1 ) + right = runs( r ) + call merge( array( left % base: & + right % base + right % len - 1 ), & + left % len, buf, & + index( left % base: & + right % base + right % len - 1 ), ibuf ) + + runs(r) = run_type( base = left % base, & + len = left % len + right % len ) + if ( r == r_count - 3 ) runs(r+1) = runs(r+2) + r_count = r_count - 1 + + end do Merge_loop + end do + if ( r_count /= 1 ) & + error stop "MERGE_SORT completed without RUN COUNT == 1." + + end subroutine merge_sort + + + pure subroutine merge( array, mid, buf, index, ibuf ) +! Merges the two non-decreasing runs `ARRAY(0:MID-1)` and `ARRAY(MID:)` +! using `BUF` as temporary storage, and stores the merged runs into +! `ARRAY(0:)`. `MID` must be > 0, and < `SIZE(ARRAY)-1`. Buffer `BUF` +! must be long enough to hold the shorter of the two runs. + character(len=*), intent(inout) :: array(0:) + integer(int_size), intent(in) :: mid + character(len=len(array)), intent(inout) :: buf(0:) + integer(int_size), intent(inout) :: index(0:) + integer(int_size), intent(inout) :: ibuf(0:) + + integer(int_size) :: array_len, i, j, k + + array_len = size(array, kind=int_size) + +! Merge first copies the shorter run into `buf`. Then, depending on which +! run was shorter, it traces the copied run and the longer run forwards +! (or backwards), comparing their next unprocessed elements and then +! copying the lesser (or greater) one into `array`. + + if ( mid <= array_len - mid ) then ! The left run is shorter. + buf(0:mid-1) = array(0:mid-1) + ibuf(0:mid-1) = index(0:mid-1) + i = 0 + j = mid + merge_lower: do k = 0, array_len-1 + if ( buf(i) <= array(j) ) then + array(k) = buf(i) + index(k) = ibuf(i) + i = i + 1 + if ( i >= mid ) exit merge_lower + else + array(k) = array(j) + index(k) = index(j) + j = j + 1 + if ( j >= array_len ) then + array(k+1:) = buf(i:mid-1) + index(k+1:) = ibuf(i:mid-1) + exit merge_lower + end if + end if + end do merge_lower + else ! The right run is shorter + buf(0:array_len-mid-1) = array(mid:array_len-1) + ibuf(0:array_len-mid-1) = index(mid:array_len-1) + i = mid - 1 + j = array_len - mid -1 + merge_upper: do k = array_len-1, 0, -1 + if ( buf(j) >= array(i) ) then + array(k) = buf(j) + index(k) = ibuf(j) + j = j - 1 + if ( j < 0 ) exit merge_upper + else + array(k) = array(i) + index(k) = index(i) + i = i - 1 + if ( i < 0 ) then + array(0:k-1) = buf(0:j) + index(0:k-1) = ibuf(0:j) + exit merge_upper + end if + end if + end do merge_upper + end if + end subroutine merge + + + pure subroutine reverse_segment( array, index ) +! Reverse a segment of an array in place + character(len=*), intent(inout) :: array(0:) + integer(int_size), intent(inout) :: index(0:) + + integer(int_size) :: itemp, lo, hi + character(len=len(array)) :: temp + + lo = 0 + hi = size( array, kind=int_size ) - 1 + do while( lo < hi ) + temp = array(lo) + array(lo) = array(hi) + array(hi) = temp + itemp = index(lo) + index(lo) = index(hi) + index(hi) = itemp + lo = lo + 1 + hi = hi - 1 + end do + + end subroutine reverse_segment + + end subroutine char_sort_index + +end submodule stdlib_sorting_sort_index diff --git a/src/fpm/stdlib_stats.f90 b/src/fpm/stdlib_stats.f90 new file mode 100644 index 000000000..06237c13c --- /dev/null +++ b/src/fpm/stdlib_stats.f90 @@ -0,0 +1,18055 @@ +module stdlib_stats + !! Provides support for various statistical methods. This includes currently + !! descriptive statistics + !! ([Specification](../page/specs/stdlib_stats.html)) + use stdlib_kinds, only: sp, dp, qp, & + int8, int16, int32, int64 + implicit none + private + ! Public API + public :: corr, cov, mean, moment, var + + + interface corr + !! version: experimental + !! + !! Pearson correlation of array elements + !! ([Specification](../page/specs/stdlib_stats.html#description)) + module function corr_1_rsp_rsp(x, dim, mask) result(res) + real(sp), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(sp) :: res + end function corr_1_rsp_rsp + module function corr_1_rdp_rdp(x, dim, mask) result(res) + real(dp), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res + end function corr_1_rdp_rdp + module function corr_1_rqp_rqp(x, dim, mask) result(res) + real(qp), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(qp) :: res + end function corr_1_rqp_rqp + module function corr_1_csp_csp(x, dim, mask) result(res) + complex(sp), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(sp) :: res + end function corr_1_csp_csp + module function corr_1_cdp_cdp(x, dim, mask) result(res) + complex(dp), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res + end function corr_1_cdp_cdp + module function corr_1_cqp_cqp(x, dim, mask) result(res) + complex(qp), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(qp) :: res + end function corr_1_cqp_cqp + + module function corr_1_iint8_dp(x, dim, mask) result(res) + integer(int8), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res + end function corr_1_iint8_dp + module function corr_1_iint16_dp(x, dim, mask) result(res) + integer(int16), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res + end function corr_1_iint16_dp + module function corr_1_iint32_dp(x, dim, mask) result(res) + integer(int32), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res + end function corr_1_iint32_dp + module function corr_1_iint64_dp(x, dim, mask) result(res) + integer(int64), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res + end function corr_1_iint64_dp + + module function corr_mask_1_rsp_rsp(x, dim, mask) result(res) + real(sp), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:) + real(sp) :: res + end function corr_mask_1_rsp_rsp + module function corr_mask_1_rdp_rdp(x, dim, mask) result(res) + real(dp), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:) + real(dp) :: res + end function corr_mask_1_rdp_rdp + module function corr_mask_1_rqp_rqp(x, dim, mask) result(res) + real(qp), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:) + real(qp) :: res + end function corr_mask_1_rqp_rqp + module function corr_mask_1_csp_csp(x, dim, mask) result(res) + complex(sp), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:) + real(sp) :: res + end function corr_mask_1_csp_csp + module function corr_mask_1_cdp_cdp(x, dim, mask) result(res) + complex(dp), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:) + real(dp) :: res + end function corr_mask_1_cdp_cdp + module function corr_mask_1_cqp_cqp(x, dim, mask) result(res) + complex(qp), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:) + real(qp) :: res + end function corr_mask_1_cqp_cqp + + module function corr_mask_1_iint8_dp(x, dim, mask) result(res) + integer(int8), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:) + real(dp) :: res + end function corr_mask_1_iint8_dp + module function corr_mask_1_iint16_dp(x, dim, mask) result(res) + integer(int16), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:) + real(dp) :: res + end function corr_mask_1_iint16_dp + module function corr_mask_1_iint32_dp(x, dim, mask) result(res) + integer(int32), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:) + real(dp) :: res + end function corr_mask_1_iint32_dp + module function corr_mask_1_iint64_dp(x, dim, mask) result(res) + integer(int64), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:) + real(dp) :: res + end function corr_mask_1_iint64_dp + + module function corr_2_rsp_rsp(x, dim, mask) result(res) + real(sp), intent(in) :: x(:, :) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(sp) :: res(merge(size(x, 1), size(x, 2), mask = 1 0)) + end do + end do + case(2) + do i = 1, size(res, 2) + do j = 1, size(res, 1) + mask_ = merge(.true., .false., mask(i, :) .and. mask(j, :)) + centeri_ = merge( x(i, :) - mean(x(i, :), mask = mask_),& + 0._sp,& + mask_) + centerj_ = merge( x(j, :) - mean(x(j, :), mask = mask_),& + 0._sp,& + mask_) + + n = count(mask_) + res(j, i) = dot_product( centeri_, centerj_)& + / (n - merge(1, 0,& + optval(corrected, .true.) .and. n > 0)) + end do + end do + case default + call error_stop("ERROR (cov): wrong dimension") + end select + + end function cov_mask_2_rsp_rsp + module function cov_mask_2_rdp_rdp(x, dim, mask, corrected) result(res) + real(dp), intent(in) :: x(:, :) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask = 1 0)) + end do + end do + case(2) + do i = 1, size(res, 2) + do j = 1, size(res, 1) + mask_ = merge(.true., .false., mask(i, :) .and. mask(j, :)) + centeri_ = merge( x(i, :) - mean(x(i, :), mask = mask_),& + 0._dp,& + mask_) + centerj_ = merge( x(j, :) - mean(x(j, :), mask = mask_),& + 0._dp,& + mask_) + + n = count(mask_) + res(j, i) = dot_product( centeri_, centerj_)& + / (n - merge(1, 0,& + optval(corrected, .true.) .and. n > 0)) + end do + end do + case default + call error_stop("ERROR (cov): wrong dimension") + end select + + end function cov_mask_2_rdp_rdp + module function cov_mask_2_rqp_rqp(x, dim, mask, corrected) result(res) + real(qp), intent(in) :: x(:, :) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:) + logical, intent(in), optional :: corrected + real(qp) :: res(merge(size(x, 1), size(x, 2), mask = 1 0)) + end do + end do + case(2) + do i = 1, size(res, 2) + do j = 1, size(res, 1) + mask_ = merge(.true., .false., mask(i, :) .and. mask(j, :)) + centeri_ = merge( x(i, :) - mean(x(i, :), mask = mask_),& + 0._qp,& + mask_) + centerj_ = merge( x(j, :) - mean(x(j, :), mask = mask_),& + 0._qp,& + mask_) + + n = count(mask_) + res(j, i) = dot_product( centeri_, centerj_)& + / (n - merge(1, 0,& + optval(corrected, .true.) .and. n > 0)) + end do + end do + case default + call error_stop("ERROR (cov): wrong dimension") + end select + + end function cov_mask_2_rqp_rqp + module function cov_mask_2_csp_csp(x, dim, mask, corrected) result(res) + complex(sp), intent(in) :: x(:, :) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:) + logical, intent(in), optional :: corrected + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask = 1 0)) + end do + end do + case(2) + do i = 1, size(res, 2) + do j = 1, size(res, 1) + mask_ = merge(.true., .false., mask(i, :) .and. mask(j, :)) + centeri_ = merge( x(i, :) - mean(x(i, :), mask = mask_),& + cmplx(0,0,kind=sp),& + mask_) + centerj_ = merge( x(j, :) - mean(x(j, :), mask = mask_),& + cmplx(0,0,kind=sp),& + mask_) + + n = count(mask_) + res(j, i) = dot_product( centeri_, centerj_)& + / (n - merge(1, 0,& + optval(corrected, .true.) .and. n > 0)) + end do + end do + case default + call error_stop("ERROR (cov): wrong dimension") + end select + + end function cov_mask_2_csp_csp + module function cov_mask_2_cdp_cdp(x, dim, mask, corrected) result(res) + complex(dp), intent(in) :: x(:, :) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:) + logical, intent(in), optional :: corrected + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask = 1 0)) + end do + end do + case(2) + do i = 1, size(res, 2) + do j = 1, size(res, 1) + mask_ = merge(.true., .false., mask(i, :) .and. mask(j, :)) + centeri_ = merge( x(i, :) - mean(x(i, :), mask = mask_),& + cmplx(0,0,kind=dp),& + mask_) + centerj_ = merge( x(j, :) - mean(x(j, :), mask = mask_),& + cmplx(0,0,kind=dp),& + mask_) + + n = count(mask_) + res(j, i) = dot_product( centeri_, centerj_)& + / (n - merge(1, 0,& + optval(corrected, .true.) .and. n > 0)) + end do + end do + case default + call error_stop("ERROR (cov): wrong dimension") + end select + + end function cov_mask_2_cdp_cdp + module function cov_mask_2_cqp_cqp(x, dim, mask, corrected) result(res) + complex(qp), intent(in) :: x(:, :) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:) + logical, intent(in), optional :: corrected + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask = 1 0)) + end do + end do + case(2) + do i = 1, size(res, 2) + do j = 1, size(res, 1) + mask_ = merge(.true., .false., mask(i, :) .and. mask(j, :)) + centeri_ = merge( x(i, :) - mean(x(i, :), mask = mask_),& + cmplx(0,0,kind=qp),& + mask_) + centerj_ = merge( x(j, :) - mean(x(j, :), mask = mask_),& + cmplx(0,0,kind=qp),& + mask_) + + n = count(mask_) + res(j, i) = dot_product( centeri_, centerj_)& + / (n - merge(1, 0,& + optval(corrected, .true.) .and. n > 0)) + end do + end do + case default + call error_stop("ERROR (cov): wrong dimension") + end select + + end function cov_mask_2_cqp_cqp + + + module function cov_mask_2_iint8_dp(x, dim, mask, corrected) result(res) + integer(int8), intent(in) :: x(:, :) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask = 1 0)) + end do + end do + case(2) + do i = 1, size(res, 2) + do j = 1, size(res, 1) + mask_ = merge(.true., .false., mask(i, :) .and. mask(j, :)) + centeri_ = merge( x(i, :) - mean(x(i, :), mask = mask_),& + 0._dp, mask_) + centerj_ = merge( x(j, :) - mean(x(j, :), mask = mask_),& + 0._dp, mask_) + + n = count(mask_) + res(j, i) = dot_product( centeri_, centerj_)& + / (n - merge(1, 0,& + optval(corrected, .true.) .and. n > 0)) + end do + end do + case default + call error_stop("ERROR (cov): wrong dimension") + end select + + end function cov_mask_2_iint8_dp + module function cov_mask_2_iint16_dp(x, dim, mask, corrected) result(res) + integer(int16), intent(in) :: x(:, :) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask = 1 0)) + end do + end do + case(2) + do i = 1, size(res, 2) + do j = 1, size(res, 1) + mask_ = merge(.true., .false., mask(i, :) .and. mask(j, :)) + centeri_ = merge( x(i, :) - mean(x(i, :), mask = mask_),& + 0._dp, mask_) + centerj_ = merge( x(j, :) - mean(x(j, :), mask = mask_),& + 0._dp, mask_) + + n = count(mask_) + res(j, i) = dot_product( centeri_, centerj_)& + / (n - merge(1, 0,& + optval(corrected, .true.) .and. n > 0)) + end do + end do + case default + call error_stop("ERROR (cov): wrong dimension") + end select + + end function cov_mask_2_iint16_dp + module function cov_mask_2_iint32_dp(x, dim, mask, corrected) result(res) + integer(int32), intent(in) :: x(:, :) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask = 1 0)) + end do + end do + case(2) + do i = 1, size(res, 2) + do j = 1, size(res, 1) + mask_ = merge(.true., .false., mask(i, :) .and. mask(j, :)) + centeri_ = merge( x(i, :) - mean(x(i, :), mask = mask_),& + 0._dp, mask_) + centerj_ = merge( x(j, :) - mean(x(j, :), mask = mask_),& + 0._dp, mask_) + + n = count(mask_) + res(j, i) = dot_product( centeri_, centerj_)& + / (n - merge(1, 0,& + optval(corrected, .true.) .and. n > 0)) + end do + end do + case default + call error_stop("ERROR (cov): wrong dimension") + end select + + end function cov_mask_2_iint32_dp + module function cov_mask_2_iint64_dp(x, dim, mask, corrected) result(res) + integer(int64), intent(in) :: x(:, :) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask = 1 0)) + end do + end do + case(2) + do i = 1, size(res, 2) + do j = 1, size(res, 1) + mask_ = merge(.true., .false., mask(i, :) .and. mask(j, :)) + centeri_ = merge( x(i, :) - mean(x(i, :), mask = mask_),& + 0._dp, mask_) + centerj_ = merge( x(j, :) - mean(x(j, :), mask = mask_),& + 0._dp, mask_) + + n = count(mask_) + res(j, i) = dot_product( centeri_, centerj_)& + / (n - merge(1, 0,& + optval(corrected, .true.) .and. n > 0)) + end do + end do + case default + call error_stop("ERROR (cov): wrong dimension") + end select + + end function cov_mask_2_iint64_dp + + +end submodule diff --git a/src/fpm/stdlib_stats_distribution_PRNG.f90 b/src/fpm/stdlib_stats_distribution_PRNG.f90 new file mode 100644 index 000000000..26adad247 --- /dev/null +++ b/src/fpm/stdlib_stats_distribution_PRNG.f90 @@ -0,0 +1,256 @@ +module stdlib_stats_distribution_PRNG + use stdlib_kinds, only: int8, int16, int32, int64 + use stdlib_error, only: error_stop + implicit none + private + integer, parameter :: MAX_INT_BIT_SIZE = bit_size(1_int64) + integer(int64) :: st(4) ! internal states for xoshiro256ss function + integer(int64) :: si = 614872703977525537_int64 ! default seed value + logical :: seed_initialized = .false. + + public :: random_seed + public :: dist_rand + + + interface dist_rand + !! Version experimental + !! + !! Generation of random integers with different kinds + !! ([Specification](../page/specs/stdlib_stats_distribution_PRNG.html# + !! description)) + module procedure dist_rand_iint8 + module procedure dist_rand_iint16 + module procedure dist_rand_iint32 + module procedure dist_rand_iint64 + end interface dist_rand + + interface random_seed + !! Version experimental + !! + !! Set seed value for random number generator + !! ([Specification](../page/specs/stdlib_stats_distribution_PRNG.html# + !! description)) + !! + module procedure random_distribution_seed_iint8 + module procedure random_distribution_seed_iint16 + module procedure random_distribution_seed_iint32 + module procedure random_distribution_seed_iint64 + end interface random_seed + + + contains + + function dist_rand_iint8(n) result(res) + !! Random integer generation for various kinds + !! result = [-2^k, 2^k - 1], k = 7, 15, 31, 63, depending on input kind + !! Result will be operated by bitwise operators to generate desired integer + !! and real pseudorandom numbers + !! + integer(int8), intent(in) :: n + integer(int8) :: res + integer :: k + + k = MAX_INT_BIT_SIZE - bit_size(n) + if(k < 0) call error_stop("Error(dist_rand): Integer bit size is" & + //" greater than 64bit") + res = shiftr(xoshiro256ss( ), k) + end function dist_rand_iint8 + + function dist_rand_iint16(n) result(res) + !! Random integer generation for various kinds + !! result = [-2^k, 2^k - 1], k = 7, 15, 31, 63, depending on input kind + !! Result will be operated by bitwise operators to generate desired integer + !! and real pseudorandom numbers + !! + integer(int16), intent(in) :: n + integer(int16) :: res + integer :: k + + k = MAX_INT_BIT_SIZE - bit_size(n) + if(k < 0) call error_stop("Error(dist_rand): Integer bit size is" & + //" greater than 64bit") + res = shiftr(xoshiro256ss( ), k) + end function dist_rand_iint16 + + function dist_rand_iint32(n) result(res) + !! Random integer generation for various kinds + !! result = [-2^k, 2^k - 1], k = 7, 15, 31, 63, depending on input kind + !! Result will be operated by bitwise operators to generate desired integer + !! and real pseudorandom numbers + !! + integer(int32), intent(in) :: n + integer(int32) :: res + integer :: k + + k = MAX_INT_BIT_SIZE - bit_size(n) + if(k < 0) call error_stop("Error(dist_rand): Integer bit size is" & + //" greater than 64bit") + res = shiftr(xoshiro256ss( ), k) + end function dist_rand_iint32 + + function dist_rand_iint64(n) result(res) + !! Random integer generation for various kinds + !! result = [-2^k, 2^k - 1], k = 7, 15, 31, 63, depending on input kind + !! Result will be operated by bitwise operators to generate desired integer + !! and real pseudorandom numbers + !! + integer(int64), intent(in) :: n + integer(int64) :: res + integer :: k + + k = MAX_INT_BIT_SIZE - bit_size(n) + if(k < 0) call error_stop("Error(dist_rand): Integer bit size is" & + //" greater than 64bit") + res = shiftr(xoshiro256ss( ), k) + end function dist_rand_iint64 + + + function xoshiro256ss( ) result (res) + ! Generate random 64-bit integers + ! Written in 2018 by David Blackman and Sebastiano Vigna (vigna@acm.org) + ! http://prng.di.unimi.it/xoshiro256starstar.c + ! + ! This is xoshiro256** 1.0, one of our all-purpose, rock-solid + ! generators. It has excellent (sub-ns) speed, a state (256 bits) that is + ! large enough for any parallel application, and it passes all tests we + ! are aware of. + ! + ! The state must be seeded so that it is not everywhere zero. If you have + ! a 64-bit seed, we suggest to seed a splitmix64 generator and use its + ! output to fill st. + ! + ! Fortran 90 version translated from C by Jim-215-Fisher + ! + integer(int64) :: res, t + + if(.not. seed_initialized) call random_distribution_seed_iint64(si,t) + res = rol64(st(2) * 5, 7) * 9 + t = shiftl(st(2), 17) + st(3) = ieor(st(3), st(1)) + st(4) = ieor(st(4), st(2)) + st(2) = ieor(st(2), st(3)) + st(1) = ieor(st(1), st(4)) + st(3) = ieor(st(3), t) + st(4) = rol64(st(4), 45) + end function xoshiro256ss + + pure function rol64(x, k) result(res) + integer(int64), intent(in) :: x + integer, intent(in) :: k + integer(int64) :: t1, t2, res + + t1 = shiftr(x, (64 - k)) + t2 = shiftl(x, k) + res = ior(t1, t2) + end function rol64 + + + function splitmix64(s) result(res) + ! Written in 2015 by Sebastiano Vigna (vigna@acm.org) + ! This is a fixed-increment version of Java 8's SplittableRandom + ! generator. + ! See http://dx.doi.org/10.1145/2714064.2660195 and + ! http://docs.oracle.com/javase/8/docs/api/java/util/SplittableRandom.html + ! + ! It is a very fast generator passing BigCrush, and it can be useful if + ! for some reason you absolutely want 64 bits of state. + ! + ! Fortran 90 translated from C by Jim-215-Fisher + ! + integer(int64) :: res + integer(int64), intent(in), optional :: s + integer(int64) :: int01 = -7046029254386353131_int64, & + int02 = -4658895280553007687_int64, & + int03 = -7723592293110705685_int64 + ! Values are converted from C unsigned integer of 0x9e3779b97f4a7c15, + ! 0xbf58476d1ce4e5b9, 0x94d049bb133111eb + + if(present(s)) si = s + res = si + si = res + int01 + res = ieor(res, shiftr(res, 30)) * int02 + res = ieor(res, shiftr(res, 27)) * int03 + res = ieor(res, shiftr(res, 31)) + end function splitmix64 + + subroutine random_distribution_seed_iint8(put, get) + !! Set seed value for random number generator + !! + integer(int8), intent(in) :: put + integer(int8), intent(out) :: get + integer(int64) :: tmp + integer :: i + + tmp = splitmix64(int(put, kind = int64)) + do i = 1, 10 + tmp = splitmix64( ) + end do + do i = 1, 4 + tmp = splitmix64( ) + st(i) = tmp + end do + get = int(tmp, kind = int8) + seed_initialized = .true. + end subroutine random_distribution_seed_iint8 + + subroutine random_distribution_seed_iint16(put, get) + !! Set seed value for random number generator + !! + integer(int16), intent(in) :: put + integer(int16), intent(out) :: get + integer(int64) :: tmp + integer :: i + + tmp = splitmix64(int(put, kind = int64)) + do i = 1, 10 + tmp = splitmix64( ) + end do + do i = 1, 4 + tmp = splitmix64( ) + st(i) = tmp + end do + get = int(tmp, kind = int16) + seed_initialized = .true. + end subroutine random_distribution_seed_iint16 + + subroutine random_distribution_seed_iint32(put, get) + !! Set seed value for random number generator + !! + integer(int32), intent(in) :: put + integer(int32), intent(out) :: get + integer(int64) :: tmp + integer :: i + + tmp = splitmix64(int(put, kind = int64)) + do i = 1, 10 + tmp = splitmix64( ) + end do + do i = 1, 4 + tmp = splitmix64( ) + st(i) = tmp + end do + get = int(tmp, kind = int32) + seed_initialized = .true. + end subroutine random_distribution_seed_iint32 + + subroutine random_distribution_seed_iint64(put, get) + !! Set seed value for random number generator + !! + integer(int64), intent(in) :: put + integer(int64), intent(out) :: get + integer(int64) :: tmp + integer :: i + + tmp = splitmix64(int(put, kind = int64)) + do i = 1, 10 + tmp = splitmix64( ) + end do + do i = 1, 4 + tmp = splitmix64( ) + st(i) = tmp + end do + get = int(tmp, kind = int64) + seed_initialized = .true. + end subroutine random_distribution_seed_iint64 + +end module stdlib_stats_distribution_PRNG diff --git a/src/fpm/stdlib_stats_mean.f90 b/src/fpm/stdlib_stats_mean.f90 new file mode 100644 index 000000000..85a4a31bd --- /dev/null +++ b/src/fpm/stdlib_stats_mean.f90 @@ -0,0 +1,8502 @@ +submodule (stdlib_stats) stdlib_stats_mean + + use, intrinsic:: ieee_arithmetic, only: ieee_value, ieee_quiet_nan + use stdlib_error, only: error_stop + use stdlib_optval, only: optval + implicit none + +contains + + module function mean_all_1_rsp_rsp (x, mask) result(res) + real(sp), intent(in) :: x(:) + logical, intent(in), optional :: mask + real(sp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), sp) + + end function mean_all_1_rsp_rsp + module function mean_all_2_rsp_rsp (x, mask) result(res) + real(sp), intent(in) :: x(:,:) + logical, intent(in), optional :: mask + real(sp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), sp) + + end function mean_all_2_rsp_rsp + module function mean_all_3_rsp_rsp (x, mask) result(res) + real(sp), intent(in) :: x(:,:,:) + logical, intent(in), optional :: mask + real(sp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), sp) + + end function mean_all_3_rsp_rsp + module function mean_all_4_rsp_rsp (x, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:) + logical, intent(in), optional :: mask + real(sp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), sp) + + end function mean_all_4_rsp_rsp + module function mean_all_5_rsp_rsp (x, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:) + logical, intent(in), optional :: mask + real(sp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), sp) + + end function mean_all_5_rsp_rsp + module function mean_all_6_rsp_rsp (x, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(sp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), sp) + + end function mean_all_6_rsp_rsp + module function mean_all_7_rsp_rsp (x, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(sp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), sp) + + end function mean_all_7_rsp_rsp + module function mean_all_8_rsp_rsp (x, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(sp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), sp) + + end function mean_all_8_rsp_rsp + module function mean_all_9_rsp_rsp (x, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(sp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), sp) + + end function mean_all_9_rsp_rsp + module function mean_all_10_rsp_rsp (x, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(sp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), sp) + + end function mean_all_10_rsp_rsp + module function mean_all_11_rsp_rsp (x, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(sp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), sp) + + end function mean_all_11_rsp_rsp + module function mean_all_12_rsp_rsp (x, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(sp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), sp) + + end function mean_all_12_rsp_rsp + module function mean_all_13_rsp_rsp (x, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(sp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), sp) + + end function mean_all_13_rsp_rsp + module function mean_all_14_rsp_rsp (x, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(sp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), sp) + + end function mean_all_14_rsp_rsp + module function mean_all_15_rsp_rsp (x, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(sp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), sp) + + end function mean_all_15_rsp_rsp + module function mean_all_1_rdp_rdp (x, mask) result(res) + real(dp), intent(in) :: x(:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), dp) + + end function mean_all_1_rdp_rdp + module function mean_all_2_rdp_rdp (x, mask) result(res) + real(dp), intent(in) :: x(:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), dp) + + end function mean_all_2_rdp_rdp + module function mean_all_3_rdp_rdp (x, mask) result(res) + real(dp), intent(in) :: x(:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), dp) + + end function mean_all_3_rdp_rdp + module function mean_all_4_rdp_rdp (x, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), dp) + + end function mean_all_4_rdp_rdp + module function mean_all_5_rdp_rdp (x, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), dp) + + end function mean_all_5_rdp_rdp + module function mean_all_6_rdp_rdp (x, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), dp) + + end function mean_all_6_rdp_rdp + module function mean_all_7_rdp_rdp (x, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), dp) + + end function mean_all_7_rdp_rdp + module function mean_all_8_rdp_rdp (x, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), dp) + + end function mean_all_8_rdp_rdp + module function mean_all_9_rdp_rdp (x, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), dp) + + end function mean_all_9_rdp_rdp + module function mean_all_10_rdp_rdp (x, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), dp) + + end function mean_all_10_rdp_rdp + module function mean_all_11_rdp_rdp (x, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), dp) + + end function mean_all_11_rdp_rdp + module function mean_all_12_rdp_rdp (x, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), dp) + + end function mean_all_12_rdp_rdp + module function mean_all_13_rdp_rdp (x, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), dp) + + end function mean_all_13_rdp_rdp + module function mean_all_14_rdp_rdp (x, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), dp) + + end function mean_all_14_rdp_rdp + module function mean_all_15_rdp_rdp (x, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), dp) + + end function mean_all_15_rdp_rdp + module function mean_all_1_rqp_rqp (x, mask) result(res) + real(qp), intent(in) :: x(:) + logical, intent(in), optional :: mask + real(qp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), qp) + + end function mean_all_1_rqp_rqp + module function mean_all_2_rqp_rqp (x, mask) result(res) + real(qp), intent(in) :: x(:,:) + logical, intent(in), optional :: mask + real(qp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), qp) + + end function mean_all_2_rqp_rqp + module function mean_all_3_rqp_rqp (x, mask) result(res) + real(qp), intent(in) :: x(:,:,:) + logical, intent(in), optional :: mask + real(qp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), qp) + + end function mean_all_3_rqp_rqp + module function mean_all_4_rqp_rqp (x, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:) + logical, intent(in), optional :: mask + real(qp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), qp) + + end function mean_all_4_rqp_rqp + module function mean_all_5_rqp_rqp (x, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:) + logical, intent(in), optional :: mask + real(qp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), qp) + + end function mean_all_5_rqp_rqp + module function mean_all_6_rqp_rqp (x, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(qp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), qp) + + end function mean_all_6_rqp_rqp + module function mean_all_7_rqp_rqp (x, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(qp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), qp) + + end function mean_all_7_rqp_rqp + module function mean_all_8_rqp_rqp (x, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(qp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), qp) + + end function mean_all_8_rqp_rqp + module function mean_all_9_rqp_rqp (x, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(qp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), qp) + + end function mean_all_9_rqp_rqp + module function mean_all_10_rqp_rqp (x, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(qp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), qp) + + end function mean_all_10_rqp_rqp + module function mean_all_11_rqp_rqp (x, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(qp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), qp) + + end function mean_all_11_rqp_rqp + module function mean_all_12_rqp_rqp (x, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(qp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), qp) + + end function mean_all_12_rqp_rqp + module function mean_all_13_rqp_rqp (x, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(qp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), qp) + + end function mean_all_13_rqp_rqp + module function mean_all_14_rqp_rqp (x, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(qp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), qp) + + end function mean_all_14_rqp_rqp + module function mean_all_15_rqp_rqp (x, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(qp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), qp) + + end function mean_all_15_rqp_rqp + module function mean_all_1_csp_csp (x, mask) result(res) + complex(sp), intent(in) :: x(:) + logical, intent(in), optional :: mask + complex(sp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), sp) + + end function mean_all_1_csp_csp + module function mean_all_2_csp_csp (x, mask) result(res) + complex(sp), intent(in) :: x(:,:) + logical, intent(in), optional :: mask + complex(sp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), sp) + + end function mean_all_2_csp_csp + module function mean_all_3_csp_csp (x, mask) result(res) + complex(sp), intent(in) :: x(:,:,:) + logical, intent(in), optional :: mask + complex(sp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), sp) + + end function mean_all_3_csp_csp + module function mean_all_4_csp_csp (x, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:) + logical, intent(in), optional :: mask + complex(sp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), sp) + + end function mean_all_4_csp_csp + module function mean_all_5_csp_csp (x, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:) + logical, intent(in), optional :: mask + complex(sp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), sp) + + end function mean_all_5_csp_csp + module function mean_all_6_csp_csp (x, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:) + logical, intent(in), optional :: mask + complex(sp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), sp) + + end function mean_all_6_csp_csp + module function mean_all_7_csp_csp (x, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + complex(sp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), sp) + + end function mean_all_7_csp_csp + module function mean_all_8_csp_csp (x, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + complex(sp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), sp) + + end function mean_all_8_csp_csp + module function mean_all_9_csp_csp (x, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + complex(sp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), sp) + + end function mean_all_9_csp_csp + module function mean_all_10_csp_csp (x, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + complex(sp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), sp) + + end function mean_all_10_csp_csp + module function mean_all_11_csp_csp (x, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + complex(sp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), sp) + + end function mean_all_11_csp_csp + module function mean_all_12_csp_csp (x, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + complex(sp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), sp) + + end function mean_all_12_csp_csp + module function mean_all_13_csp_csp (x, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + complex(sp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), sp) + + end function mean_all_13_csp_csp + module function mean_all_14_csp_csp (x, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + complex(sp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), sp) + + end function mean_all_14_csp_csp + module function mean_all_15_csp_csp (x, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + complex(sp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), sp) + + end function mean_all_15_csp_csp + module function mean_all_1_cdp_cdp (x, mask) result(res) + complex(dp), intent(in) :: x(:) + logical, intent(in), optional :: mask + complex(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), dp) + + end function mean_all_1_cdp_cdp + module function mean_all_2_cdp_cdp (x, mask) result(res) + complex(dp), intent(in) :: x(:,:) + logical, intent(in), optional :: mask + complex(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), dp) + + end function mean_all_2_cdp_cdp + module function mean_all_3_cdp_cdp (x, mask) result(res) + complex(dp), intent(in) :: x(:,:,:) + logical, intent(in), optional :: mask + complex(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), dp) + + end function mean_all_3_cdp_cdp + module function mean_all_4_cdp_cdp (x, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:) + logical, intent(in), optional :: mask + complex(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), dp) + + end function mean_all_4_cdp_cdp + module function mean_all_5_cdp_cdp (x, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:) + logical, intent(in), optional :: mask + complex(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), dp) + + end function mean_all_5_cdp_cdp + module function mean_all_6_cdp_cdp (x, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:) + logical, intent(in), optional :: mask + complex(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), dp) + + end function mean_all_6_cdp_cdp + module function mean_all_7_cdp_cdp (x, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + complex(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), dp) + + end function mean_all_7_cdp_cdp + module function mean_all_8_cdp_cdp (x, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + complex(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), dp) + + end function mean_all_8_cdp_cdp + module function mean_all_9_cdp_cdp (x, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + complex(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), dp) + + end function mean_all_9_cdp_cdp + module function mean_all_10_cdp_cdp (x, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + complex(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), dp) + + end function mean_all_10_cdp_cdp + module function mean_all_11_cdp_cdp (x, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + complex(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), dp) + + end function mean_all_11_cdp_cdp + module function mean_all_12_cdp_cdp (x, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + complex(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), dp) + + end function mean_all_12_cdp_cdp + module function mean_all_13_cdp_cdp (x, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + complex(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), dp) + + end function mean_all_13_cdp_cdp + module function mean_all_14_cdp_cdp (x, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + complex(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), dp) + + end function mean_all_14_cdp_cdp + module function mean_all_15_cdp_cdp (x, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + complex(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), dp) + + end function mean_all_15_cdp_cdp + module function mean_all_1_cqp_cqp (x, mask) result(res) + complex(qp), intent(in) :: x(:) + logical, intent(in), optional :: mask + complex(qp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), qp) + + end function mean_all_1_cqp_cqp + module function mean_all_2_cqp_cqp (x, mask) result(res) + complex(qp), intent(in) :: x(:,:) + logical, intent(in), optional :: mask + complex(qp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), qp) + + end function mean_all_2_cqp_cqp + module function mean_all_3_cqp_cqp (x, mask) result(res) + complex(qp), intent(in) :: x(:,:,:) + logical, intent(in), optional :: mask + complex(qp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), qp) + + end function mean_all_3_cqp_cqp + module function mean_all_4_cqp_cqp (x, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:) + logical, intent(in), optional :: mask + complex(qp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), qp) + + end function mean_all_4_cqp_cqp + module function mean_all_5_cqp_cqp (x, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:) + logical, intent(in), optional :: mask + complex(qp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), qp) + + end function mean_all_5_cqp_cqp + module function mean_all_6_cqp_cqp (x, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:) + logical, intent(in), optional :: mask + complex(qp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), qp) + + end function mean_all_6_cqp_cqp + module function mean_all_7_cqp_cqp (x, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + complex(qp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), qp) + + end function mean_all_7_cqp_cqp + module function mean_all_8_cqp_cqp (x, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + complex(qp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), qp) + + end function mean_all_8_cqp_cqp + module function mean_all_9_cqp_cqp (x, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + complex(qp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), qp) + + end function mean_all_9_cqp_cqp + module function mean_all_10_cqp_cqp (x, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + complex(qp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), qp) + + end function mean_all_10_cqp_cqp + module function mean_all_11_cqp_cqp (x, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + complex(qp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), qp) + + end function mean_all_11_cqp_cqp + module function mean_all_12_cqp_cqp (x, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + complex(qp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), qp) + + end function mean_all_12_cqp_cqp + module function mean_all_13_cqp_cqp (x, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + complex(qp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), qp) + + end function mean_all_13_cqp_cqp + module function mean_all_14_cqp_cqp (x, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + complex(qp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), qp) + + end function mean_all_14_cqp_cqp + module function mean_all_15_cqp_cqp (x, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + complex(qp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + res = sum(x) / real(size(x, kind = int64), qp) + + end function mean_all_15_cqp_cqp + + module function mean_all_1_iint8_dp(x, mask) result(res) + integer(int8), intent(in) :: x(:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_1_iint8_dp + module function mean_all_2_iint8_dp(x, mask) result(res) + integer(int8), intent(in) :: x(:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_2_iint8_dp + module function mean_all_3_iint8_dp(x, mask) result(res) + integer(int8), intent(in) :: x(:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_3_iint8_dp + module function mean_all_4_iint8_dp(x, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_4_iint8_dp + module function mean_all_5_iint8_dp(x, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_5_iint8_dp + module function mean_all_6_iint8_dp(x, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_6_iint8_dp + module function mean_all_7_iint8_dp(x, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_7_iint8_dp + module function mean_all_8_iint8_dp(x, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_8_iint8_dp + module function mean_all_9_iint8_dp(x, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_9_iint8_dp + module function mean_all_10_iint8_dp(x, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_10_iint8_dp + module function mean_all_11_iint8_dp(x, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_11_iint8_dp + module function mean_all_12_iint8_dp(x, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_12_iint8_dp + module function mean_all_13_iint8_dp(x, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_13_iint8_dp + module function mean_all_14_iint8_dp(x, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_14_iint8_dp + module function mean_all_15_iint8_dp(x, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_15_iint8_dp + module function mean_all_1_iint16_dp(x, mask) result(res) + integer(int16), intent(in) :: x(:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_1_iint16_dp + module function mean_all_2_iint16_dp(x, mask) result(res) + integer(int16), intent(in) :: x(:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_2_iint16_dp + module function mean_all_3_iint16_dp(x, mask) result(res) + integer(int16), intent(in) :: x(:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_3_iint16_dp + module function mean_all_4_iint16_dp(x, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_4_iint16_dp + module function mean_all_5_iint16_dp(x, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_5_iint16_dp + module function mean_all_6_iint16_dp(x, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_6_iint16_dp + module function mean_all_7_iint16_dp(x, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_7_iint16_dp + module function mean_all_8_iint16_dp(x, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_8_iint16_dp + module function mean_all_9_iint16_dp(x, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_9_iint16_dp + module function mean_all_10_iint16_dp(x, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_10_iint16_dp + module function mean_all_11_iint16_dp(x, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_11_iint16_dp + module function mean_all_12_iint16_dp(x, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_12_iint16_dp + module function mean_all_13_iint16_dp(x, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_13_iint16_dp + module function mean_all_14_iint16_dp(x, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_14_iint16_dp + module function mean_all_15_iint16_dp(x, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_15_iint16_dp + module function mean_all_1_iint32_dp(x, mask) result(res) + integer(int32), intent(in) :: x(:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_1_iint32_dp + module function mean_all_2_iint32_dp(x, mask) result(res) + integer(int32), intent(in) :: x(:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_2_iint32_dp + module function mean_all_3_iint32_dp(x, mask) result(res) + integer(int32), intent(in) :: x(:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_3_iint32_dp + module function mean_all_4_iint32_dp(x, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_4_iint32_dp + module function mean_all_5_iint32_dp(x, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_5_iint32_dp + module function mean_all_6_iint32_dp(x, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_6_iint32_dp + module function mean_all_7_iint32_dp(x, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_7_iint32_dp + module function mean_all_8_iint32_dp(x, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_8_iint32_dp + module function mean_all_9_iint32_dp(x, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_9_iint32_dp + module function mean_all_10_iint32_dp(x, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_10_iint32_dp + module function mean_all_11_iint32_dp(x, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_11_iint32_dp + module function mean_all_12_iint32_dp(x, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_12_iint32_dp + module function mean_all_13_iint32_dp(x, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_13_iint32_dp + module function mean_all_14_iint32_dp(x, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_14_iint32_dp + module function mean_all_15_iint32_dp(x, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_15_iint32_dp + module function mean_all_1_iint64_dp(x, mask) result(res) + integer(int64), intent(in) :: x(:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_1_iint64_dp + module function mean_all_2_iint64_dp(x, mask) result(res) + integer(int64), intent(in) :: x(:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_2_iint64_dp + module function mean_all_3_iint64_dp(x, mask) result(res) + integer(int64), intent(in) :: x(:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_3_iint64_dp + module function mean_all_4_iint64_dp(x, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_4_iint64_dp + module function mean_all_5_iint64_dp(x, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_5_iint64_dp + module function mean_all_6_iint64_dp(x, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_6_iint64_dp + module function mean_all_7_iint64_dp(x, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_7_iint64_dp + module function mean_all_8_iint64_dp(x, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_8_iint64_dp + module function mean_all_9_iint64_dp(x, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_9_iint64_dp + module function mean_all_10_iint64_dp(x, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_10_iint64_dp + module function mean_all_11_iint64_dp(x, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_11_iint64_dp + module function mean_all_12_iint64_dp(x, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_12_iint64_dp + module function mean_all_13_iint64_dp(x, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_13_iint64_dp + module function mean_all_14_iint64_dp(x, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_14_iint64_dp + module function mean_all_15_iint64_dp(x, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + + end function mean_all_15_iint64_dp + + + module function mean_1_rsp_rsp(x, dim, mask) result(res) + real(sp), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(sp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + if (dim >= 1 .and. dim <= 1) then + res = sum(x, dim) / real(size(x, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_1_rsp_rsp + module function mean_2_rsp_rsp(x, dim, mask) result(res) + real(sp), intent(in) :: x(:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then + res = sum(x, dim) / real(size(x, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_2_rsp_rsp + module function mean_3_rsp_rsp(x, dim, mask) result(res) + real(sp), intent(in) :: x(:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then + res = sum(x, dim) / real(size(x, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_3_rsp_rsp + module function mean_4_rsp_rsp(x, dim, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then + res = sum(x, dim) / real(size(x, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_4_rsp_rsp + module function mean_5_rsp_rsp(x, dim, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then + res = sum(x, dim) / real(size(x, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_5_rsp_rsp + module function mean_6_rsp_rsp(x, dim, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then + res = sum(x, dim) / real(size(x, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_6_rsp_rsp + module function mean_7_rsp_rsp(x, dim, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then + res = sum(x, dim) / real(size(x, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_7_rsp_rsp + module function mean_8_rsp_rsp(x, dim, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then + res = sum(x, dim) / real(size(x, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_8_rsp_rsp + module function mean_9_rsp_rsp(x, dim, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then + res = sum(x, dim) / real(size(x, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_9_rsp_rsp + module function mean_10_rsp_rsp(x, dim, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then + res = sum(x, dim) / real(size(x, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_10_rsp_rsp + module function mean_11_rsp_rsp(x, dim, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then + res = sum(x, dim) / real(size(x, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_11_rsp_rsp + module function mean_12_rsp_rsp(x, dim, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then + res = sum(x, dim) / real(size(x, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_12_rsp_rsp + module function mean_13_rsp_rsp(x, dim, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then + res = sum(x, dim) / real(size(x, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_13_rsp_rsp + module function mean_14_rsp_rsp(x, dim, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + res = sum(x, dim) / real(size(x, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_14_rsp_rsp + module function mean_15_rsp_rsp(x, dim, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + res = sum(x, dim) / real(size(x, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_15_rsp_rsp + module function mean_1_rdp_rdp(x, dim, mask) result(res) + real(dp), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + if (dim >= 1 .and. dim <= 1) then + res = sum(x, dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_1_rdp_rdp + module function mean_2_rdp_rdp(x, dim, mask) result(res) + real(dp), intent(in) :: x(:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then + res = sum(x, dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_2_rdp_rdp + module function mean_3_rdp_rdp(x, dim, mask) result(res) + real(dp), intent(in) :: x(:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then + res = sum(x, dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_3_rdp_rdp + module function mean_4_rdp_rdp(x, dim, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then + res = sum(x, dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_4_rdp_rdp + module function mean_5_rdp_rdp(x, dim, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then + res = sum(x, dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_5_rdp_rdp + module function mean_6_rdp_rdp(x, dim, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then + res = sum(x, dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_6_rdp_rdp + module function mean_7_rdp_rdp(x, dim, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then + res = sum(x, dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_7_rdp_rdp + module function mean_8_rdp_rdp(x, dim, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then + res = sum(x, dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_8_rdp_rdp + module function mean_9_rdp_rdp(x, dim, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then + res = sum(x, dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_9_rdp_rdp + module function mean_10_rdp_rdp(x, dim, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then + res = sum(x, dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_10_rdp_rdp + module function mean_11_rdp_rdp(x, dim, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then + res = sum(x, dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_11_rdp_rdp + module function mean_12_rdp_rdp(x, dim, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then + res = sum(x, dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_12_rdp_rdp + module function mean_13_rdp_rdp(x, dim, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then + res = sum(x, dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_13_rdp_rdp + module function mean_14_rdp_rdp(x, dim, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + res = sum(x, dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_14_rdp_rdp + module function mean_15_rdp_rdp(x, dim, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + res = sum(x, dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_15_rdp_rdp + module function mean_1_rqp_rqp(x, dim, mask) result(res) + real(qp), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(qp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + if (dim >= 1 .and. dim <= 1) then + res = sum(x, dim) / real(size(x, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_1_rqp_rqp + module function mean_2_rqp_rqp(x, dim, mask) result(res) + real(qp), intent(in) :: x(:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then + res = sum(x, dim) / real(size(x, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_2_rqp_rqp + module function mean_3_rqp_rqp(x, dim, mask) result(res) + real(qp), intent(in) :: x(:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then + res = sum(x, dim) / real(size(x, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_3_rqp_rqp + module function mean_4_rqp_rqp(x, dim, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then + res = sum(x, dim) / real(size(x, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_4_rqp_rqp + module function mean_5_rqp_rqp(x, dim, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then + res = sum(x, dim) / real(size(x, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_5_rqp_rqp + module function mean_6_rqp_rqp(x, dim, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then + res = sum(x, dim) / real(size(x, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_6_rqp_rqp + module function mean_7_rqp_rqp(x, dim, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then + res = sum(x, dim) / real(size(x, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_7_rqp_rqp + module function mean_8_rqp_rqp(x, dim, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then + res = sum(x, dim) / real(size(x, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_8_rqp_rqp + module function mean_9_rqp_rqp(x, dim, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then + res = sum(x, dim) / real(size(x, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_9_rqp_rqp + module function mean_10_rqp_rqp(x, dim, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then + res = sum(x, dim) / real(size(x, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_10_rqp_rqp + module function mean_11_rqp_rqp(x, dim, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then + res = sum(x, dim) / real(size(x, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_11_rqp_rqp + module function mean_12_rqp_rqp(x, dim, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then + res = sum(x, dim) / real(size(x, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_12_rqp_rqp + module function mean_13_rqp_rqp(x, dim, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then + res = sum(x, dim) / real(size(x, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_13_rqp_rqp + module function mean_14_rqp_rqp(x, dim, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + res = sum(x, dim) / real(size(x, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_14_rqp_rqp + module function mean_15_rqp_rqp(x, dim, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + res = sum(x, dim) / real(size(x, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_15_rqp_rqp + module function mean_1_csp_csp(x, dim, mask) result(res) + complex(sp), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + complex(sp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + if (dim >= 1 .and. dim <= 1) then + res = sum(x, dim) / real(size(x, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_1_csp_csp + module function mean_2_csp_csp(x, dim, mask) result(res) + complex(sp), intent(in) :: x(:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then + res = sum(x, dim) / real(size(x, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_2_csp_csp + module function mean_3_csp_csp(x, dim, mask) result(res) + complex(sp), intent(in) :: x(:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then + res = sum(x, dim) / real(size(x, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_3_csp_csp + module function mean_4_csp_csp(x, dim, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then + res = sum(x, dim) / real(size(x, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_4_csp_csp + module function mean_5_csp_csp(x, dim, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then + res = sum(x, dim) / real(size(x, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_5_csp_csp + module function mean_6_csp_csp(x, dim, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then + res = sum(x, dim) / real(size(x, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_6_csp_csp + module function mean_7_csp_csp(x, dim, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then + res = sum(x, dim) / real(size(x, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_7_csp_csp + module function mean_8_csp_csp(x, dim, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then + res = sum(x, dim) / real(size(x, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_8_csp_csp + module function mean_9_csp_csp(x, dim, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then + res = sum(x, dim) / real(size(x, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_9_csp_csp + module function mean_10_csp_csp(x, dim, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then + res = sum(x, dim) / real(size(x, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_10_csp_csp + module function mean_11_csp_csp(x, dim, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then + res = sum(x, dim) / real(size(x, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_11_csp_csp + module function mean_12_csp_csp(x, dim, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then + res = sum(x, dim) / real(size(x, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_12_csp_csp + module function mean_13_csp_csp(x, dim, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then + res = sum(x, dim) / real(size(x, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_13_csp_csp + module function mean_14_csp_csp(x, dim, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + res = sum(x, dim) / real(size(x, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_14_csp_csp + module function mean_15_csp_csp(x, dim, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + res = sum(x, dim) / real(size(x, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_15_csp_csp + module function mean_1_cdp_cdp(x, dim, mask) result(res) + complex(dp), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + complex(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + if (dim >= 1 .and. dim <= 1) then + res = sum(x, dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_1_cdp_cdp + module function mean_2_cdp_cdp(x, dim, mask) result(res) + complex(dp), intent(in) :: x(:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then + res = sum(x, dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_2_cdp_cdp + module function mean_3_cdp_cdp(x, dim, mask) result(res) + complex(dp), intent(in) :: x(:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then + res = sum(x, dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_3_cdp_cdp + module function mean_4_cdp_cdp(x, dim, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then + res = sum(x, dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_4_cdp_cdp + module function mean_5_cdp_cdp(x, dim, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then + res = sum(x, dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_5_cdp_cdp + module function mean_6_cdp_cdp(x, dim, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then + res = sum(x, dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_6_cdp_cdp + module function mean_7_cdp_cdp(x, dim, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then + res = sum(x, dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_7_cdp_cdp + module function mean_8_cdp_cdp(x, dim, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then + res = sum(x, dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_8_cdp_cdp + module function mean_9_cdp_cdp(x, dim, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then + res = sum(x, dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_9_cdp_cdp + module function mean_10_cdp_cdp(x, dim, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then + res = sum(x, dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_10_cdp_cdp + module function mean_11_cdp_cdp(x, dim, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then + res = sum(x, dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_11_cdp_cdp + module function mean_12_cdp_cdp(x, dim, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then + res = sum(x, dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_12_cdp_cdp + module function mean_13_cdp_cdp(x, dim, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then + res = sum(x, dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_13_cdp_cdp + module function mean_14_cdp_cdp(x, dim, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + res = sum(x, dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_14_cdp_cdp + module function mean_15_cdp_cdp(x, dim, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + res = sum(x, dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_15_cdp_cdp + module function mean_1_cqp_cqp(x, dim, mask) result(res) + complex(qp), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + complex(qp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + if (dim >= 1 .and. dim <= 1) then + res = sum(x, dim) / real(size(x, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_1_cqp_cqp + module function mean_2_cqp_cqp(x, dim, mask) result(res) + complex(qp), intent(in) :: x(:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then + res = sum(x, dim) / real(size(x, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_2_cqp_cqp + module function mean_3_cqp_cqp(x, dim, mask) result(res) + complex(qp), intent(in) :: x(:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then + res = sum(x, dim) / real(size(x, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_3_cqp_cqp + module function mean_4_cqp_cqp(x, dim, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then + res = sum(x, dim) / real(size(x, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_4_cqp_cqp + module function mean_5_cqp_cqp(x, dim, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then + res = sum(x, dim) / real(size(x, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_5_cqp_cqp + module function mean_6_cqp_cqp(x, dim, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then + res = sum(x, dim) / real(size(x, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_6_cqp_cqp + module function mean_7_cqp_cqp(x, dim, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then + res = sum(x, dim) / real(size(x, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_7_cqp_cqp + module function mean_8_cqp_cqp(x, dim, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then + res = sum(x, dim) / real(size(x, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_8_cqp_cqp + module function mean_9_cqp_cqp(x, dim, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then + res = sum(x, dim) / real(size(x, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_9_cqp_cqp + module function mean_10_cqp_cqp(x, dim, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then + res = sum(x, dim) / real(size(x, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_10_cqp_cqp + module function mean_11_cqp_cqp(x, dim, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then + res = sum(x, dim) / real(size(x, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_11_cqp_cqp + module function mean_12_cqp_cqp(x, dim, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then + res = sum(x, dim) / real(size(x, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_12_cqp_cqp + module function mean_13_cqp_cqp(x, dim, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then + res = sum(x, dim) / real(size(x, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_13_cqp_cqp + module function mean_14_cqp_cqp(x, dim, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + res = sum(x, dim) / real(size(x, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_14_cqp_cqp + module function mean_15_cqp_cqp(x, dim, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + res = sum(x, dim) / real(size(x, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_15_cqp_cqp + + + module function mean_1_iint8_dp(x, dim, mask) result(res) + integer(int8), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + if (dim >= 1 .and. dim <= 1) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_1_iint8_dp + module function mean_2_iint8_dp(x, dim, mask) result(res) + integer(int8), intent(in) :: x(:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_2_iint8_dp + module function mean_3_iint8_dp(x, dim, mask) result(res) + integer(int8), intent(in) :: x(:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_3_iint8_dp + module function mean_4_iint8_dp(x, dim, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_4_iint8_dp + module function mean_5_iint8_dp(x, dim, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_5_iint8_dp + module function mean_6_iint8_dp(x, dim, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_6_iint8_dp + module function mean_7_iint8_dp(x, dim, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_7_iint8_dp + module function mean_8_iint8_dp(x, dim, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_8_iint8_dp + module function mean_9_iint8_dp(x, dim, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_9_iint8_dp + module function mean_10_iint8_dp(x, dim, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_10_iint8_dp + module function mean_11_iint8_dp(x, dim, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_11_iint8_dp + module function mean_12_iint8_dp(x, dim, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_12_iint8_dp + module function mean_13_iint8_dp(x, dim, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_13_iint8_dp + module function mean_14_iint8_dp(x, dim, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_14_iint8_dp + module function mean_15_iint8_dp(x, dim, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_15_iint8_dp + module function mean_1_iint16_dp(x, dim, mask) result(res) + integer(int16), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + if (dim >= 1 .and. dim <= 1) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_1_iint16_dp + module function mean_2_iint16_dp(x, dim, mask) result(res) + integer(int16), intent(in) :: x(:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_2_iint16_dp + module function mean_3_iint16_dp(x, dim, mask) result(res) + integer(int16), intent(in) :: x(:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_3_iint16_dp + module function mean_4_iint16_dp(x, dim, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_4_iint16_dp + module function mean_5_iint16_dp(x, dim, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_5_iint16_dp + module function mean_6_iint16_dp(x, dim, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_6_iint16_dp + module function mean_7_iint16_dp(x, dim, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_7_iint16_dp + module function mean_8_iint16_dp(x, dim, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_8_iint16_dp + module function mean_9_iint16_dp(x, dim, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_9_iint16_dp + module function mean_10_iint16_dp(x, dim, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_10_iint16_dp + module function mean_11_iint16_dp(x, dim, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_11_iint16_dp + module function mean_12_iint16_dp(x, dim, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_12_iint16_dp + module function mean_13_iint16_dp(x, dim, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_13_iint16_dp + module function mean_14_iint16_dp(x, dim, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_14_iint16_dp + module function mean_15_iint16_dp(x, dim, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_15_iint16_dp + module function mean_1_iint32_dp(x, dim, mask) result(res) + integer(int32), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + if (dim >= 1 .and. dim <= 1) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_1_iint32_dp + module function mean_2_iint32_dp(x, dim, mask) result(res) + integer(int32), intent(in) :: x(:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_2_iint32_dp + module function mean_3_iint32_dp(x, dim, mask) result(res) + integer(int32), intent(in) :: x(:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_3_iint32_dp + module function mean_4_iint32_dp(x, dim, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_4_iint32_dp + module function mean_5_iint32_dp(x, dim, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_5_iint32_dp + module function mean_6_iint32_dp(x, dim, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_6_iint32_dp + module function mean_7_iint32_dp(x, dim, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_7_iint32_dp + module function mean_8_iint32_dp(x, dim, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_8_iint32_dp + module function mean_9_iint32_dp(x, dim, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_9_iint32_dp + module function mean_10_iint32_dp(x, dim, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_10_iint32_dp + module function mean_11_iint32_dp(x, dim, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_11_iint32_dp + module function mean_12_iint32_dp(x, dim, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_12_iint32_dp + module function mean_13_iint32_dp(x, dim, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_13_iint32_dp + module function mean_14_iint32_dp(x, dim, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_14_iint32_dp + module function mean_15_iint32_dp(x, dim, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_15_iint32_dp + module function mean_1_iint64_dp(x, dim, mask) result(res) + integer(int64), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + if (dim >= 1 .and. dim <= 1) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_1_iint64_dp + module function mean_2_iint64_dp(x, dim, mask) result(res) + integer(int64), intent(in) :: x(:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_2_iint64_dp + module function mean_3_iint64_dp(x, dim, mask) result(res) + integer(int64), intent(in) :: x(:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_3_iint64_dp + module function mean_4_iint64_dp(x, dim, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_4_iint64_dp + module function mean_5_iint64_dp(x, dim, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_5_iint64_dp + module function mean_6_iint64_dp(x, dim, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_6_iint64_dp + module function mean_7_iint64_dp(x, dim, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_7_iint64_dp + module function mean_8_iint64_dp(x, dim, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_8_iint64_dp + module function mean_9_iint64_dp(x, dim, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_9_iint64_dp + module function mean_10_iint64_dp(x, dim, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_10_iint64_dp + module function mean_11_iint64_dp(x, dim, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_11_iint64_dp + module function mean_12_iint64_dp(x, dim, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_12_iint64_dp + module function mean_13_iint64_dp(x, dim, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_13_iint64_dp + module function mean_14_iint64_dp(x, dim, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_14_iint64_dp + module function mean_15_iint64_dp(x, dim, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + res = sum(real(x, dp), dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_15_iint64_dp + + module function mean_mask_all_1_rsp_rsp(x, mask) result(res) + real(sp), intent(in) :: x(:) + logical, intent(in) :: mask(:) + real(sp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), sp) + + end function mean_mask_all_1_rsp_rsp + module function mean_mask_all_2_rsp_rsp(x, mask) result(res) + real(sp), intent(in) :: x(:,:) + logical, intent(in) :: mask(:,:) + real(sp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), sp) + + end function mean_mask_all_2_rsp_rsp + module function mean_mask_all_3_rsp_rsp(x, mask) result(res) + real(sp), intent(in) :: x(:,:,:) + logical, intent(in) :: mask(:,:,:) + real(sp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), sp) + + end function mean_mask_all_3_rsp_rsp + module function mean_mask_all_4_rsp_rsp(x, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:) + logical, intent(in) :: mask(:,:,:,:) + real(sp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), sp) + + end function mean_mask_all_4_rsp_rsp + module function mean_mask_all_5_rsp_rsp(x, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:) + real(sp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), sp) + + end function mean_mask_all_5_rsp_rsp + module function mean_mask_all_6_rsp_rsp(x, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:) + real(sp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), sp) + + end function mean_mask_all_6_rsp_rsp + module function mean_mask_all_7_rsp_rsp(x, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:) + real(sp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), sp) + + end function mean_mask_all_7_rsp_rsp + module function mean_mask_all_8_rsp_rsp(x, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + real(sp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), sp) + + end function mean_mask_all_8_rsp_rsp + module function mean_mask_all_9_rsp_rsp(x, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + real(sp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), sp) + + end function mean_mask_all_9_rsp_rsp + module function mean_mask_all_10_rsp_rsp(x, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + real(sp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), sp) + + end function mean_mask_all_10_rsp_rsp + module function mean_mask_all_11_rsp_rsp(x, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + real(sp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), sp) + + end function mean_mask_all_11_rsp_rsp + module function mean_mask_all_12_rsp_rsp(x, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + real(sp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), sp) + + end function mean_mask_all_12_rsp_rsp + module function mean_mask_all_13_rsp_rsp(x, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + real(sp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), sp) + + end function mean_mask_all_13_rsp_rsp + module function mean_mask_all_14_rsp_rsp(x, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + real(sp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), sp) + + end function mean_mask_all_14_rsp_rsp + module function mean_mask_all_15_rsp_rsp(x, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + real(sp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), sp) + + end function mean_mask_all_15_rsp_rsp + module function mean_mask_all_1_rdp_rdp(x, mask) result(res) + real(dp), intent(in) :: x(:) + logical, intent(in) :: mask(:) + real(dp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_1_rdp_rdp + module function mean_mask_all_2_rdp_rdp(x, mask) result(res) + real(dp), intent(in) :: x(:,:) + logical, intent(in) :: mask(:,:) + real(dp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_2_rdp_rdp + module function mean_mask_all_3_rdp_rdp(x, mask) result(res) + real(dp), intent(in) :: x(:,:,:) + logical, intent(in) :: mask(:,:,:) + real(dp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_3_rdp_rdp + module function mean_mask_all_4_rdp_rdp(x, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:) + logical, intent(in) :: mask(:,:,:,:) + real(dp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_4_rdp_rdp + module function mean_mask_all_5_rdp_rdp(x, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:) + real(dp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_5_rdp_rdp + module function mean_mask_all_6_rdp_rdp(x, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:) + real(dp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_6_rdp_rdp + module function mean_mask_all_7_rdp_rdp(x, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:) + real(dp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_7_rdp_rdp + module function mean_mask_all_8_rdp_rdp(x, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + real(dp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_8_rdp_rdp + module function mean_mask_all_9_rdp_rdp(x, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + real(dp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_9_rdp_rdp + module function mean_mask_all_10_rdp_rdp(x, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + real(dp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_10_rdp_rdp + module function mean_mask_all_11_rdp_rdp(x, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_11_rdp_rdp + module function mean_mask_all_12_rdp_rdp(x, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_12_rdp_rdp + module function mean_mask_all_13_rdp_rdp(x, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_13_rdp_rdp + module function mean_mask_all_14_rdp_rdp(x, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_14_rdp_rdp + module function mean_mask_all_15_rdp_rdp(x, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_15_rdp_rdp + module function mean_mask_all_1_rqp_rqp(x, mask) result(res) + real(qp), intent(in) :: x(:) + logical, intent(in) :: mask(:) + real(qp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), qp) + + end function mean_mask_all_1_rqp_rqp + module function mean_mask_all_2_rqp_rqp(x, mask) result(res) + real(qp), intent(in) :: x(:,:) + logical, intent(in) :: mask(:,:) + real(qp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), qp) + + end function mean_mask_all_2_rqp_rqp + module function mean_mask_all_3_rqp_rqp(x, mask) result(res) + real(qp), intent(in) :: x(:,:,:) + logical, intent(in) :: mask(:,:,:) + real(qp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), qp) + + end function mean_mask_all_3_rqp_rqp + module function mean_mask_all_4_rqp_rqp(x, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:) + logical, intent(in) :: mask(:,:,:,:) + real(qp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), qp) + + end function mean_mask_all_4_rqp_rqp + module function mean_mask_all_5_rqp_rqp(x, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:) + real(qp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), qp) + + end function mean_mask_all_5_rqp_rqp + module function mean_mask_all_6_rqp_rqp(x, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:) + real(qp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), qp) + + end function mean_mask_all_6_rqp_rqp + module function mean_mask_all_7_rqp_rqp(x, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:) + real(qp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), qp) + + end function mean_mask_all_7_rqp_rqp + module function mean_mask_all_8_rqp_rqp(x, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + real(qp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), qp) + + end function mean_mask_all_8_rqp_rqp + module function mean_mask_all_9_rqp_rqp(x, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + real(qp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), qp) + + end function mean_mask_all_9_rqp_rqp + module function mean_mask_all_10_rqp_rqp(x, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + real(qp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), qp) + + end function mean_mask_all_10_rqp_rqp + module function mean_mask_all_11_rqp_rqp(x, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + real(qp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), qp) + + end function mean_mask_all_11_rqp_rqp + module function mean_mask_all_12_rqp_rqp(x, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + real(qp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), qp) + + end function mean_mask_all_12_rqp_rqp + module function mean_mask_all_13_rqp_rqp(x, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + real(qp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), qp) + + end function mean_mask_all_13_rqp_rqp + module function mean_mask_all_14_rqp_rqp(x, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + real(qp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), qp) + + end function mean_mask_all_14_rqp_rqp + module function mean_mask_all_15_rqp_rqp(x, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + real(qp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), qp) + + end function mean_mask_all_15_rqp_rqp + module function mean_mask_all_1_csp_csp(x, mask) result(res) + complex(sp), intent(in) :: x(:) + logical, intent(in) :: mask(:) + complex(sp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), sp) + + end function mean_mask_all_1_csp_csp + module function mean_mask_all_2_csp_csp(x, mask) result(res) + complex(sp), intent(in) :: x(:,:) + logical, intent(in) :: mask(:,:) + complex(sp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), sp) + + end function mean_mask_all_2_csp_csp + module function mean_mask_all_3_csp_csp(x, mask) result(res) + complex(sp), intent(in) :: x(:,:,:) + logical, intent(in) :: mask(:,:,:) + complex(sp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), sp) + + end function mean_mask_all_3_csp_csp + module function mean_mask_all_4_csp_csp(x, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:) + logical, intent(in) :: mask(:,:,:,:) + complex(sp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), sp) + + end function mean_mask_all_4_csp_csp + module function mean_mask_all_5_csp_csp(x, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:) + complex(sp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), sp) + + end function mean_mask_all_5_csp_csp + module function mean_mask_all_6_csp_csp(x, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:) + complex(sp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), sp) + + end function mean_mask_all_6_csp_csp + module function mean_mask_all_7_csp_csp(x, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:) + complex(sp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), sp) + + end function mean_mask_all_7_csp_csp + module function mean_mask_all_8_csp_csp(x, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + complex(sp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), sp) + + end function mean_mask_all_8_csp_csp + module function mean_mask_all_9_csp_csp(x, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + complex(sp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), sp) + + end function mean_mask_all_9_csp_csp + module function mean_mask_all_10_csp_csp(x, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + complex(sp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), sp) + + end function mean_mask_all_10_csp_csp + module function mean_mask_all_11_csp_csp(x, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + complex(sp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), sp) + + end function mean_mask_all_11_csp_csp + module function mean_mask_all_12_csp_csp(x, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + complex(sp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), sp) + + end function mean_mask_all_12_csp_csp + module function mean_mask_all_13_csp_csp(x, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + complex(sp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), sp) + + end function mean_mask_all_13_csp_csp + module function mean_mask_all_14_csp_csp(x, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + complex(sp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), sp) + + end function mean_mask_all_14_csp_csp + module function mean_mask_all_15_csp_csp(x, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + complex(sp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), sp) + + end function mean_mask_all_15_csp_csp + module function mean_mask_all_1_cdp_cdp(x, mask) result(res) + complex(dp), intent(in) :: x(:) + logical, intent(in) :: mask(:) + complex(dp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_1_cdp_cdp + module function mean_mask_all_2_cdp_cdp(x, mask) result(res) + complex(dp), intent(in) :: x(:,:) + logical, intent(in) :: mask(:,:) + complex(dp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_2_cdp_cdp + module function mean_mask_all_3_cdp_cdp(x, mask) result(res) + complex(dp), intent(in) :: x(:,:,:) + logical, intent(in) :: mask(:,:,:) + complex(dp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_3_cdp_cdp + module function mean_mask_all_4_cdp_cdp(x, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:) + logical, intent(in) :: mask(:,:,:,:) + complex(dp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_4_cdp_cdp + module function mean_mask_all_5_cdp_cdp(x, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:) + complex(dp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_5_cdp_cdp + module function mean_mask_all_6_cdp_cdp(x, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:) + complex(dp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_6_cdp_cdp + module function mean_mask_all_7_cdp_cdp(x, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:) + complex(dp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_7_cdp_cdp + module function mean_mask_all_8_cdp_cdp(x, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + complex(dp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_8_cdp_cdp + module function mean_mask_all_9_cdp_cdp(x, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + complex(dp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_9_cdp_cdp + module function mean_mask_all_10_cdp_cdp(x, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + complex(dp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_10_cdp_cdp + module function mean_mask_all_11_cdp_cdp(x, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + complex(dp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_11_cdp_cdp + module function mean_mask_all_12_cdp_cdp(x, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + complex(dp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_12_cdp_cdp + module function mean_mask_all_13_cdp_cdp(x, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + complex(dp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_13_cdp_cdp + module function mean_mask_all_14_cdp_cdp(x, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + complex(dp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_14_cdp_cdp + module function mean_mask_all_15_cdp_cdp(x, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + complex(dp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_15_cdp_cdp + module function mean_mask_all_1_cqp_cqp(x, mask) result(res) + complex(qp), intent(in) :: x(:) + logical, intent(in) :: mask(:) + complex(qp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), qp) + + end function mean_mask_all_1_cqp_cqp + module function mean_mask_all_2_cqp_cqp(x, mask) result(res) + complex(qp), intent(in) :: x(:,:) + logical, intent(in) :: mask(:,:) + complex(qp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), qp) + + end function mean_mask_all_2_cqp_cqp + module function mean_mask_all_3_cqp_cqp(x, mask) result(res) + complex(qp), intent(in) :: x(:,:,:) + logical, intent(in) :: mask(:,:,:) + complex(qp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), qp) + + end function mean_mask_all_3_cqp_cqp + module function mean_mask_all_4_cqp_cqp(x, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:) + logical, intent(in) :: mask(:,:,:,:) + complex(qp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), qp) + + end function mean_mask_all_4_cqp_cqp + module function mean_mask_all_5_cqp_cqp(x, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:) + complex(qp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), qp) + + end function mean_mask_all_5_cqp_cqp + module function mean_mask_all_6_cqp_cqp(x, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:) + complex(qp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), qp) + + end function mean_mask_all_6_cqp_cqp + module function mean_mask_all_7_cqp_cqp(x, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:) + complex(qp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), qp) + + end function mean_mask_all_7_cqp_cqp + module function mean_mask_all_8_cqp_cqp(x, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + complex(qp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), qp) + + end function mean_mask_all_8_cqp_cqp + module function mean_mask_all_9_cqp_cqp(x, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + complex(qp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), qp) + + end function mean_mask_all_9_cqp_cqp + module function mean_mask_all_10_cqp_cqp(x, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + complex(qp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), qp) + + end function mean_mask_all_10_cqp_cqp + module function mean_mask_all_11_cqp_cqp(x, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + complex(qp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), qp) + + end function mean_mask_all_11_cqp_cqp + module function mean_mask_all_12_cqp_cqp(x, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + complex(qp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), qp) + + end function mean_mask_all_12_cqp_cqp + module function mean_mask_all_13_cqp_cqp(x, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + complex(qp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), qp) + + end function mean_mask_all_13_cqp_cqp + module function mean_mask_all_14_cqp_cqp(x, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + complex(qp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), qp) + + end function mean_mask_all_14_cqp_cqp + module function mean_mask_all_15_cqp_cqp(x, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + complex(qp) :: res + + res = sum(x, mask) / real(count(mask, kind = int64), qp) + + end function mean_mask_all_15_cqp_cqp + + + module function mean_mask_all_1_iint8_dp(x, mask) result(res) + integer(int8), intent(in) :: x(:) + logical, intent(in) :: mask(:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_1_iint8_dp + module function mean_mask_all_2_iint8_dp(x, mask) result(res) + integer(int8), intent(in) :: x(:,:) + logical, intent(in) :: mask(:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_2_iint8_dp + module function mean_mask_all_3_iint8_dp(x, mask) result(res) + integer(int8), intent(in) :: x(:,:,:) + logical, intent(in) :: mask(:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_3_iint8_dp + module function mean_mask_all_4_iint8_dp(x, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:) + logical, intent(in) :: mask(:,:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_4_iint8_dp + module function mean_mask_all_5_iint8_dp(x, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_5_iint8_dp + module function mean_mask_all_6_iint8_dp(x, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_6_iint8_dp + module function mean_mask_all_7_iint8_dp(x, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_7_iint8_dp + module function mean_mask_all_8_iint8_dp(x, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_8_iint8_dp + module function mean_mask_all_9_iint8_dp(x, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_9_iint8_dp + module function mean_mask_all_10_iint8_dp(x, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_10_iint8_dp + module function mean_mask_all_11_iint8_dp(x, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_11_iint8_dp + module function mean_mask_all_12_iint8_dp(x, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_12_iint8_dp + module function mean_mask_all_13_iint8_dp(x, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_13_iint8_dp + module function mean_mask_all_14_iint8_dp(x, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_14_iint8_dp + module function mean_mask_all_15_iint8_dp(x, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_15_iint8_dp + module function mean_mask_all_1_iint16_dp(x, mask) result(res) + integer(int16), intent(in) :: x(:) + logical, intent(in) :: mask(:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_1_iint16_dp + module function mean_mask_all_2_iint16_dp(x, mask) result(res) + integer(int16), intent(in) :: x(:,:) + logical, intent(in) :: mask(:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_2_iint16_dp + module function mean_mask_all_3_iint16_dp(x, mask) result(res) + integer(int16), intent(in) :: x(:,:,:) + logical, intent(in) :: mask(:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_3_iint16_dp + module function mean_mask_all_4_iint16_dp(x, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:) + logical, intent(in) :: mask(:,:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_4_iint16_dp + module function mean_mask_all_5_iint16_dp(x, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_5_iint16_dp + module function mean_mask_all_6_iint16_dp(x, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_6_iint16_dp + module function mean_mask_all_7_iint16_dp(x, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_7_iint16_dp + module function mean_mask_all_8_iint16_dp(x, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_8_iint16_dp + module function mean_mask_all_9_iint16_dp(x, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_9_iint16_dp + module function mean_mask_all_10_iint16_dp(x, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_10_iint16_dp + module function mean_mask_all_11_iint16_dp(x, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_11_iint16_dp + module function mean_mask_all_12_iint16_dp(x, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_12_iint16_dp + module function mean_mask_all_13_iint16_dp(x, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_13_iint16_dp + module function mean_mask_all_14_iint16_dp(x, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_14_iint16_dp + module function mean_mask_all_15_iint16_dp(x, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_15_iint16_dp + module function mean_mask_all_1_iint32_dp(x, mask) result(res) + integer(int32), intent(in) :: x(:) + logical, intent(in) :: mask(:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_1_iint32_dp + module function mean_mask_all_2_iint32_dp(x, mask) result(res) + integer(int32), intent(in) :: x(:,:) + logical, intent(in) :: mask(:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_2_iint32_dp + module function mean_mask_all_3_iint32_dp(x, mask) result(res) + integer(int32), intent(in) :: x(:,:,:) + logical, intent(in) :: mask(:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_3_iint32_dp + module function mean_mask_all_4_iint32_dp(x, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:) + logical, intent(in) :: mask(:,:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_4_iint32_dp + module function mean_mask_all_5_iint32_dp(x, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_5_iint32_dp + module function mean_mask_all_6_iint32_dp(x, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_6_iint32_dp + module function mean_mask_all_7_iint32_dp(x, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_7_iint32_dp + module function mean_mask_all_8_iint32_dp(x, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_8_iint32_dp + module function mean_mask_all_9_iint32_dp(x, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_9_iint32_dp + module function mean_mask_all_10_iint32_dp(x, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_10_iint32_dp + module function mean_mask_all_11_iint32_dp(x, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_11_iint32_dp + module function mean_mask_all_12_iint32_dp(x, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_12_iint32_dp + module function mean_mask_all_13_iint32_dp(x, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_13_iint32_dp + module function mean_mask_all_14_iint32_dp(x, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_14_iint32_dp + module function mean_mask_all_15_iint32_dp(x, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_15_iint32_dp + module function mean_mask_all_1_iint64_dp(x, mask) result(res) + integer(int64), intent(in) :: x(:) + logical, intent(in) :: mask(:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_1_iint64_dp + module function mean_mask_all_2_iint64_dp(x, mask) result(res) + integer(int64), intent(in) :: x(:,:) + logical, intent(in) :: mask(:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_2_iint64_dp + module function mean_mask_all_3_iint64_dp(x, mask) result(res) + integer(int64), intent(in) :: x(:,:,:) + logical, intent(in) :: mask(:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_3_iint64_dp + module function mean_mask_all_4_iint64_dp(x, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:) + logical, intent(in) :: mask(:,:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_4_iint64_dp + module function mean_mask_all_5_iint64_dp(x, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_5_iint64_dp + module function mean_mask_all_6_iint64_dp(x, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_6_iint64_dp + module function mean_mask_all_7_iint64_dp(x, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_7_iint64_dp + module function mean_mask_all_8_iint64_dp(x, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_8_iint64_dp + module function mean_mask_all_9_iint64_dp(x, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_9_iint64_dp + module function mean_mask_all_10_iint64_dp(x, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_10_iint64_dp + module function mean_mask_all_11_iint64_dp(x, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_11_iint64_dp + module function mean_mask_all_12_iint64_dp(x, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_12_iint64_dp + module function mean_mask_all_13_iint64_dp(x, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_13_iint64_dp + module function mean_mask_all_14_iint64_dp(x, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_14_iint64_dp + module function mean_mask_all_15_iint64_dp(x, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res + + res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) + + end function mean_mask_all_15_iint64_dp + + module function mean_mask_1_rsp_rsp(x, dim, mask) result(res) + real(sp), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:) + real(sp) :: res + + if (dim >= 1 .and. dim <= 1) then + res = sum(x, dim, mask) / real(count(mask, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_1_rsp_rsp + module function mean_mask_2_rsp_rsp(x, dim, mask) result(res) + real(sp), intent(in) :: x(:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:) + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then + res = sum(x, dim, mask) / real(count(mask, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_2_rsp_rsp + module function mean_mask_3_rsp_rsp(x, dim, mask) result(res) + real(sp), intent(in) :: x(:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:) + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then + res = sum(x, dim, mask) / real(count(mask, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_3_rsp_rsp + module function mean_mask_4_rsp_rsp(x, dim, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:) + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then + res = sum(x, dim, mask) / real(count(mask, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_4_rsp_rsp + module function mean_mask_5_rsp_rsp(x, dim, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:) + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then + res = sum(x, dim, mask) / real(count(mask, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_5_rsp_rsp + module function mean_mask_6_rsp_rsp(x, dim, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:) + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then + res = sum(x, dim, mask) / real(count(mask, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_6_rsp_rsp + module function mean_mask_7_rsp_rsp(x, dim, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:) + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then + res = sum(x, dim, mask) / real(count(mask, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_7_rsp_rsp + module function mean_mask_8_rsp_rsp(x, dim, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then + res = sum(x, dim, mask) / real(count(mask, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_8_rsp_rsp + module function mean_mask_9_rsp_rsp(x, dim, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then + res = sum(x, dim, mask) / real(count(mask, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_9_rsp_rsp + module function mean_mask_10_rsp_rsp(x, dim, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then + res = sum(x, dim, mask) / real(count(mask, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_10_rsp_rsp + module function mean_mask_11_rsp_rsp(x, dim, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then + res = sum(x, dim, mask) / real(count(mask, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_11_rsp_rsp + module function mean_mask_12_rsp_rsp(x, dim, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then + res = sum(x, dim, mask) / real(count(mask, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_12_rsp_rsp + module function mean_mask_13_rsp_rsp(x, dim, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then + res = sum(x, dim, mask) / real(count(mask, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_13_rsp_rsp + module function mean_mask_14_rsp_rsp(x, dim, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + res = sum(x, dim, mask) / real(count(mask, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_14_rsp_rsp + module function mean_mask_15_rsp_rsp(x, dim, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + res = sum(x, dim, mask) / real(count(mask, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_15_rsp_rsp + module function mean_mask_1_rdp_rdp(x, dim, mask) result(res) + real(dp), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:) + real(dp) :: res + + if (dim >= 1 .and. dim <= 1) then + res = sum(x, dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_1_rdp_rdp + module function mean_mask_2_rdp_rdp(x, dim, mask) result(res) + real(dp), intent(in) :: x(:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then + res = sum(x, dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_2_rdp_rdp + module function mean_mask_3_rdp_rdp(x, dim, mask) result(res) + real(dp), intent(in) :: x(:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then + res = sum(x, dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_3_rdp_rdp + module function mean_mask_4_rdp_rdp(x, dim, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then + res = sum(x, dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_4_rdp_rdp + module function mean_mask_5_rdp_rdp(x, dim, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then + res = sum(x, dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_5_rdp_rdp + module function mean_mask_6_rdp_rdp(x, dim, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then + res = sum(x, dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_6_rdp_rdp + module function mean_mask_7_rdp_rdp(x, dim, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then + res = sum(x, dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_7_rdp_rdp + module function mean_mask_8_rdp_rdp(x, dim, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then + res = sum(x, dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_8_rdp_rdp + module function mean_mask_9_rdp_rdp(x, dim, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then + res = sum(x, dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_9_rdp_rdp + module function mean_mask_10_rdp_rdp(x, dim, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then + res = sum(x, dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_10_rdp_rdp + module function mean_mask_11_rdp_rdp(x, dim, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then + res = sum(x, dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_11_rdp_rdp + module function mean_mask_12_rdp_rdp(x, dim, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then + res = sum(x, dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_12_rdp_rdp + module function mean_mask_13_rdp_rdp(x, dim, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then + res = sum(x, dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_13_rdp_rdp + module function mean_mask_14_rdp_rdp(x, dim, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + res = sum(x, dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_14_rdp_rdp + module function mean_mask_15_rdp_rdp(x, dim, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + res = sum(x, dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_15_rdp_rdp + module function mean_mask_1_rqp_rqp(x, dim, mask) result(res) + real(qp), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:) + real(qp) :: res + + if (dim >= 1 .and. dim <= 1) then + res = sum(x, dim, mask) / real(count(mask, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_1_rqp_rqp + module function mean_mask_2_rqp_rqp(x, dim, mask) result(res) + real(qp), intent(in) :: x(:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:) + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then + res = sum(x, dim, mask) / real(count(mask, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_2_rqp_rqp + module function mean_mask_3_rqp_rqp(x, dim, mask) result(res) + real(qp), intent(in) :: x(:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:) + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then + res = sum(x, dim, mask) / real(count(mask, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_3_rqp_rqp + module function mean_mask_4_rqp_rqp(x, dim, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:) + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then + res = sum(x, dim, mask) / real(count(mask, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_4_rqp_rqp + module function mean_mask_5_rqp_rqp(x, dim, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:) + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then + res = sum(x, dim, mask) / real(count(mask, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_5_rqp_rqp + module function mean_mask_6_rqp_rqp(x, dim, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:) + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then + res = sum(x, dim, mask) / real(count(mask, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_6_rqp_rqp + module function mean_mask_7_rqp_rqp(x, dim, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:) + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then + res = sum(x, dim, mask) / real(count(mask, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_7_rqp_rqp + module function mean_mask_8_rqp_rqp(x, dim, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then + res = sum(x, dim, mask) / real(count(mask, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_8_rqp_rqp + module function mean_mask_9_rqp_rqp(x, dim, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then + res = sum(x, dim, mask) / real(count(mask, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_9_rqp_rqp + module function mean_mask_10_rqp_rqp(x, dim, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then + res = sum(x, dim, mask) / real(count(mask, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_10_rqp_rqp + module function mean_mask_11_rqp_rqp(x, dim, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then + res = sum(x, dim, mask) / real(count(mask, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_11_rqp_rqp + module function mean_mask_12_rqp_rqp(x, dim, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then + res = sum(x, dim, mask) / real(count(mask, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_12_rqp_rqp + module function mean_mask_13_rqp_rqp(x, dim, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then + res = sum(x, dim, mask) / real(count(mask, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_13_rqp_rqp + module function mean_mask_14_rqp_rqp(x, dim, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + res = sum(x, dim, mask) / real(count(mask, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_14_rqp_rqp + module function mean_mask_15_rqp_rqp(x, dim, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + res = sum(x, dim, mask) / real(count(mask, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_15_rqp_rqp + module function mean_mask_1_csp_csp(x, dim, mask) result(res) + complex(sp), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:) + complex(sp) :: res + + if (dim >= 1 .and. dim <= 1) then + res = sum(x, dim, mask) / real(count(mask, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_1_csp_csp + module function mean_mask_2_csp_csp(x, dim, mask) result(res) + complex(sp), intent(in) :: x(:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:) + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then + res = sum(x, dim, mask) / real(count(mask, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_2_csp_csp + module function mean_mask_3_csp_csp(x, dim, mask) result(res) + complex(sp), intent(in) :: x(:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:) + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then + res = sum(x, dim, mask) / real(count(mask, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_3_csp_csp + module function mean_mask_4_csp_csp(x, dim, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:) + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then + res = sum(x, dim, mask) / real(count(mask, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_4_csp_csp + module function mean_mask_5_csp_csp(x, dim, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:) + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then + res = sum(x, dim, mask) / real(count(mask, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_5_csp_csp + module function mean_mask_6_csp_csp(x, dim, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:) + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then + res = sum(x, dim, mask) / real(count(mask, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_6_csp_csp + module function mean_mask_7_csp_csp(x, dim, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:) + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then + res = sum(x, dim, mask) / real(count(mask, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_7_csp_csp + module function mean_mask_8_csp_csp(x, dim, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then + res = sum(x, dim, mask) / real(count(mask, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_8_csp_csp + module function mean_mask_9_csp_csp(x, dim, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then + res = sum(x, dim, mask) / real(count(mask, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_9_csp_csp + module function mean_mask_10_csp_csp(x, dim, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then + res = sum(x, dim, mask) / real(count(mask, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_10_csp_csp + module function mean_mask_11_csp_csp(x, dim, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then + res = sum(x, dim, mask) / real(count(mask, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_11_csp_csp + module function mean_mask_12_csp_csp(x, dim, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then + res = sum(x, dim, mask) / real(count(mask, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_12_csp_csp + module function mean_mask_13_csp_csp(x, dim, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then + res = sum(x, dim, mask) / real(count(mask, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_13_csp_csp + module function mean_mask_14_csp_csp(x, dim, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + res = sum(x, dim, mask) / real(count(mask, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_14_csp_csp + module function mean_mask_15_csp_csp(x, dim, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + res = sum(x, dim, mask) / real(count(mask, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_15_csp_csp + module function mean_mask_1_cdp_cdp(x, dim, mask) result(res) + complex(dp), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:) + complex(dp) :: res + + if (dim >= 1 .and. dim <= 1) then + res = sum(x, dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_1_cdp_cdp + module function mean_mask_2_cdp_cdp(x, dim, mask) result(res) + complex(dp), intent(in) :: x(:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:) + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then + res = sum(x, dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_2_cdp_cdp + module function mean_mask_3_cdp_cdp(x, dim, mask) result(res) + complex(dp), intent(in) :: x(:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:) + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then + res = sum(x, dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_3_cdp_cdp + module function mean_mask_4_cdp_cdp(x, dim, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:) + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then + res = sum(x, dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_4_cdp_cdp + module function mean_mask_5_cdp_cdp(x, dim, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:) + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then + res = sum(x, dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_5_cdp_cdp + module function mean_mask_6_cdp_cdp(x, dim, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:) + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then + res = sum(x, dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_6_cdp_cdp + module function mean_mask_7_cdp_cdp(x, dim, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:) + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then + res = sum(x, dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_7_cdp_cdp + module function mean_mask_8_cdp_cdp(x, dim, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then + res = sum(x, dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_8_cdp_cdp + module function mean_mask_9_cdp_cdp(x, dim, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then + res = sum(x, dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_9_cdp_cdp + module function mean_mask_10_cdp_cdp(x, dim, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then + res = sum(x, dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_10_cdp_cdp + module function mean_mask_11_cdp_cdp(x, dim, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then + res = sum(x, dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_11_cdp_cdp + module function mean_mask_12_cdp_cdp(x, dim, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then + res = sum(x, dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_12_cdp_cdp + module function mean_mask_13_cdp_cdp(x, dim, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then + res = sum(x, dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_13_cdp_cdp + module function mean_mask_14_cdp_cdp(x, dim, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + res = sum(x, dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_14_cdp_cdp + module function mean_mask_15_cdp_cdp(x, dim, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + res = sum(x, dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_15_cdp_cdp + module function mean_mask_1_cqp_cqp(x, dim, mask) result(res) + complex(qp), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:) + complex(qp) :: res + + if (dim >= 1 .and. dim <= 1) then + res = sum(x, dim, mask) / real(count(mask, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_1_cqp_cqp + module function mean_mask_2_cqp_cqp(x, dim, mask) result(res) + complex(qp), intent(in) :: x(:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:) + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then + res = sum(x, dim, mask) / real(count(mask, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_2_cqp_cqp + module function mean_mask_3_cqp_cqp(x, dim, mask) result(res) + complex(qp), intent(in) :: x(:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:) + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then + res = sum(x, dim, mask) / real(count(mask, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_3_cqp_cqp + module function mean_mask_4_cqp_cqp(x, dim, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:) + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then + res = sum(x, dim, mask) / real(count(mask, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_4_cqp_cqp + module function mean_mask_5_cqp_cqp(x, dim, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:) + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then + res = sum(x, dim, mask) / real(count(mask, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_5_cqp_cqp + module function mean_mask_6_cqp_cqp(x, dim, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:) + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then + res = sum(x, dim, mask) / real(count(mask, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_6_cqp_cqp + module function mean_mask_7_cqp_cqp(x, dim, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:) + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then + res = sum(x, dim, mask) / real(count(mask, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_7_cqp_cqp + module function mean_mask_8_cqp_cqp(x, dim, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then + res = sum(x, dim, mask) / real(count(mask, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_8_cqp_cqp + module function mean_mask_9_cqp_cqp(x, dim, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then + res = sum(x, dim, mask) / real(count(mask, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_9_cqp_cqp + module function mean_mask_10_cqp_cqp(x, dim, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then + res = sum(x, dim, mask) / real(count(mask, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_10_cqp_cqp + module function mean_mask_11_cqp_cqp(x, dim, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then + res = sum(x, dim, mask) / real(count(mask, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_11_cqp_cqp + module function mean_mask_12_cqp_cqp(x, dim, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then + res = sum(x, dim, mask) / real(count(mask, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_12_cqp_cqp + module function mean_mask_13_cqp_cqp(x, dim, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then + res = sum(x, dim, mask) / real(count(mask, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_13_cqp_cqp + module function mean_mask_14_cqp_cqp(x, dim, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + res = sum(x, dim, mask) / real(count(mask, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_14_cqp_cqp + module function mean_mask_15_cqp_cqp(x, dim, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + res = sum(x, dim, mask) / real(count(mask, dim), qp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_15_cqp_cqp + + + module function mean_mask_1_iint8_dp(x, dim, mask) result(res) + integer(int8), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:) + real(dp) :: res + + if (dim >= 1 .and. dim <= 1) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_1_iint8_dp + module function mean_mask_2_iint8_dp(x, dim, mask) result(res) + integer(int8), intent(in) :: x(:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_2_iint8_dp + module function mean_mask_3_iint8_dp(x, dim, mask) result(res) + integer(int8), intent(in) :: x(:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_3_iint8_dp + module function mean_mask_4_iint8_dp(x, dim, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_4_iint8_dp + module function mean_mask_5_iint8_dp(x, dim, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_5_iint8_dp + module function mean_mask_6_iint8_dp(x, dim, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_6_iint8_dp + module function mean_mask_7_iint8_dp(x, dim, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_7_iint8_dp + module function mean_mask_8_iint8_dp(x, dim, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_8_iint8_dp + module function mean_mask_9_iint8_dp(x, dim, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_9_iint8_dp + module function mean_mask_10_iint8_dp(x, dim, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_10_iint8_dp + module function mean_mask_11_iint8_dp(x, dim, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_11_iint8_dp + module function mean_mask_12_iint8_dp(x, dim, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_12_iint8_dp + module function mean_mask_13_iint8_dp(x, dim, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_13_iint8_dp + module function mean_mask_14_iint8_dp(x, dim, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_14_iint8_dp + module function mean_mask_15_iint8_dp(x, dim, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_15_iint8_dp + module function mean_mask_1_iint16_dp(x, dim, mask) result(res) + integer(int16), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:) + real(dp) :: res + + if (dim >= 1 .and. dim <= 1) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_1_iint16_dp + module function mean_mask_2_iint16_dp(x, dim, mask) result(res) + integer(int16), intent(in) :: x(:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_2_iint16_dp + module function mean_mask_3_iint16_dp(x, dim, mask) result(res) + integer(int16), intent(in) :: x(:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_3_iint16_dp + module function mean_mask_4_iint16_dp(x, dim, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_4_iint16_dp + module function mean_mask_5_iint16_dp(x, dim, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_5_iint16_dp + module function mean_mask_6_iint16_dp(x, dim, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_6_iint16_dp + module function mean_mask_7_iint16_dp(x, dim, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_7_iint16_dp + module function mean_mask_8_iint16_dp(x, dim, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_8_iint16_dp + module function mean_mask_9_iint16_dp(x, dim, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_9_iint16_dp + module function mean_mask_10_iint16_dp(x, dim, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_10_iint16_dp + module function mean_mask_11_iint16_dp(x, dim, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_11_iint16_dp + module function mean_mask_12_iint16_dp(x, dim, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_12_iint16_dp + module function mean_mask_13_iint16_dp(x, dim, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_13_iint16_dp + module function mean_mask_14_iint16_dp(x, dim, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_14_iint16_dp + module function mean_mask_15_iint16_dp(x, dim, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_15_iint16_dp + module function mean_mask_1_iint32_dp(x, dim, mask) result(res) + integer(int32), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:) + real(dp) :: res + + if (dim >= 1 .and. dim <= 1) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_1_iint32_dp + module function mean_mask_2_iint32_dp(x, dim, mask) result(res) + integer(int32), intent(in) :: x(:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_2_iint32_dp + module function mean_mask_3_iint32_dp(x, dim, mask) result(res) + integer(int32), intent(in) :: x(:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_3_iint32_dp + module function mean_mask_4_iint32_dp(x, dim, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_4_iint32_dp + module function mean_mask_5_iint32_dp(x, dim, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_5_iint32_dp + module function mean_mask_6_iint32_dp(x, dim, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_6_iint32_dp + module function mean_mask_7_iint32_dp(x, dim, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_7_iint32_dp + module function mean_mask_8_iint32_dp(x, dim, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_8_iint32_dp + module function mean_mask_9_iint32_dp(x, dim, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_9_iint32_dp + module function mean_mask_10_iint32_dp(x, dim, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_10_iint32_dp + module function mean_mask_11_iint32_dp(x, dim, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_11_iint32_dp + module function mean_mask_12_iint32_dp(x, dim, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_12_iint32_dp + module function mean_mask_13_iint32_dp(x, dim, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_13_iint32_dp + module function mean_mask_14_iint32_dp(x, dim, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_14_iint32_dp + module function mean_mask_15_iint32_dp(x, dim, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_15_iint32_dp + module function mean_mask_1_iint64_dp(x, dim, mask) result(res) + integer(int64), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:) + real(dp) :: res + + if (dim >= 1 .and. dim <= 1) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_1_iint64_dp + module function mean_mask_2_iint64_dp(x, dim, mask) result(res) + integer(int64), intent(in) :: x(:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_2_iint64_dp + module function mean_mask_3_iint64_dp(x, dim, mask) result(res) + integer(int64), intent(in) :: x(:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_3_iint64_dp + module function mean_mask_4_iint64_dp(x, dim, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_4_iint64_dp + module function mean_mask_5_iint64_dp(x, dim, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_5_iint64_dp + module function mean_mask_6_iint64_dp(x, dim, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_6_iint64_dp + module function mean_mask_7_iint64_dp(x, dim, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_7_iint64_dp + module function mean_mask_8_iint64_dp(x, dim, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_8_iint64_dp + module function mean_mask_9_iint64_dp(x, dim, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_9_iint64_dp + module function mean_mask_10_iint64_dp(x, dim, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_10_iint64_dp + module function mean_mask_11_iint64_dp(x, dim, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_11_iint64_dp + module function mean_mask_12_iint64_dp(x, dim, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_12_iint64_dp + module function mean_mask_13_iint64_dp(x, dim, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_13_iint64_dp + module function mean_mask_14_iint64_dp(x, dim, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_14_iint64_dp + module function mean_mask_15_iint64_dp(x, dim, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if + + end function mean_mask_15_iint64_dp + +end submodule diff --git a/src/fpm/stdlib_stats_moment.f90 b/src/fpm/stdlib_stats_moment.f90 new file mode 100644 index 000000000..419855c8f --- /dev/null +++ b/src/fpm/stdlib_stats_moment.f90 @@ -0,0 +1,19653 @@ +submodule (stdlib_stats) stdlib_stats_moment + + use, intrinsic:: ieee_arithmetic, only: ieee_value, ieee_quiet_nan + use stdlib_error, only: error_stop + use stdlib_optval, only: optval + implicit none + +contains + + module function moment_1_rsp_rsp(x, order, dim, center, mask) result(res) + real(sp), intent(in) :: x(:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(sp), intent(in), optional :: center + logical, intent(in), optional :: mask + real(sp) :: res + + integer :: i + real(sp) :: n + real(sp), allocatable :: mean_ + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + n = real(size(x, dim), sp) + + res = 0 + select case(dim) + case(1) + if (present(center)) then + do i = 1, size(x, 1) + res = res + (x(i) - center)**order + end do + else + allocate(mean_, source = mean(x, 1)) + do i = 1, size(x, 1) + res = res + (x(i) - mean_)**order + end do + deallocate(mean_) + end if + case default + call error_stop("ERROR (moment): wrong dimension") + end select + res = res / n + + end function moment_1_rsp_rsp + module function moment_2_rsp_rsp(x, order, dim, center, mask) result(res) + real(sp), intent(in) :: x(:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(sp), intent(in), optional :: center(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_2_rsp_rsp + module function moment_scalar_3_rsp_rsp(x, order, dim, center, mask) result(res) + real(sp), intent(in) :: x(:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(sp), intent(in) :: center + logical, intent(in), optional :: mask + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_3_rsp_rsp + module function moment_scalar_4_rsp_rsp(x, order, dim, center, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(sp), intent(in) :: center + logical, intent(in), optional :: mask + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_4_rsp_rsp + module function moment_scalar_5_rsp_rsp(x, order, dim, center, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(sp), intent(in) :: center + logical, intent(in), optional :: mask + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_5_rsp_rsp + module function moment_scalar_6_rsp_rsp(x, order, dim, center, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(sp), intent(in) :: center + logical, intent(in), optional :: mask + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_6_rsp_rsp + module function moment_scalar_7_rsp_rsp(x, order, dim, center, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(sp), intent(in) :: center + logical, intent(in), optional :: mask + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_7_rsp_rsp + module function moment_scalar_8_rsp_rsp(x, order, dim, center, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(sp), intent(in) :: center + logical, intent(in), optional :: mask + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_8_rsp_rsp + module function moment_scalar_9_rsp_rsp(x, order, dim, center, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(sp), intent(in) :: center + logical, intent(in), optional :: mask + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_9_rsp_rsp + module function moment_scalar_10_rsp_rsp(x, order, dim, center, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(sp), intent(in) :: center + logical, intent(in), optional :: mask + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_10_rsp_rsp + module function moment_scalar_11_rsp_rsp(x, order, dim, center, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(sp), intent(in) :: center + logical, intent(in), optional :: mask + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_11_rsp_rsp + module function moment_scalar_12_rsp_rsp(x, order, dim, center, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(sp), intent(in) :: center + logical, intent(in), optional :: mask + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_12_rsp_rsp + module function moment_scalar_13_rsp_rsp(x, order, dim, center, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(sp), intent(in) :: center + logical, intent(in), optional :: mask + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_13_rsp_rsp + module function moment_scalar_14_rsp_rsp(x, order, dim, center, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(sp), intent(in) :: center + logical, intent(in), optional :: mask + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_14_rsp_rsp + module function moment_scalar_15_rsp_rsp(x, order, dim, center, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(sp), intent(in) :: center + logical, intent(in), optional :: mask + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_15_rsp_rsp + module function moment_scalar_2_rdp_rdp(x, order, dim, center, mask) result(res) + real(dp), intent(in) :: x(:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_2_rdp_rdp + module function moment_scalar_3_rdp_rdp(x, order, dim, center, mask) result(res) + real(dp), intent(in) :: x(:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_3_rdp_rdp + module function moment_scalar_4_rdp_rdp(x, order, dim, center, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_4_rdp_rdp + module function moment_scalar_5_rdp_rdp(x, order, dim, center, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_5_rdp_rdp + module function moment_scalar_6_rdp_rdp(x, order, dim, center, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_6_rdp_rdp + module function moment_scalar_7_rdp_rdp(x, order, dim, center, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_7_rdp_rdp + module function moment_scalar_8_rdp_rdp(x, order, dim, center, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_8_rdp_rdp + module function moment_scalar_9_rdp_rdp(x, order, dim, center, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_9_rdp_rdp + module function moment_scalar_10_rdp_rdp(x, order, dim, center, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_10_rdp_rdp + module function moment_scalar_11_rdp_rdp(x, order, dim, center, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_11_rdp_rdp + module function moment_scalar_12_rdp_rdp(x, order, dim, center, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_12_rdp_rdp + module function moment_scalar_13_rdp_rdp(x, order, dim, center, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_13_rdp_rdp + module function moment_scalar_14_rdp_rdp(x, order, dim, center, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_14_rdp_rdp + module function moment_scalar_15_rdp_rdp(x, order, dim, center, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_15_rdp_rdp + module function moment_scalar_2_rqp_rqp(x, order, dim, center, mask) result(res) + real(qp), intent(in) :: x(:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(qp), intent(in) :: center + logical, intent(in), optional :: mask + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_2_rqp_rqp + module function moment_scalar_3_rqp_rqp(x, order, dim, center, mask) result(res) + real(qp), intent(in) :: x(:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(qp), intent(in) :: center + logical, intent(in), optional :: mask + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_3_rqp_rqp + module function moment_scalar_4_rqp_rqp(x, order, dim, center, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(qp), intent(in) :: center + logical, intent(in), optional :: mask + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_4_rqp_rqp + module function moment_scalar_5_rqp_rqp(x, order, dim, center, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(qp), intent(in) :: center + logical, intent(in), optional :: mask + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_5_rqp_rqp + module function moment_scalar_6_rqp_rqp(x, order, dim, center, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(qp), intent(in) :: center + logical, intent(in), optional :: mask + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_6_rqp_rqp + module function moment_scalar_7_rqp_rqp(x, order, dim, center, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(qp), intent(in) :: center + logical, intent(in), optional :: mask + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_7_rqp_rqp + module function moment_scalar_8_rqp_rqp(x, order, dim, center, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(qp), intent(in) :: center + logical, intent(in), optional :: mask + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_8_rqp_rqp + module function moment_scalar_9_rqp_rqp(x, order, dim, center, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(qp), intent(in) :: center + logical, intent(in), optional :: mask + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_9_rqp_rqp + module function moment_scalar_10_rqp_rqp(x, order, dim, center, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(qp), intent(in) :: center + logical, intent(in), optional :: mask + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_10_rqp_rqp + module function moment_scalar_11_rqp_rqp(x, order, dim, center, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(qp), intent(in) :: center + logical, intent(in), optional :: mask + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_11_rqp_rqp + module function moment_scalar_12_rqp_rqp(x, order, dim, center, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(qp), intent(in) :: center + logical, intent(in), optional :: mask + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_12_rqp_rqp + module function moment_scalar_13_rqp_rqp(x, order, dim, center, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(qp), intent(in) :: center + logical, intent(in), optional :: mask + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_13_rqp_rqp + module function moment_scalar_14_rqp_rqp(x, order, dim, center, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(qp), intent(in) :: center + logical, intent(in), optional :: mask + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_14_rqp_rqp + module function moment_scalar_15_rqp_rqp(x, order, dim, center, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(qp), intent(in) :: center + logical, intent(in), optional :: mask + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_15_rqp_rqp + module function moment_scalar_2_csp_csp(x, order, dim, center, mask) result(res) + complex(sp), intent(in) :: x(:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(sp), intent(in) :: center + logical, intent(in), optional :: mask + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_2_csp_csp + module function moment_scalar_3_csp_csp(x, order, dim, center, mask) result(res) + complex(sp), intent(in) :: x(:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(sp), intent(in) :: center + logical, intent(in), optional :: mask + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_3_csp_csp + module function moment_scalar_4_csp_csp(x, order, dim, center, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(sp), intent(in) :: center + logical, intent(in), optional :: mask + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_4_csp_csp + module function moment_scalar_5_csp_csp(x, order, dim, center, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(sp), intent(in) :: center + logical, intent(in), optional :: mask + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_5_csp_csp + module function moment_scalar_6_csp_csp(x, order, dim, center, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(sp), intent(in) :: center + logical, intent(in), optional :: mask + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_6_csp_csp + module function moment_scalar_7_csp_csp(x, order, dim, center, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(sp), intent(in) :: center + logical, intent(in), optional :: mask + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_7_csp_csp + module function moment_scalar_8_csp_csp(x, order, dim, center, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(sp), intent(in) :: center + logical, intent(in), optional :: mask + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_8_csp_csp + module function moment_scalar_9_csp_csp(x, order, dim, center, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(sp), intent(in) :: center + logical, intent(in), optional :: mask + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_9_csp_csp + module function moment_scalar_10_csp_csp(x, order, dim, center, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(sp), intent(in) :: center + logical, intent(in), optional :: mask + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_10_csp_csp + module function moment_scalar_11_csp_csp(x, order, dim, center, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(sp), intent(in) :: center + logical, intent(in), optional :: mask + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_11_csp_csp + module function moment_scalar_12_csp_csp(x, order, dim, center, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(sp), intent(in) :: center + logical, intent(in), optional :: mask + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_12_csp_csp + module function moment_scalar_13_csp_csp(x, order, dim, center, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(sp), intent(in) :: center + logical, intent(in), optional :: mask + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_13_csp_csp + module function moment_scalar_14_csp_csp(x, order, dim, center, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(sp), intent(in) :: center + logical, intent(in), optional :: mask + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_14_csp_csp + module function moment_scalar_15_csp_csp(x, order, dim, center, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(sp), intent(in) :: center + logical, intent(in), optional :: mask + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_15_csp_csp + module function moment_scalar_2_cdp_cdp(x, order, dim, center, mask) result(res) + complex(dp), intent(in) :: x(:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(dp), intent(in) :: center + logical, intent(in), optional :: mask + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_2_cdp_cdp + module function moment_scalar_3_cdp_cdp(x, order, dim, center, mask) result(res) + complex(dp), intent(in) :: x(:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(dp), intent(in) :: center + logical, intent(in), optional :: mask + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_3_cdp_cdp + module function moment_scalar_4_cdp_cdp(x, order, dim, center, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(dp), intent(in) :: center + logical, intent(in), optional :: mask + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_4_cdp_cdp + module function moment_scalar_5_cdp_cdp(x, order, dim, center, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(dp), intent(in) :: center + logical, intent(in), optional :: mask + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_5_cdp_cdp + module function moment_scalar_6_cdp_cdp(x, order, dim, center, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(dp), intent(in) :: center + logical, intent(in), optional :: mask + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_6_cdp_cdp + module function moment_scalar_7_cdp_cdp(x, order, dim, center, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(dp), intent(in) :: center + logical, intent(in), optional :: mask + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_7_cdp_cdp + module function moment_scalar_8_cdp_cdp(x, order, dim, center, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(dp), intent(in) :: center + logical, intent(in), optional :: mask + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_8_cdp_cdp + module function moment_scalar_9_cdp_cdp(x, order, dim, center, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(dp), intent(in) :: center + logical, intent(in), optional :: mask + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_9_cdp_cdp + module function moment_scalar_10_cdp_cdp(x, order, dim, center, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(dp), intent(in) :: center + logical, intent(in), optional :: mask + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_10_cdp_cdp + module function moment_scalar_11_cdp_cdp(x, order, dim, center, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(dp), intent(in) :: center + logical, intent(in), optional :: mask + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_11_cdp_cdp + module function moment_scalar_12_cdp_cdp(x, order, dim, center, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(dp), intent(in) :: center + logical, intent(in), optional :: mask + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_12_cdp_cdp + module function moment_scalar_13_cdp_cdp(x, order, dim, center, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(dp), intent(in) :: center + logical, intent(in), optional :: mask + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_13_cdp_cdp + module function moment_scalar_14_cdp_cdp(x, order, dim, center, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(dp), intent(in) :: center + logical, intent(in), optional :: mask + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_14_cdp_cdp + module function moment_scalar_15_cdp_cdp(x, order, dim, center, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(dp), intent(in) :: center + logical, intent(in), optional :: mask + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_15_cdp_cdp + module function moment_scalar_2_cqp_cqp(x, order, dim, center, mask) result(res) + complex(qp), intent(in) :: x(:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(qp), intent(in) :: center + logical, intent(in), optional :: mask + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_2_cqp_cqp + module function moment_scalar_3_cqp_cqp(x, order, dim, center, mask) result(res) + complex(qp), intent(in) :: x(:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(qp), intent(in) :: center + logical, intent(in), optional :: mask + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_3_cqp_cqp + module function moment_scalar_4_cqp_cqp(x, order, dim, center, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(qp), intent(in) :: center + logical, intent(in), optional :: mask + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_4_cqp_cqp + module function moment_scalar_5_cqp_cqp(x, order, dim, center, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(qp), intent(in) :: center + logical, intent(in), optional :: mask + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_5_cqp_cqp + module function moment_scalar_6_cqp_cqp(x, order, dim, center, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(qp), intent(in) :: center + logical, intent(in), optional :: mask + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_6_cqp_cqp + module function moment_scalar_7_cqp_cqp(x, order, dim, center, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(qp), intent(in) :: center + logical, intent(in), optional :: mask + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_7_cqp_cqp + module function moment_scalar_8_cqp_cqp(x, order, dim, center, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(qp), intent(in) :: center + logical, intent(in), optional :: mask + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_8_cqp_cqp + module function moment_scalar_9_cqp_cqp(x, order, dim, center, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(qp), intent(in) :: center + logical, intent(in), optional :: mask + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_9_cqp_cqp + module function moment_scalar_10_cqp_cqp(x, order, dim, center, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(qp), intent(in) :: center + logical, intent(in), optional :: mask + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_10_cqp_cqp + module function moment_scalar_11_cqp_cqp(x, order, dim, center, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(qp), intent(in) :: center + logical, intent(in), optional :: mask + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_11_cqp_cqp + module function moment_scalar_12_cqp_cqp(x, order, dim, center, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(qp), intent(in) :: center + logical, intent(in), optional :: mask + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_12_cqp_cqp + module function moment_scalar_13_cqp_cqp(x, order, dim, center, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(qp), intent(in) :: center + logical, intent(in), optional :: mask + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_13_cqp_cqp + module function moment_scalar_14_cqp_cqp(x, order, dim, center, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(qp), intent(in) :: center + logical, intent(in), optional :: mask + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_14_cqp_cqp + module function moment_scalar_15_cqp_cqp(x, order, dim, center, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(qp), intent(in) :: center + logical, intent(in), optional :: mask + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + res = sum((x - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_15_cqp_cqp + + module function moment_scalar_2_iint8_dp(x, order, dim, center, mask) result(res) + integer(int8), intent(in) :: x(:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_2_iint8_dp + module function moment_scalar_3_iint8_dp(x, order, dim, center, mask) result(res) + integer(int8), intent(in) :: x(:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_3_iint8_dp + module function moment_scalar_4_iint8_dp(x, order, dim, center, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_4_iint8_dp + module function moment_scalar_5_iint8_dp(x, order, dim, center, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_5_iint8_dp + module function moment_scalar_6_iint8_dp(x, order, dim, center, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_6_iint8_dp + module function moment_scalar_7_iint8_dp(x, order, dim, center, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_7_iint8_dp + module function moment_scalar_8_iint8_dp(x, order, dim, center, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_8_iint8_dp + module function moment_scalar_9_iint8_dp(x, order, dim, center, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_9_iint8_dp + module function moment_scalar_10_iint8_dp(x, order, dim, center, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_10_iint8_dp + module function moment_scalar_11_iint8_dp(x, order, dim, center, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_11_iint8_dp + module function moment_scalar_12_iint8_dp(x, order, dim, center, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_12_iint8_dp + module function moment_scalar_13_iint8_dp(x, order, dim, center, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_13_iint8_dp + module function moment_scalar_14_iint8_dp(x, order, dim, center, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_14_iint8_dp + module function moment_scalar_15_iint8_dp(x, order, dim, center, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_15_iint8_dp + module function moment_scalar_2_iint16_dp(x, order, dim, center, mask) result(res) + integer(int16), intent(in) :: x(:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_2_iint16_dp + module function moment_scalar_3_iint16_dp(x, order, dim, center, mask) result(res) + integer(int16), intent(in) :: x(:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_3_iint16_dp + module function moment_scalar_4_iint16_dp(x, order, dim, center, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_4_iint16_dp + module function moment_scalar_5_iint16_dp(x, order, dim, center, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_5_iint16_dp + module function moment_scalar_6_iint16_dp(x, order, dim, center, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_6_iint16_dp + module function moment_scalar_7_iint16_dp(x, order, dim, center, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_7_iint16_dp + module function moment_scalar_8_iint16_dp(x, order, dim, center, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_8_iint16_dp + module function moment_scalar_9_iint16_dp(x, order, dim, center, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_9_iint16_dp + module function moment_scalar_10_iint16_dp(x, order, dim, center, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_10_iint16_dp + module function moment_scalar_11_iint16_dp(x, order, dim, center, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_11_iint16_dp + module function moment_scalar_12_iint16_dp(x, order, dim, center, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_12_iint16_dp + module function moment_scalar_13_iint16_dp(x, order, dim, center, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_13_iint16_dp + module function moment_scalar_14_iint16_dp(x, order, dim, center, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_14_iint16_dp + module function moment_scalar_15_iint16_dp(x, order, dim, center, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_15_iint16_dp + module function moment_scalar_2_iint32_dp(x, order, dim, center, mask) result(res) + integer(int32), intent(in) :: x(:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_2_iint32_dp + module function moment_scalar_3_iint32_dp(x, order, dim, center, mask) result(res) + integer(int32), intent(in) :: x(:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_3_iint32_dp + module function moment_scalar_4_iint32_dp(x, order, dim, center, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_4_iint32_dp + module function moment_scalar_5_iint32_dp(x, order, dim, center, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_5_iint32_dp + module function moment_scalar_6_iint32_dp(x, order, dim, center, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_6_iint32_dp + module function moment_scalar_7_iint32_dp(x, order, dim, center, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_7_iint32_dp + module function moment_scalar_8_iint32_dp(x, order, dim, center, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_8_iint32_dp + module function moment_scalar_9_iint32_dp(x, order, dim, center, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_9_iint32_dp + module function moment_scalar_10_iint32_dp(x, order, dim, center, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_10_iint32_dp + module function moment_scalar_11_iint32_dp(x, order, dim, center, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_11_iint32_dp + module function moment_scalar_12_iint32_dp(x, order, dim, center, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_12_iint32_dp + module function moment_scalar_13_iint32_dp(x, order, dim, center, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_13_iint32_dp + module function moment_scalar_14_iint32_dp(x, order, dim, center, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_14_iint32_dp + module function moment_scalar_15_iint32_dp(x, order, dim, center, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_15_iint32_dp + module function moment_scalar_2_iint64_dp(x, order, dim, center, mask) result(res) + integer(int64), intent(in) :: x(:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_2_iint64_dp + module function moment_scalar_3_iint64_dp(x, order, dim, center, mask) result(res) + integer(int64), intent(in) :: x(:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_3_iint64_dp + module function moment_scalar_4_iint64_dp(x, order, dim, center, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_4_iint64_dp + module function moment_scalar_5_iint64_dp(x, order, dim, center, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_5_iint64_dp + module function moment_scalar_6_iint64_dp(x, order, dim, center, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_6_iint64_dp + module function moment_scalar_7_iint64_dp(x, order, dim, center, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_7_iint64_dp + module function moment_scalar_8_iint64_dp(x, order, dim, center, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_8_iint64_dp + module function moment_scalar_9_iint64_dp(x, order, dim, center, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_9_iint64_dp + module function moment_scalar_10_iint64_dp(x, order, dim, center, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_10_iint64_dp + module function moment_scalar_11_iint64_dp(x, order, dim, center, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_11_iint64_dp + module function moment_scalar_12_iint64_dp(x, order, dim, center, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_12_iint64_dp + module function moment_scalar_13_iint64_dp(x, order, dim, center, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_13_iint64_dp + module function moment_scalar_14_iint64_dp(x, order, dim, center, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_14_iint64_dp + module function moment_scalar_15_iint64_dp(x, order, dim, center, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp),intent(in) :: center + logical, intent(in), optional :: mask + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_scalar_15_iint64_dp + + + module function moment_mask_scalar_2_rsp_rsp(x, order, dim, center, mask) result(res) + real(sp), intent(in) :: x(:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(sp), intent(in) :: center + logical, intent(in) :: mask(:,:) + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_2_rsp_rsp + module function moment_mask_scalar_3_rsp_rsp(x, order, dim, center, mask) result(res) + real(sp), intent(in) :: x(:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(sp), intent(in) :: center + logical, intent(in) :: mask(:,:,:) + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_3_rsp_rsp + module function moment_mask_scalar_4_rsp_rsp(x, order, dim, center, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(sp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:) + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_4_rsp_rsp + module function moment_mask_scalar_5_rsp_rsp(x, order, dim, center, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(sp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:) + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_5_rsp_rsp + module function moment_mask_scalar_6_rsp_rsp(x, order, dim, center, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(sp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:) + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_6_rsp_rsp + module function moment_mask_scalar_7_rsp_rsp(x, order, dim, center, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(sp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:) + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_7_rsp_rsp + module function moment_mask_scalar_8_rsp_rsp(x, order, dim, center, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(sp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_8_rsp_rsp + module function moment_mask_scalar_9_rsp_rsp(x, order, dim, center, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(sp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_9_rsp_rsp + module function moment_mask_scalar_10_rsp_rsp(x, order, dim, center, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(sp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_10_rsp_rsp + module function moment_mask_scalar_11_rsp_rsp(x, order, dim, center, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(sp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_11_rsp_rsp + module function moment_mask_scalar_12_rsp_rsp(x, order, dim, center, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(sp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_12_rsp_rsp + module function moment_mask_scalar_13_rsp_rsp(x, order, dim, center, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(sp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_13_rsp_rsp + module function moment_mask_scalar_14_rsp_rsp(x, order, dim, center, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(sp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_14_rsp_rsp + module function moment_mask_scalar_15_rsp_rsp(x, order, dim, center, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(sp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_15_rsp_rsp + module function moment_mask_scalar_2_rdp_rdp(x, order, dim, center, mask) result(res) + real(dp), intent(in) :: x(:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_2_rdp_rdp + module function moment_mask_scalar_3_rdp_rdp(x, order, dim, center, mask) result(res) + real(dp), intent(in) :: x(:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_3_rdp_rdp + module function moment_mask_scalar_4_rdp_rdp(x, order, dim, center, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_4_rdp_rdp + module function moment_mask_scalar_5_rdp_rdp(x, order, dim, center, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_5_rdp_rdp + module function moment_mask_scalar_6_rdp_rdp(x, order, dim, center, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_6_rdp_rdp + module function moment_mask_scalar_7_rdp_rdp(x, order, dim, center, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_7_rdp_rdp + module function moment_mask_scalar_8_rdp_rdp(x, order, dim, center, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_8_rdp_rdp + module function moment_mask_scalar_9_rdp_rdp(x, order, dim, center, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_9_rdp_rdp + module function moment_mask_scalar_10_rdp_rdp(x, order, dim, center, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_10_rdp_rdp + module function moment_mask_scalar_11_rdp_rdp(x, order, dim, center, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_11_rdp_rdp + module function moment_mask_scalar_12_rdp_rdp(x, order, dim, center, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_12_rdp_rdp + module function moment_mask_scalar_13_rdp_rdp(x, order, dim, center, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_13_rdp_rdp + module function moment_mask_scalar_14_rdp_rdp(x, order, dim, center, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_14_rdp_rdp + module function moment_mask_scalar_15_rdp_rdp(x, order, dim, center, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_15_rdp_rdp + module function moment_mask_scalar_2_rqp_rqp(x, order, dim, center, mask) result(res) + real(qp), intent(in) :: x(:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(qp), intent(in) :: center + logical, intent(in) :: mask(:,:) + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_2_rqp_rqp + module function moment_mask_scalar_3_rqp_rqp(x, order, dim, center, mask) result(res) + real(qp), intent(in) :: x(:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(qp), intent(in) :: center + logical, intent(in) :: mask(:,:,:) + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_3_rqp_rqp + module function moment_mask_scalar_4_rqp_rqp(x, order, dim, center, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(qp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:) + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_4_rqp_rqp + module function moment_mask_scalar_5_rqp_rqp(x, order, dim, center, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(qp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:) + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_5_rqp_rqp + module function moment_mask_scalar_6_rqp_rqp(x, order, dim, center, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(qp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:) + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_6_rqp_rqp + module function moment_mask_scalar_7_rqp_rqp(x, order, dim, center, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(qp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:) + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_7_rqp_rqp + module function moment_mask_scalar_8_rqp_rqp(x, order, dim, center, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(qp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_8_rqp_rqp + module function moment_mask_scalar_9_rqp_rqp(x, order, dim, center, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(qp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_9_rqp_rqp + module function moment_mask_scalar_10_rqp_rqp(x, order, dim, center, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(qp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_10_rqp_rqp + module function moment_mask_scalar_11_rqp_rqp(x, order, dim, center, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(qp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_11_rqp_rqp + module function moment_mask_scalar_12_rqp_rqp(x, order, dim, center, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(qp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_12_rqp_rqp + module function moment_mask_scalar_13_rqp_rqp(x, order, dim, center, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(qp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_13_rqp_rqp + module function moment_mask_scalar_14_rqp_rqp(x, order, dim, center, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(qp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_14_rqp_rqp + module function moment_mask_scalar_15_rqp_rqp(x, order, dim, center, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(qp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_15_rqp_rqp + module function moment_mask_scalar_2_csp_csp(x, order, dim, center, mask) result(res) + complex(sp), intent(in) :: x(:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(sp), intent(in) :: center + logical, intent(in) :: mask(:,:) + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_2_csp_csp + module function moment_mask_scalar_3_csp_csp(x, order, dim, center, mask) result(res) + complex(sp), intent(in) :: x(:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(sp), intent(in) :: center + logical, intent(in) :: mask(:,:,:) + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_3_csp_csp + module function moment_mask_scalar_4_csp_csp(x, order, dim, center, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(sp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:) + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_4_csp_csp + module function moment_mask_scalar_5_csp_csp(x, order, dim, center, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(sp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:) + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_5_csp_csp + module function moment_mask_scalar_6_csp_csp(x, order, dim, center, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(sp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:) + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_6_csp_csp + module function moment_mask_scalar_7_csp_csp(x, order, dim, center, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(sp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:) + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_7_csp_csp + module function moment_mask_scalar_8_csp_csp(x, order, dim, center, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(sp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_8_csp_csp + module function moment_mask_scalar_9_csp_csp(x, order, dim, center, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(sp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_9_csp_csp + module function moment_mask_scalar_10_csp_csp(x, order, dim, center, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(sp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_10_csp_csp + module function moment_mask_scalar_11_csp_csp(x, order, dim, center, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(sp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_11_csp_csp + module function moment_mask_scalar_12_csp_csp(x, order, dim, center, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(sp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_12_csp_csp + module function moment_mask_scalar_13_csp_csp(x, order, dim, center, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(sp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_13_csp_csp + module function moment_mask_scalar_14_csp_csp(x, order, dim, center, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(sp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_14_csp_csp + module function moment_mask_scalar_15_csp_csp(x, order, dim, center, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(sp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_15_csp_csp + module function moment_mask_scalar_2_cdp_cdp(x, order, dim, center, mask) result(res) + complex(dp), intent(in) :: x(:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(dp), intent(in) :: center + logical, intent(in) :: mask(:,:) + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_2_cdp_cdp + module function moment_mask_scalar_3_cdp_cdp(x, order, dim, center, mask) result(res) + complex(dp), intent(in) :: x(:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:) + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_3_cdp_cdp + module function moment_mask_scalar_4_cdp_cdp(x, order, dim, center, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:) + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_4_cdp_cdp + module function moment_mask_scalar_5_cdp_cdp(x, order, dim, center, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:) + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_5_cdp_cdp + module function moment_mask_scalar_6_cdp_cdp(x, order, dim, center, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:) + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_6_cdp_cdp + module function moment_mask_scalar_7_cdp_cdp(x, order, dim, center, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:) + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_7_cdp_cdp + module function moment_mask_scalar_8_cdp_cdp(x, order, dim, center, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_8_cdp_cdp + module function moment_mask_scalar_9_cdp_cdp(x, order, dim, center, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_9_cdp_cdp + module function moment_mask_scalar_10_cdp_cdp(x, order, dim, center, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_10_cdp_cdp + module function moment_mask_scalar_11_cdp_cdp(x, order, dim, center, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_11_cdp_cdp + module function moment_mask_scalar_12_cdp_cdp(x, order, dim, center, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_12_cdp_cdp + module function moment_mask_scalar_13_cdp_cdp(x, order, dim, center, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_13_cdp_cdp + module function moment_mask_scalar_14_cdp_cdp(x, order, dim, center, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_14_cdp_cdp + module function moment_mask_scalar_15_cdp_cdp(x, order, dim, center, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_15_cdp_cdp + module function moment_mask_scalar_2_cqp_cqp(x, order, dim, center, mask) result(res) + complex(qp), intent(in) :: x(:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(qp), intent(in) :: center + logical, intent(in) :: mask(:,:) + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_2_cqp_cqp + module function moment_mask_scalar_3_cqp_cqp(x, order, dim, center, mask) result(res) + complex(qp), intent(in) :: x(:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(qp), intent(in) :: center + logical, intent(in) :: mask(:,:,:) + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_3_cqp_cqp + module function moment_mask_scalar_4_cqp_cqp(x, order, dim, center, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(qp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:) + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_4_cqp_cqp + module function moment_mask_scalar_5_cqp_cqp(x, order, dim, center, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(qp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:) + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_5_cqp_cqp + module function moment_mask_scalar_6_cqp_cqp(x, order, dim, center, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(qp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:) + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_6_cqp_cqp + module function moment_mask_scalar_7_cqp_cqp(x, order, dim, center, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(qp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:) + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_7_cqp_cqp + module function moment_mask_scalar_8_cqp_cqp(x, order, dim, center, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(qp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_8_cqp_cqp + module function moment_mask_scalar_9_cqp_cqp(x, order, dim, center, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(qp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_9_cqp_cqp + module function moment_mask_scalar_10_cqp_cqp(x, order, dim, center, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(qp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_10_cqp_cqp + module function moment_mask_scalar_11_cqp_cqp(x, order, dim, center, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(qp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_11_cqp_cqp + module function moment_mask_scalar_12_cqp_cqp(x, order, dim, center, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(qp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_12_cqp_cqp + module function moment_mask_scalar_13_cqp_cqp(x, order, dim, center, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(qp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_13_cqp_cqp + module function moment_mask_scalar_14_cqp_cqp(x, order, dim, center, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(qp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_14_cqp_cqp + module function moment_mask_scalar_15_cqp_cqp(x, order, dim, center, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + complex(qp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_15_cqp_cqp + + + module function moment_mask_scalar_2_iint8_dp(x, order, dim, center, mask) result(res) + integer(int8), intent(in) :: x(:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_2_iint8_dp + module function moment_mask_scalar_3_iint8_dp(x, order, dim, center, mask) result(res) + integer(int8), intent(in) :: x(:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_3_iint8_dp + module function moment_mask_scalar_4_iint8_dp(x, order, dim, center, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_4_iint8_dp + module function moment_mask_scalar_5_iint8_dp(x, order, dim, center, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_5_iint8_dp + module function moment_mask_scalar_6_iint8_dp(x, order, dim, center, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_6_iint8_dp + module function moment_mask_scalar_7_iint8_dp(x, order, dim, center, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_7_iint8_dp + module function moment_mask_scalar_8_iint8_dp(x, order, dim, center, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_8_iint8_dp + module function moment_mask_scalar_9_iint8_dp(x, order, dim, center, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_9_iint8_dp + module function moment_mask_scalar_10_iint8_dp(x, order, dim, center, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_10_iint8_dp + module function moment_mask_scalar_11_iint8_dp(x, order, dim, center, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_11_iint8_dp + module function moment_mask_scalar_12_iint8_dp(x, order, dim, center, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_12_iint8_dp + module function moment_mask_scalar_13_iint8_dp(x, order, dim, center, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_13_iint8_dp + module function moment_mask_scalar_14_iint8_dp(x, order, dim, center, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_14_iint8_dp + module function moment_mask_scalar_15_iint8_dp(x, order, dim, center, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_15_iint8_dp + module function moment_mask_scalar_2_iint16_dp(x, order, dim, center, mask) result(res) + integer(int16), intent(in) :: x(:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_2_iint16_dp + module function moment_mask_scalar_3_iint16_dp(x, order, dim, center, mask) result(res) + integer(int16), intent(in) :: x(:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_3_iint16_dp + module function moment_mask_scalar_4_iint16_dp(x, order, dim, center, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_4_iint16_dp + module function moment_mask_scalar_5_iint16_dp(x, order, dim, center, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_5_iint16_dp + module function moment_mask_scalar_6_iint16_dp(x, order, dim, center, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_6_iint16_dp + module function moment_mask_scalar_7_iint16_dp(x, order, dim, center, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_7_iint16_dp + module function moment_mask_scalar_8_iint16_dp(x, order, dim, center, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_8_iint16_dp + module function moment_mask_scalar_9_iint16_dp(x, order, dim, center, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_9_iint16_dp + module function moment_mask_scalar_10_iint16_dp(x, order, dim, center, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_10_iint16_dp + module function moment_mask_scalar_11_iint16_dp(x, order, dim, center, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_11_iint16_dp + module function moment_mask_scalar_12_iint16_dp(x, order, dim, center, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_12_iint16_dp + module function moment_mask_scalar_13_iint16_dp(x, order, dim, center, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_13_iint16_dp + module function moment_mask_scalar_14_iint16_dp(x, order, dim, center, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_14_iint16_dp + module function moment_mask_scalar_15_iint16_dp(x, order, dim, center, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_15_iint16_dp + module function moment_mask_scalar_2_iint32_dp(x, order, dim, center, mask) result(res) + integer(int32), intent(in) :: x(:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_2_iint32_dp + module function moment_mask_scalar_3_iint32_dp(x, order, dim, center, mask) result(res) + integer(int32), intent(in) :: x(:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_3_iint32_dp + module function moment_mask_scalar_4_iint32_dp(x, order, dim, center, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_4_iint32_dp + module function moment_mask_scalar_5_iint32_dp(x, order, dim, center, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_5_iint32_dp + module function moment_mask_scalar_6_iint32_dp(x, order, dim, center, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_6_iint32_dp + module function moment_mask_scalar_7_iint32_dp(x, order, dim, center, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_7_iint32_dp + module function moment_mask_scalar_8_iint32_dp(x, order, dim, center, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_8_iint32_dp + module function moment_mask_scalar_9_iint32_dp(x, order, dim, center, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_9_iint32_dp + module function moment_mask_scalar_10_iint32_dp(x, order, dim, center, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_10_iint32_dp + module function moment_mask_scalar_11_iint32_dp(x, order, dim, center, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_11_iint32_dp + module function moment_mask_scalar_12_iint32_dp(x, order, dim, center, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_12_iint32_dp + module function moment_mask_scalar_13_iint32_dp(x, order, dim, center, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_13_iint32_dp + module function moment_mask_scalar_14_iint32_dp(x, order, dim, center, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_14_iint32_dp + module function moment_mask_scalar_15_iint32_dp(x, order, dim, center, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_15_iint32_dp + module function moment_mask_scalar_2_iint64_dp(x, order, dim, center, mask) result(res) + integer(int64), intent(in) :: x(:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_2_iint64_dp + module function moment_mask_scalar_3_iint64_dp(x, order, dim, center, mask) result(res) + integer(int64), intent(in) :: x(:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_3_iint64_dp + module function moment_mask_scalar_4_iint64_dp(x, order, dim, center, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_4_iint64_dp + module function moment_mask_scalar_5_iint64_dp(x, order, dim, center, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_5_iint64_dp + module function moment_mask_scalar_6_iint64_dp(x, order, dim, center, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_6_iint64_dp + module function moment_mask_scalar_7_iint64_dp(x, order, dim, center, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_7_iint64_dp + module function moment_mask_scalar_8_iint64_dp(x, order, dim, center, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_8_iint64_dp + module function moment_mask_scalar_9_iint64_dp(x, order, dim, center, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_9_iint64_dp + module function moment_mask_scalar_10_iint64_dp(x, order, dim, center, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_10_iint64_dp + module function moment_mask_scalar_11_iint64_dp(x, order, dim, center, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_11_iint64_dp + module function moment_mask_scalar_12_iint64_dp(x, order, dim, center, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_12_iint64_dp + module function moment_mask_scalar_13_iint64_dp(x, order, dim, center, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_13_iint64_dp + module function moment_mask_scalar_14_iint64_dp(x, order, dim, center, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_14_iint64_dp + module function moment_mask_scalar_15_iint64_dp(x, order, dim, center, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: order + integer, intent(in) :: dim + real(dp), intent(in) :: center + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + else + call error_stop("ERROR (moment): wrong dimension") + end if + + end function moment_mask_scalar_15_iint64_dp + +end submodule diff --git a/src/fpm/stdlib_stats_var.f90 b/src/fpm/stdlib_stats_var.f90 new file mode 100644 index 000000000..6dffe6b94 --- /dev/null +++ b/src/fpm/stdlib_stats_var.f90 @@ -0,0 +1,29775 @@ +submodule (stdlib_stats) stdlib_stats_var + + use, intrinsic:: ieee_arithmetic, only: ieee_value, ieee_quiet_nan + use stdlib_error, only: error_stop + use stdlib_optval, only: optval + implicit none + +contains + + module function var_all_1_rsp_rsp(x, mask, corrected) result(res) + real(sp), intent(in) :: x(:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + real(sp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), sp) + mean = sum(x) / n + + res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + + end function var_all_1_rsp_rsp + module function var_all_2_rsp_rsp(x, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + real(sp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), sp) + mean = sum(x) / n + + res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + + end function var_all_2_rsp_rsp + module function var_all_3_rsp_rsp(x, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + real(sp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), sp) + mean = sum(x) / n + + res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + + end function var_all_3_rsp_rsp + module function var_all_4_rsp_rsp(x, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + real(sp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), sp) + mean = sum(x) / n + + res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + + end function var_all_4_rsp_rsp + module function var_all_5_rsp_rsp(x, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + real(sp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), sp) + mean = sum(x) / n + + res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + + end function var_all_5_rsp_rsp + module function var_all_6_rsp_rsp(x, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + real(sp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), sp) + mean = sum(x) / n + + res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + + end function var_all_6_rsp_rsp + module function var_all_7_rsp_rsp(x, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + real(sp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), sp) + mean = sum(x) / n + + res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + + end function var_all_7_rsp_rsp + module function var_all_8_rsp_rsp(x, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + real(sp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), sp) + mean = sum(x) / n + + res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + + end function var_all_8_rsp_rsp + module function var_all_9_rsp_rsp(x, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + real(sp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), sp) + mean = sum(x) / n + + res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + + end function var_all_9_rsp_rsp + module function var_all_10_rsp_rsp(x, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + real(sp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), sp) + mean = sum(x) / n + + res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + + end function var_all_10_rsp_rsp + module function var_all_11_rsp_rsp(x, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + real(sp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), sp) + mean = sum(x) / n + + res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + + end function var_all_11_rsp_rsp + module function var_all_12_rsp_rsp(x, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + real(sp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), sp) + mean = sum(x) / n + + res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + + end function var_all_12_rsp_rsp + module function var_all_13_rsp_rsp(x, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + real(sp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), sp) + mean = sum(x) / n + + res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + + end function var_all_13_rsp_rsp + module function var_all_14_rsp_rsp(x, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + real(sp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), sp) + mean = sum(x) / n + + res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + + end function var_all_14_rsp_rsp + module function var_all_15_rsp_rsp(x, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + real(sp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), sp) + mean = sum(x) / n + + res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + + end function var_all_15_rsp_rsp + module function var_all_1_rdp_rdp(x, mask, corrected) result(res) + real(dp), intent(in) :: x(:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + real(dp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(x) / n + + res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + + end function var_all_1_rdp_rdp + module function var_all_2_rdp_rdp(x, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + real(dp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(x) / n + + res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + + end function var_all_2_rdp_rdp + module function var_all_3_rdp_rdp(x, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + real(dp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(x) / n + + res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + + end function var_all_3_rdp_rdp + module function var_all_4_rdp_rdp(x, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + real(dp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(x) / n + + res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + + end function var_all_4_rdp_rdp + module function var_all_5_rdp_rdp(x, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + real(dp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(x) / n + + res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + + end function var_all_5_rdp_rdp + module function var_all_6_rdp_rdp(x, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + real(dp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(x) / n + + res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + + end function var_all_6_rdp_rdp + module function var_all_7_rdp_rdp(x, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + real(dp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(x) / n + + res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + + end function var_all_7_rdp_rdp + module function var_all_8_rdp_rdp(x, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + real(dp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(x) / n + + res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + + end function var_all_8_rdp_rdp + module function var_all_9_rdp_rdp(x, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + real(dp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(x) / n + + res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + + end function var_all_9_rdp_rdp + module function var_all_10_rdp_rdp(x, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + real(dp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(x) / n + + res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + + end function var_all_10_rdp_rdp + module function var_all_11_rdp_rdp(x, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + real(dp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(x) / n + + res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + + end function var_all_11_rdp_rdp + module function var_all_12_rdp_rdp(x, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + real(dp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(x) / n + + res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + + end function var_all_12_rdp_rdp + module function var_all_13_rdp_rdp(x, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + real(dp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(x) / n + + res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + + end function var_all_13_rdp_rdp + module function var_all_14_rdp_rdp(x, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + real(dp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(x) / n + + res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + + end function var_all_14_rdp_rdp + module function var_all_15_rdp_rdp(x, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + real(dp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(x) / n + + res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + + end function var_all_15_rdp_rdp + module function var_all_1_rqp_rqp(x, mask, corrected) result(res) + real(qp), intent(in) :: x(:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + real(qp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), qp) + mean = sum(x) / n + + res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + + end function var_all_1_rqp_rqp + module function var_all_2_rqp_rqp(x, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + real(qp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), qp) + mean = sum(x) / n + + res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + + end function var_all_2_rqp_rqp + module function var_all_3_rqp_rqp(x, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + real(qp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), qp) + mean = sum(x) / n + + res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + + end function var_all_3_rqp_rqp + module function var_all_4_rqp_rqp(x, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + real(qp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), qp) + mean = sum(x) / n + + res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + + end function var_all_4_rqp_rqp + module function var_all_5_rqp_rqp(x, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + real(qp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), qp) + mean = sum(x) / n + + res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + + end function var_all_5_rqp_rqp + module function var_all_6_rqp_rqp(x, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + real(qp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), qp) + mean = sum(x) / n + + res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + + end function var_all_6_rqp_rqp + module function var_all_7_rqp_rqp(x, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + real(qp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), qp) + mean = sum(x) / n + + res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + + end function var_all_7_rqp_rqp + module function var_all_8_rqp_rqp(x, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + real(qp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), qp) + mean = sum(x) / n + + res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + + end function var_all_8_rqp_rqp + module function var_all_9_rqp_rqp(x, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + real(qp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), qp) + mean = sum(x) / n + + res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + + end function var_all_9_rqp_rqp + module function var_all_10_rqp_rqp(x, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + real(qp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), qp) + mean = sum(x) / n + + res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + + end function var_all_10_rqp_rqp + module function var_all_11_rqp_rqp(x, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + real(qp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), qp) + mean = sum(x) / n + + res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + + end function var_all_11_rqp_rqp + module function var_all_12_rqp_rqp(x, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + real(qp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), qp) + mean = sum(x) / n + + res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + + end function var_all_12_rqp_rqp + module function var_all_13_rqp_rqp(x, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + real(qp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), qp) + mean = sum(x) / n + + res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + + end function var_all_13_rqp_rqp + module function var_all_14_rqp_rqp(x, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + real(qp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), qp) + mean = sum(x) / n + + res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + + end function var_all_14_rqp_rqp + module function var_all_15_rqp_rqp(x, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + real(qp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), qp) + mean = sum(x) / n + + res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + + end function var_all_15_rqp_rqp + module function var_all_1_csp_csp(x, mask, corrected) result(res) + complex(sp), intent(in) :: x(:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + complex(sp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), sp) + mean = sum(x) / n + + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_1_csp_csp + module function var_all_2_csp_csp(x, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + complex(sp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), sp) + mean = sum(x) / n + + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_2_csp_csp + module function var_all_3_csp_csp(x, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + complex(sp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), sp) + mean = sum(x) / n + + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_3_csp_csp + module function var_all_4_csp_csp(x, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + complex(sp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), sp) + mean = sum(x) / n + + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_4_csp_csp + module function var_all_5_csp_csp(x, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + complex(sp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), sp) + mean = sum(x) / n + + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_5_csp_csp + module function var_all_6_csp_csp(x, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + complex(sp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), sp) + mean = sum(x) / n + + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_6_csp_csp + module function var_all_7_csp_csp(x, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + complex(sp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), sp) + mean = sum(x) / n + + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_7_csp_csp + module function var_all_8_csp_csp(x, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + complex(sp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), sp) + mean = sum(x) / n + + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_8_csp_csp + module function var_all_9_csp_csp(x, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + complex(sp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), sp) + mean = sum(x) / n + + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_9_csp_csp + module function var_all_10_csp_csp(x, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + complex(sp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), sp) + mean = sum(x) / n + + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_10_csp_csp + module function var_all_11_csp_csp(x, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + complex(sp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), sp) + mean = sum(x) / n + + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_11_csp_csp + module function var_all_12_csp_csp(x, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + complex(sp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), sp) + mean = sum(x) / n + + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_12_csp_csp + module function var_all_13_csp_csp(x, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + complex(sp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), sp) + mean = sum(x) / n + + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_13_csp_csp + module function var_all_14_csp_csp(x, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + complex(sp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), sp) + mean = sum(x) / n + + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_14_csp_csp + module function var_all_15_csp_csp(x, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + complex(sp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), sp) + mean = sum(x) / n + + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_15_csp_csp + module function var_all_1_cdp_cdp(x, mask, corrected) result(res) + complex(dp), intent(in) :: x(:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + complex(dp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(x) / n + + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_1_cdp_cdp + module function var_all_2_cdp_cdp(x, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + complex(dp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(x) / n + + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_2_cdp_cdp + module function var_all_3_cdp_cdp(x, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + complex(dp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(x) / n + + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_3_cdp_cdp + module function var_all_4_cdp_cdp(x, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + complex(dp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(x) / n + + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_4_cdp_cdp + module function var_all_5_cdp_cdp(x, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + complex(dp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(x) / n + + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_5_cdp_cdp + module function var_all_6_cdp_cdp(x, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + complex(dp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(x) / n + + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_6_cdp_cdp + module function var_all_7_cdp_cdp(x, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + complex(dp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(x) / n + + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_7_cdp_cdp + module function var_all_8_cdp_cdp(x, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + complex(dp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(x) / n + + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_8_cdp_cdp + module function var_all_9_cdp_cdp(x, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + complex(dp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(x) / n + + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_9_cdp_cdp + module function var_all_10_cdp_cdp(x, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + complex(dp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(x) / n + + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_10_cdp_cdp + module function var_all_11_cdp_cdp(x, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + complex(dp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(x) / n + + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_11_cdp_cdp + module function var_all_12_cdp_cdp(x, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + complex(dp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(x) / n + + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_12_cdp_cdp + module function var_all_13_cdp_cdp(x, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + complex(dp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(x) / n + + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_13_cdp_cdp + module function var_all_14_cdp_cdp(x, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + complex(dp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(x) / n + + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_14_cdp_cdp + module function var_all_15_cdp_cdp(x, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + complex(dp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(x) / n + + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_15_cdp_cdp + module function var_all_1_cqp_cqp(x, mask, corrected) result(res) + complex(qp), intent(in) :: x(:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + complex(qp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), qp) + mean = sum(x) / n + + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_1_cqp_cqp + module function var_all_2_cqp_cqp(x, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + complex(qp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), qp) + mean = sum(x) / n + + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_2_cqp_cqp + module function var_all_3_cqp_cqp(x, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + complex(qp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), qp) + mean = sum(x) / n + + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_3_cqp_cqp + module function var_all_4_cqp_cqp(x, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + complex(qp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), qp) + mean = sum(x) / n + + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_4_cqp_cqp + module function var_all_5_cqp_cqp(x, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + complex(qp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), qp) + mean = sum(x) / n + + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_5_cqp_cqp + module function var_all_6_cqp_cqp(x, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + complex(qp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), qp) + mean = sum(x) / n + + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_6_cqp_cqp + module function var_all_7_cqp_cqp(x, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + complex(qp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), qp) + mean = sum(x) / n + + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_7_cqp_cqp + module function var_all_8_cqp_cqp(x, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + complex(qp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), qp) + mean = sum(x) / n + + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_8_cqp_cqp + module function var_all_9_cqp_cqp(x, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + complex(qp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), qp) + mean = sum(x) / n + + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_9_cqp_cqp + module function var_all_10_cqp_cqp(x, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + complex(qp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), qp) + mean = sum(x) / n + + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_10_cqp_cqp + module function var_all_11_cqp_cqp(x, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + complex(qp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), qp) + mean = sum(x) / n + + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_11_cqp_cqp + module function var_all_12_cqp_cqp(x, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + complex(qp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), qp) + mean = sum(x) / n + + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_12_cqp_cqp + module function var_all_13_cqp_cqp(x, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + complex(qp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), qp) + mean = sum(x) / n + + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_13_cqp_cqp + module function var_all_14_cqp_cqp(x, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + complex(qp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), qp) + mean = sum(x) / n + + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_14_cqp_cqp + module function var_all_15_cqp_cqp(x, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + complex(qp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._qp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), qp) + mean = sum(x) / n + + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_15_cqp_cqp + + + module function var_all_1_iint8_dp(x, mask, corrected) result(res) + integer(int8), intent(in) :: x(:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_1_iint8_dp + module function var_all_2_iint8_dp(x, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_2_iint8_dp + module function var_all_3_iint8_dp(x, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_3_iint8_dp + module function var_all_4_iint8_dp(x, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_4_iint8_dp + module function var_all_5_iint8_dp(x, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_5_iint8_dp + module function var_all_6_iint8_dp(x, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_6_iint8_dp + module function var_all_7_iint8_dp(x, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_7_iint8_dp + module function var_all_8_iint8_dp(x, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_8_iint8_dp + module function var_all_9_iint8_dp(x, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_9_iint8_dp + module function var_all_10_iint8_dp(x, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_10_iint8_dp + module function var_all_11_iint8_dp(x, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_11_iint8_dp + module function var_all_12_iint8_dp(x, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_12_iint8_dp + module function var_all_13_iint8_dp(x, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_13_iint8_dp + module function var_all_14_iint8_dp(x, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_14_iint8_dp + module function var_all_15_iint8_dp(x, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_15_iint8_dp + module function var_all_1_iint16_dp(x, mask, corrected) result(res) + integer(int16), intent(in) :: x(:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_1_iint16_dp + module function var_all_2_iint16_dp(x, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_2_iint16_dp + module function var_all_3_iint16_dp(x, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_3_iint16_dp + module function var_all_4_iint16_dp(x, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_4_iint16_dp + module function var_all_5_iint16_dp(x, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_5_iint16_dp + module function var_all_6_iint16_dp(x, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_6_iint16_dp + module function var_all_7_iint16_dp(x, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_7_iint16_dp + module function var_all_8_iint16_dp(x, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_8_iint16_dp + module function var_all_9_iint16_dp(x, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_9_iint16_dp + module function var_all_10_iint16_dp(x, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_10_iint16_dp + module function var_all_11_iint16_dp(x, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_11_iint16_dp + module function var_all_12_iint16_dp(x, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_12_iint16_dp + module function var_all_13_iint16_dp(x, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_13_iint16_dp + module function var_all_14_iint16_dp(x, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_14_iint16_dp + module function var_all_15_iint16_dp(x, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_15_iint16_dp + module function var_all_1_iint32_dp(x, mask, corrected) result(res) + integer(int32), intent(in) :: x(:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_1_iint32_dp + module function var_all_2_iint32_dp(x, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_2_iint32_dp + module function var_all_3_iint32_dp(x, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_3_iint32_dp + module function var_all_4_iint32_dp(x, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_4_iint32_dp + module function var_all_5_iint32_dp(x, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_5_iint32_dp + module function var_all_6_iint32_dp(x, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_6_iint32_dp + module function var_all_7_iint32_dp(x, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_7_iint32_dp + module function var_all_8_iint32_dp(x, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_8_iint32_dp + module function var_all_9_iint32_dp(x, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_9_iint32_dp + module function var_all_10_iint32_dp(x, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_10_iint32_dp + module function var_all_11_iint32_dp(x, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_11_iint32_dp + module function var_all_12_iint32_dp(x, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_12_iint32_dp + module function var_all_13_iint32_dp(x, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_13_iint32_dp + module function var_all_14_iint32_dp(x, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_14_iint32_dp + module function var_all_15_iint32_dp(x, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_15_iint32_dp + module function var_all_1_iint64_dp(x, mask, corrected) result(res) + integer(int64), intent(in) :: x(:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_1_iint64_dp + module function var_all_2_iint64_dp(x, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_2_iint64_dp + module function var_all_3_iint64_dp(x, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_3_iint64_dp + module function var_all_4_iint64_dp(x, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_4_iint64_dp + module function var_all_5_iint64_dp(x, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_5_iint64_dp + module function var_all_6_iint64_dp(x, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_6_iint64_dp + module function var_all_7_iint64_dp(x, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_7_iint64_dp + module function var_all_8_iint64_dp(x, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_8_iint64_dp + module function var_all_9_iint64_dp(x, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_9_iint64_dp + module function var_all_10_iint64_dp(x, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_10_iint64_dp + module function var_all_11_iint64_dp(x, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_11_iint64_dp + module function var_all_12_iint64_dp(x, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_12_iint64_dp + module function var_all_13_iint64_dp(x, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_13_iint64_dp + module function var_all_14_iint64_dp(x, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_14_iint64_dp + module function var_all_15_iint64_dp(x, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._dp, ieee_quiet_nan) + return + end if + + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n + + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_all_15_iint64_dp + + + module function var_1_rsp_rsp(x, dim, mask, corrected) result(res) + real(sp), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(sp) :: res + + integer :: i + real(sp) :: n + real(sp) :: mean + + if (.not.optval(mask, .true.)) then + res = ieee_value(1._sp, ieee_quiet_nan) + return + end if + + res = 0._sp + select case(dim) + case(1) + n = size(x, dim) + mean = sum(x, dim) / n + do i = 1, size(x, dim) + res = res + (x(i) - mean)**2 + end do + case default + call error_stop("ERROR (var): wrong dimension") + end select + res = res / (n - merge(1, 0, optval(corrected, .true.))) + + end function var_1_rsp_rsp + module function var_2_rsp_rsp(x, dim, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:) + integer, intent(in) :: dim + logical, intent(in), optional :: mask + logical, intent(in), optional :: corrected + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_all_1_rsp_rsp + module function var_mask_all_2_rsp_rsp(x, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:) + logical, intent(in) :: mask(:,:) + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + real(sp) :: mean + + n = real(count(mask, kind = int64), sp) + mean = sum(x, mask) / n + + res = sum((x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_2_rsp_rsp + module function var_mask_all_3_rsp_rsp(x, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:,:) + logical, intent(in) :: mask(:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + real(sp) :: mean + + n = real(count(mask, kind = int64), sp) + mean = sum(x, mask) / n + + res = sum((x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_3_rsp_rsp + module function var_mask_all_4_rsp_rsp(x, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:,:,:) + logical, intent(in) :: mask(:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + real(sp) :: mean + + n = real(count(mask, kind = int64), sp) + mean = sum(x, mask) / n + + res = sum((x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_4_rsp_rsp + module function var_mask_all_5_rsp_rsp(x, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + real(sp) :: mean + + n = real(count(mask, kind = int64), sp) + mean = sum(x, mask) / n + + res = sum((x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_5_rsp_rsp + module function var_mask_all_6_rsp_rsp(x, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + real(sp) :: mean + + n = real(count(mask, kind = int64), sp) + mean = sum(x, mask) / n + + res = sum((x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_6_rsp_rsp + module function var_mask_all_7_rsp_rsp(x, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + real(sp) :: mean + + n = real(count(mask, kind = int64), sp) + mean = sum(x, mask) / n + + res = sum((x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_7_rsp_rsp + module function var_mask_all_8_rsp_rsp(x, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + real(sp) :: mean + + n = real(count(mask, kind = int64), sp) + mean = sum(x, mask) / n + + res = sum((x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_8_rsp_rsp + module function var_mask_all_9_rsp_rsp(x, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + real(sp) :: mean + + n = real(count(mask, kind = int64), sp) + mean = sum(x, mask) / n + + res = sum((x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_9_rsp_rsp + module function var_mask_all_10_rsp_rsp(x, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + real(sp) :: mean + + n = real(count(mask, kind = int64), sp) + mean = sum(x, mask) / n + + res = sum((x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_10_rsp_rsp + module function var_mask_all_11_rsp_rsp(x, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + real(sp) :: mean + + n = real(count(mask, kind = int64), sp) + mean = sum(x, mask) / n + + res = sum((x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_11_rsp_rsp + module function var_mask_all_12_rsp_rsp(x, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + real(sp) :: mean + + n = real(count(mask, kind = int64), sp) + mean = sum(x, mask) / n + + res = sum((x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_12_rsp_rsp + module function var_mask_all_13_rsp_rsp(x, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + real(sp) :: mean + + n = real(count(mask, kind = int64), sp) + mean = sum(x, mask) / n + + res = sum((x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_13_rsp_rsp + module function var_mask_all_14_rsp_rsp(x, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + real(sp) :: mean + + n = real(count(mask, kind = int64), sp) + mean = sum(x, mask) / n + + res = sum((x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_14_rsp_rsp + module function var_mask_all_15_rsp_rsp(x, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + real(sp) :: mean + + n = real(count(mask, kind = int64), sp) + mean = sum(x, mask) / n + + res = sum((x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_15_rsp_rsp + module function var_mask_all_1_rdp_rdp(x, mask, corrected) result(res) + real(dp), intent(in) :: x(:) + logical, intent(in) :: mask(:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + real(dp) :: mean + + n = real(count(mask, kind = int64), dp) + mean = sum(x, mask) / n + + res = sum((x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_1_rdp_rdp + module function var_mask_all_2_rdp_rdp(x, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:) + logical, intent(in) :: mask(:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + real(dp) :: mean + + n = real(count(mask, kind = int64), dp) + mean = sum(x, mask) / n + + res = sum((x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_2_rdp_rdp + module function var_mask_all_3_rdp_rdp(x, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:,:) + logical, intent(in) :: mask(:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + real(dp) :: mean + + n = real(count(mask, kind = int64), dp) + mean = sum(x, mask) / n + + res = sum((x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_3_rdp_rdp + module function var_mask_all_4_rdp_rdp(x, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:,:,:) + logical, intent(in) :: mask(:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + real(dp) :: mean + + n = real(count(mask, kind = int64), dp) + mean = sum(x, mask) / n + + res = sum((x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_4_rdp_rdp + module function var_mask_all_5_rdp_rdp(x, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + real(dp) :: mean + + n = real(count(mask, kind = int64), dp) + mean = sum(x, mask) / n + + res = sum((x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_5_rdp_rdp + module function var_mask_all_6_rdp_rdp(x, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + real(dp) :: mean + + n = real(count(mask, kind = int64), dp) + mean = sum(x, mask) / n + + res = sum((x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_6_rdp_rdp + module function var_mask_all_7_rdp_rdp(x, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + real(dp) :: mean + + n = real(count(mask, kind = int64), dp) + mean = sum(x, mask) / n + + res = sum((x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_7_rdp_rdp + module function var_mask_all_8_rdp_rdp(x, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + real(dp) :: mean + + n = real(count(mask, kind = int64), dp) + mean = sum(x, mask) / n + + res = sum((x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_8_rdp_rdp + module function var_mask_all_9_rdp_rdp(x, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + real(dp) :: mean + + n = real(count(mask, kind = int64), dp) + mean = sum(x, mask) / n + + res = sum((x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_9_rdp_rdp + module function var_mask_all_10_rdp_rdp(x, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + real(dp) :: mean + + n = real(count(mask, kind = int64), dp) + mean = sum(x, mask) / n + + res = sum((x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_10_rdp_rdp + module function var_mask_all_11_rdp_rdp(x, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + real(dp) :: mean + + n = real(count(mask, kind = int64), dp) + mean = sum(x, mask) / n + + res = sum((x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_11_rdp_rdp + module function var_mask_all_12_rdp_rdp(x, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + real(dp) :: mean + + n = real(count(mask, kind = int64), dp) + mean = sum(x, mask) / n + + res = sum((x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_12_rdp_rdp + module function var_mask_all_13_rdp_rdp(x, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + real(dp) :: mean + + n = real(count(mask, kind = int64), dp) + mean = sum(x, mask) / n + + res = sum((x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_13_rdp_rdp + module function var_mask_all_14_rdp_rdp(x, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + real(dp) :: mean + + n = real(count(mask, kind = int64), dp) + mean = sum(x, mask) / n + + res = sum((x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_14_rdp_rdp + module function var_mask_all_15_rdp_rdp(x, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + real(dp) :: mean + + n = real(count(mask, kind = int64), dp) + mean = sum(x, mask) / n + + res = sum((x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_15_rdp_rdp + module function var_mask_all_1_rqp_rqp(x, mask, corrected) result(res) + real(qp), intent(in) :: x(:) + logical, intent(in) :: mask(:) + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + real(qp) :: mean + + n = real(count(mask, kind = int64), qp) + mean = sum(x, mask) / n + + res = sum((x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_1_rqp_rqp + module function var_mask_all_2_rqp_rqp(x, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:) + logical, intent(in) :: mask(:,:) + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + real(qp) :: mean + + n = real(count(mask, kind = int64), qp) + mean = sum(x, mask) / n + + res = sum((x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_2_rqp_rqp + module function var_mask_all_3_rqp_rqp(x, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:,:) + logical, intent(in) :: mask(:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + real(qp) :: mean + + n = real(count(mask, kind = int64), qp) + mean = sum(x, mask) / n + + res = sum((x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_3_rqp_rqp + module function var_mask_all_4_rqp_rqp(x, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:,:,:) + logical, intent(in) :: mask(:,:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + real(qp) :: mean + + n = real(count(mask, kind = int64), qp) + mean = sum(x, mask) / n + + res = sum((x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_4_rqp_rqp + module function var_mask_all_5_rqp_rqp(x, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + real(qp) :: mean + + n = real(count(mask, kind = int64), qp) + mean = sum(x, mask) / n + + res = sum((x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_5_rqp_rqp + module function var_mask_all_6_rqp_rqp(x, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + real(qp) :: mean + + n = real(count(mask, kind = int64), qp) + mean = sum(x, mask) / n + + res = sum((x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_6_rqp_rqp + module function var_mask_all_7_rqp_rqp(x, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + real(qp) :: mean + + n = real(count(mask, kind = int64), qp) + mean = sum(x, mask) / n + + res = sum((x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_7_rqp_rqp + module function var_mask_all_8_rqp_rqp(x, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + real(qp) :: mean + + n = real(count(mask, kind = int64), qp) + mean = sum(x, mask) / n + + res = sum((x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_8_rqp_rqp + module function var_mask_all_9_rqp_rqp(x, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + real(qp) :: mean + + n = real(count(mask, kind = int64), qp) + mean = sum(x, mask) / n + + res = sum((x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_9_rqp_rqp + module function var_mask_all_10_rqp_rqp(x, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + real(qp) :: mean + + n = real(count(mask, kind = int64), qp) + mean = sum(x, mask) / n + + res = sum((x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_10_rqp_rqp + module function var_mask_all_11_rqp_rqp(x, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + real(qp) :: mean + + n = real(count(mask, kind = int64), qp) + mean = sum(x, mask) / n + + res = sum((x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_11_rqp_rqp + module function var_mask_all_12_rqp_rqp(x, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + real(qp) :: mean + + n = real(count(mask, kind = int64), qp) + mean = sum(x, mask) / n + + res = sum((x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_12_rqp_rqp + module function var_mask_all_13_rqp_rqp(x, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + real(qp) :: mean + + n = real(count(mask, kind = int64), qp) + mean = sum(x, mask) / n + + res = sum((x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_13_rqp_rqp + module function var_mask_all_14_rqp_rqp(x, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + real(qp) :: mean + + n = real(count(mask, kind = int64), qp) + mean = sum(x, mask) / n + + res = sum((x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_14_rqp_rqp + module function var_mask_all_15_rqp_rqp(x, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + real(qp) :: mean + + n = real(count(mask, kind = int64), qp) + mean = sum(x, mask) / n + + res = sum((x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_15_rqp_rqp + module function var_mask_all_1_csp_csp(x, mask, corrected) result(res) + complex(sp), intent(in) :: x(:) + logical, intent(in) :: mask(:) + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + complex(sp) :: mean + + n = real(count(mask, kind = int64), sp) + mean = sum(x, mask) / n + + res = sum(abs(x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_1_csp_csp + module function var_mask_all_2_csp_csp(x, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:) + logical, intent(in) :: mask(:,:) + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + complex(sp) :: mean + + n = real(count(mask, kind = int64), sp) + mean = sum(x, mask) / n + + res = sum(abs(x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_2_csp_csp + module function var_mask_all_3_csp_csp(x, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:) + logical, intent(in) :: mask(:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + complex(sp) :: mean + + n = real(count(mask, kind = int64), sp) + mean = sum(x, mask) / n + + res = sum(abs(x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_3_csp_csp + module function var_mask_all_4_csp_csp(x, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:,:) + logical, intent(in) :: mask(:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + complex(sp) :: mean + + n = real(count(mask, kind = int64), sp) + mean = sum(x, mask) / n + + res = sum(abs(x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_4_csp_csp + module function var_mask_all_5_csp_csp(x, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + complex(sp) :: mean + + n = real(count(mask, kind = int64), sp) + mean = sum(x, mask) / n + + res = sum(abs(x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_5_csp_csp + module function var_mask_all_6_csp_csp(x, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + complex(sp) :: mean + + n = real(count(mask, kind = int64), sp) + mean = sum(x, mask) / n + + res = sum(abs(x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_6_csp_csp + module function var_mask_all_7_csp_csp(x, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + complex(sp) :: mean + + n = real(count(mask, kind = int64), sp) + mean = sum(x, mask) / n + + res = sum(abs(x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_7_csp_csp + module function var_mask_all_8_csp_csp(x, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + complex(sp) :: mean + + n = real(count(mask, kind = int64), sp) + mean = sum(x, mask) / n + + res = sum(abs(x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_8_csp_csp + module function var_mask_all_9_csp_csp(x, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + complex(sp) :: mean + + n = real(count(mask, kind = int64), sp) + mean = sum(x, mask) / n + + res = sum(abs(x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_9_csp_csp + module function var_mask_all_10_csp_csp(x, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + complex(sp) :: mean + + n = real(count(mask, kind = int64), sp) + mean = sum(x, mask) / n + + res = sum(abs(x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_10_csp_csp + module function var_mask_all_11_csp_csp(x, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + complex(sp) :: mean + + n = real(count(mask, kind = int64), sp) + mean = sum(x, mask) / n + + res = sum(abs(x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_11_csp_csp + module function var_mask_all_12_csp_csp(x, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + complex(sp) :: mean + + n = real(count(mask, kind = int64), sp) + mean = sum(x, mask) / n + + res = sum(abs(x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_12_csp_csp + module function var_mask_all_13_csp_csp(x, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + complex(sp) :: mean + + n = real(count(mask, kind = int64), sp) + mean = sum(x, mask) / n + + res = sum(abs(x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_13_csp_csp + module function var_mask_all_14_csp_csp(x, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + complex(sp) :: mean + + n = real(count(mask, kind = int64), sp) + mean = sum(x, mask) / n + + res = sum(abs(x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_14_csp_csp + module function var_mask_all_15_csp_csp(x, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + complex(sp) :: mean + + n = real(count(mask, kind = int64), sp) + mean = sum(x, mask) / n + + res = sum(abs(x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_15_csp_csp + module function var_mask_all_1_cdp_cdp(x, mask, corrected) result(res) + complex(dp), intent(in) :: x(:) + logical, intent(in) :: mask(:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + complex(dp) :: mean + + n = real(count(mask, kind = int64), dp) + mean = sum(x, mask) / n + + res = sum(abs(x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_1_cdp_cdp + module function var_mask_all_2_cdp_cdp(x, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:) + logical, intent(in) :: mask(:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + complex(dp) :: mean + + n = real(count(mask, kind = int64), dp) + mean = sum(x, mask) / n + + res = sum(abs(x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_2_cdp_cdp + module function var_mask_all_3_cdp_cdp(x, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:) + logical, intent(in) :: mask(:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + complex(dp) :: mean + + n = real(count(mask, kind = int64), dp) + mean = sum(x, mask) / n + + res = sum(abs(x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_3_cdp_cdp + module function var_mask_all_4_cdp_cdp(x, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:,:) + logical, intent(in) :: mask(:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + complex(dp) :: mean + + n = real(count(mask, kind = int64), dp) + mean = sum(x, mask) / n + + res = sum(abs(x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_4_cdp_cdp + module function var_mask_all_5_cdp_cdp(x, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + complex(dp) :: mean + + n = real(count(mask, kind = int64), dp) + mean = sum(x, mask) / n + + res = sum(abs(x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_5_cdp_cdp + module function var_mask_all_6_cdp_cdp(x, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + complex(dp) :: mean + + n = real(count(mask, kind = int64), dp) + mean = sum(x, mask) / n + + res = sum(abs(x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_6_cdp_cdp + module function var_mask_all_7_cdp_cdp(x, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + complex(dp) :: mean + + n = real(count(mask, kind = int64), dp) + mean = sum(x, mask) / n + + res = sum(abs(x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_7_cdp_cdp + module function var_mask_all_8_cdp_cdp(x, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + complex(dp) :: mean + + n = real(count(mask, kind = int64), dp) + mean = sum(x, mask) / n + + res = sum(abs(x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_8_cdp_cdp + module function var_mask_all_9_cdp_cdp(x, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + complex(dp) :: mean + + n = real(count(mask, kind = int64), dp) + mean = sum(x, mask) / n + + res = sum(abs(x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_9_cdp_cdp + module function var_mask_all_10_cdp_cdp(x, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + complex(dp) :: mean + + n = real(count(mask, kind = int64), dp) + mean = sum(x, mask) / n + + res = sum(abs(x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_10_cdp_cdp + module function var_mask_all_11_cdp_cdp(x, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + complex(dp) :: mean + + n = real(count(mask, kind = int64), dp) + mean = sum(x, mask) / n + + res = sum(abs(x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_11_cdp_cdp + module function var_mask_all_12_cdp_cdp(x, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + complex(dp) :: mean + + n = real(count(mask, kind = int64), dp) + mean = sum(x, mask) / n + + res = sum(abs(x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_12_cdp_cdp + module function var_mask_all_13_cdp_cdp(x, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + complex(dp) :: mean + + n = real(count(mask, kind = int64), dp) + mean = sum(x, mask) / n + + res = sum(abs(x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_13_cdp_cdp + module function var_mask_all_14_cdp_cdp(x, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + complex(dp) :: mean + + n = real(count(mask, kind = int64), dp) + mean = sum(x, mask) / n + + res = sum(abs(x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_14_cdp_cdp + module function var_mask_all_15_cdp_cdp(x, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + complex(dp) :: mean + + n = real(count(mask, kind = int64), dp) + mean = sum(x, mask) / n + + res = sum(abs(x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_15_cdp_cdp + module function var_mask_all_1_cqp_cqp(x, mask, corrected) result(res) + complex(qp), intent(in) :: x(:) + logical, intent(in) :: mask(:) + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + complex(qp) :: mean + + n = real(count(mask, kind = int64), qp) + mean = sum(x, mask) / n + + res = sum(abs(x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_1_cqp_cqp + module function var_mask_all_2_cqp_cqp(x, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:) + logical, intent(in) :: mask(:,:) + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + complex(qp) :: mean + + n = real(count(mask, kind = int64), qp) + mean = sum(x, mask) / n + + res = sum(abs(x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_2_cqp_cqp + module function var_mask_all_3_cqp_cqp(x, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:) + logical, intent(in) :: mask(:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + complex(qp) :: mean + + n = real(count(mask, kind = int64), qp) + mean = sum(x, mask) / n + + res = sum(abs(x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_3_cqp_cqp + module function var_mask_all_4_cqp_cqp(x, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:,:) + logical, intent(in) :: mask(:,:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + complex(qp) :: mean + + n = real(count(mask, kind = int64), qp) + mean = sum(x, mask) / n + + res = sum(abs(x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_4_cqp_cqp + module function var_mask_all_5_cqp_cqp(x, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + complex(qp) :: mean + + n = real(count(mask, kind = int64), qp) + mean = sum(x, mask) / n + + res = sum(abs(x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_5_cqp_cqp + module function var_mask_all_6_cqp_cqp(x, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + complex(qp) :: mean + + n = real(count(mask, kind = int64), qp) + mean = sum(x, mask) / n + + res = sum(abs(x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_6_cqp_cqp + module function var_mask_all_7_cqp_cqp(x, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + complex(qp) :: mean + + n = real(count(mask, kind = int64), qp) + mean = sum(x, mask) / n + + res = sum(abs(x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_7_cqp_cqp + module function var_mask_all_8_cqp_cqp(x, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + complex(qp) :: mean + + n = real(count(mask, kind = int64), qp) + mean = sum(x, mask) / n + + res = sum(abs(x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_8_cqp_cqp + module function var_mask_all_9_cqp_cqp(x, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + complex(qp) :: mean + + n = real(count(mask, kind = int64), qp) + mean = sum(x, mask) / n + + res = sum(abs(x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_9_cqp_cqp + module function var_mask_all_10_cqp_cqp(x, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + complex(qp) :: mean + + n = real(count(mask, kind = int64), qp) + mean = sum(x, mask) / n + + res = sum(abs(x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_10_cqp_cqp + module function var_mask_all_11_cqp_cqp(x, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + complex(qp) :: mean + + n = real(count(mask, kind = int64), qp) + mean = sum(x, mask) / n + + res = sum(abs(x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_11_cqp_cqp + module function var_mask_all_12_cqp_cqp(x, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + complex(qp) :: mean + + n = real(count(mask, kind = int64), qp) + mean = sum(x, mask) / n + + res = sum(abs(x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_12_cqp_cqp + module function var_mask_all_13_cqp_cqp(x, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + complex(qp) :: mean + + n = real(count(mask, kind = int64), qp) + mean = sum(x, mask) / n + + res = sum(abs(x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_13_cqp_cqp + module function var_mask_all_14_cqp_cqp(x, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + complex(qp) :: mean + + n = real(count(mask, kind = int64), qp) + mean = sum(x, mask) / n + + res = sum(abs(x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_14_cqp_cqp + module function var_mask_all_15_cqp_cqp(x, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res + + real(qp) :: n + complex(qp) :: mean + + n = real(count(mask, kind = int64), qp) + mean = sum(x, mask) / n + + res = sum(abs(x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_15_cqp_cqp + + + module function var_mask_all_1_iint8_dp(x, mask, corrected) result(res) + integer(int8), intent(in) :: x(:) + logical, intent(in) :: mask(:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_1_iint8_dp + module function var_mask_all_2_iint8_dp(x, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:) + logical, intent(in) :: mask(:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_2_iint8_dp + module function var_mask_all_3_iint8_dp(x, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:) + logical, intent(in) :: mask(:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_3_iint8_dp + module function var_mask_all_4_iint8_dp(x, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:,:) + logical, intent(in) :: mask(:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_4_iint8_dp + module function var_mask_all_5_iint8_dp(x, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_5_iint8_dp + module function var_mask_all_6_iint8_dp(x, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_6_iint8_dp + module function var_mask_all_7_iint8_dp(x, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_7_iint8_dp + module function var_mask_all_8_iint8_dp(x, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_8_iint8_dp + module function var_mask_all_9_iint8_dp(x, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_9_iint8_dp + module function var_mask_all_10_iint8_dp(x, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_10_iint8_dp + module function var_mask_all_11_iint8_dp(x, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_11_iint8_dp + module function var_mask_all_12_iint8_dp(x, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_12_iint8_dp + module function var_mask_all_13_iint8_dp(x, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_13_iint8_dp + module function var_mask_all_14_iint8_dp(x, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_14_iint8_dp + module function var_mask_all_15_iint8_dp(x, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_15_iint8_dp + module function var_mask_all_1_iint16_dp(x, mask, corrected) result(res) + integer(int16), intent(in) :: x(:) + logical, intent(in) :: mask(:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_1_iint16_dp + module function var_mask_all_2_iint16_dp(x, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:) + logical, intent(in) :: mask(:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_2_iint16_dp + module function var_mask_all_3_iint16_dp(x, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:) + logical, intent(in) :: mask(:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_3_iint16_dp + module function var_mask_all_4_iint16_dp(x, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:,:) + logical, intent(in) :: mask(:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_4_iint16_dp + module function var_mask_all_5_iint16_dp(x, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_5_iint16_dp + module function var_mask_all_6_iint16_dp(x, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_6_iint16_dp + module function var_mask_all_7_iint16_dp(x, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_7_iint16_dp + module function var_mask_all_8_iint16_dp(x, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_8_iint16_dp + module function var_mask_all_9_iint16_dp(x, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_9_iint16_dp + module function var_mask_all_10_iint16_dp(x, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_10_iint16_dp + module function var_mask_all_11_iint16_dp(x, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_11_iint16_dp + module function var_mask_all_12_iint16_dp(x, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_12_iint16_dp + module function var_mask_all_13_iint16_dp(x, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_13_iint16_dp + module function var_mask_all_14_iint16_dp(x, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_14_iint16_dp + module function var_mask_all_15_iint16_dp(x, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_15_iint16_dp + module function var_mask_all_1_iint32_dp(x, mask, corrected) result(res) + integer(int32), intent(in) :: x(:) + logical, intent(in) :: mask(:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_1_iint32_dp + module function var_mask_all_2_iint32_dp(x, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:) + logical, intent(in) :: mask(:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_2_iint32_dp + module function var_mask_all_3_iint32_dp(x, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:) + logical, intent(in) :: mask(:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_3_iint32_dp + module function var_mask_all_4_iint32_dp(x, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:,:) + logical, intent(in) :: mask(:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_4_iint32_dp + module function var_mask_all_5_iint32_dp(x, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_5_iint32_dp + module function var_mask_all_6_iint32_dp(x, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_6_iint32_dp + module function var_mask_all_7_iint32_dp(x, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_7_iint32_dp + module function var_mask_all_8_iint32_dp(x, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_8_iint32_dp + module function var_mask_all_9_iint32_dp(x, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_9_iint32_dp + module function var_mask_all_10_iint32_dp(x, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_10_iint32_dp + module function var_mask_all_11_iint32_dp(x, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_11_iint32_dp + module function var_mask_all_12_iint32_dp(x, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_12_iint32_dp + module function var_mask_all_13_iint32_dp(x, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_13_iint32_dp + module function var_mask_all_14_iint32_dp(x, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_14_iint32_dp + module function var_mask_all_15_iint32_dp(x, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_15_iint32_dp + module function var_mask_all_1_iint64_dp(x, mask, corrected) result(res) + integer(int64), intent(in) :: x(:) + logical, intent(in) :: mask(:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_1_iint64_dp + module function var_mask_all_2_iint64_dp(x, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:) + logical, intent(in) :: mask(:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_2_iint64_dp + module function var_mask_all_3_iint64_dp(x, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:) + logical, intent(in) :: mask(:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_3_iint64_dp + module function var_mask_all_4_iint64_dp(x, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:,:) + logical, intent(in) :: mask(:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_4_iint64_dp + module function var_mask_all_5_iint64_dp(x, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_5_iint64_dp + module function var_mask_all_6_iint64_dp(x, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_6_iint64_dp + module function var_mask_all_7_iint64_dp(x, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_7_iint64_dp + module function var_mask_all_8_iint64_dp(x, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_8_iint64_dp + module function var_mask_all_9_iint64_dp(x, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_9_iint64_dp + module function var_mask_all_10_iint64_dp(x, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_10_iint64_dp + module function var_mask_all_11_iint64_dp(x, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_11_iint64_dp + module function var_mask_all_12_iint64_dp(x, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_12_iint64_dp + module function var_mask_all_13_iint64_dp(x, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_13_iint64_dp + module function var_mask_all_14_iint64_dp(x, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_14_iint64_dp + module function var_mask_all_15_iint64_dp(x, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_15_iint64_dp + + + module function var_mask_1_rsp_rsp(x, dim, mask, corrected) result(res) + real(sp), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:) + logical, intent(in), optional :: corrected + real(sp) :: res + + integer :: i + real(sp) :: n + real(sp) :: mean + + res = 0._sp + select case(dim) + case(1) + n = count(mask, dim) + mean = sum(x, dim, mask) / n + do i = 1, size(x, dim) + res = res + merge( (x(i) - mean)**2,& + 0._sp,& + mask(i)) + end do + case default + call error_stop("ERROR (var): wrong dimension") + end select + res = res / (n - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_1_rsp_rsp + module function var_mask_2_rsp_rsp(x, dim, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:) + logical, intent(in), optional :: corrected + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_2_rsp_rsp + module function var_mask_3_rsp_rsp(x, dim, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_3_rsp_rsp + module function var_mask_4_rsp_rsp(x, dim, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_4_rsp_rsp + module function var_mask_5_rsp_rsp(x, dim, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_5_rsp_rsp + module function var_mask_6_rsp_rsp(x, dim, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_6_rsp_rsp + module function var_mask_7_rsp_rsp(x, dim, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_7_rsp_rsp + module function var_mask_8_rsp_rsp(x, dim, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_8_rsp_rsp + module function var_mask_9_rsp_rsp(x, dim, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_9_rsp_rsp + module function var_mask_10_rsp_rsp(x, dim, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_10_rsp_rsp + module function var_mask_11_rsp_rsp(x, dim, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_11_rsp_rsp + module function var_mask_12_rsp_rsp(x, dim, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_12_rsp_rsp + module function var_mask_13_rsp_rsp(x, dim, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_13_rsp_rsp + module function var_mask_14_rsp_rsp(x, dim, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_14_rsp_rsp + module function var_mask_15_rsp_rsp(x, dim, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_15_rsp_rsp + module function var_mask_1_rdp_rdp(x, dim, mask, corrected) result(res) + real(dp), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:) + logical, intent(in), optional :: corrected + real(dp) :: res + + integer :: i + real(dp) :: n + real(dp) :: mean + + res = 0._dp + select case(dim) + case(1) + n = count(mask, dim) + mean = sum(x, dim, mask) / n + do i = 1, size(x, dim) + res = res + merge( (x(i) - mean)**2,& + 0._dp,& + mask(i)) + end do + case default + call error_stop("ERROR (var): wrong dimension") + end select + res = res / (n - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_1_rdp_rdp + module function var_mask_2_rdp_rdp(x, dim, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_2_rdp_rdp + module function var_mask_3_rdp_rdp(x, dim, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_3_rdp_rdp + module function var_mask_4_rdp_rdp(x, dim, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_4_rdp_rdp + module function var_mask_5_rdp_rdp(x, dim, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_5_rdp_rdp + module function var_mask_6_rdp_rdp(x, dim, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_6_rdp_rdp + module function var_mask_7_rdp_rdp(x, dim, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_7_rdp_rdp + module function var_mask_8_rdp_rdp(x, dim, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_8_rdp_rdp + module function var_mask_9_rdp_rdp(x, dim, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_9_rdp_rdp + module function var_mask_10_rdp_rdp(x, dim, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_10_rdp_rdp + module function var_mask_11_rdp_rdp(x, dim, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_11_rdp_rdp + module function var_mask_12_rdp_rdp(x, dim, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_12_rdp_rdp + module function var_mask_13_rdp_rdp(x, dim, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_13_rdp_rdp + module function var_mask_14_rdp_rdp(x, dim, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_14_rdp_rdp + module function var_mask_15_rdp_rdp(x, dim, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_15_rdp_rdp + module function var_mask_1_rqp_rqp(x, dim, mask, corrected) result(res) + real(qp), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:) + logical, intent(in), optional :: corrected + real(qp) :: res + + integer :: i + real(qp) :: n + real(qp) :: mean + + res = 0._qp + select case(dim) + case(1) + n = count(mask, dim) + mean = sum(x, dim, mask) / n + do i = 1, size(x, dim) + res = res + merge( (x(i) - mean)**2,& + 0._qp,& + mask(i)) + end do + case default + call error_stop("ERROR (var): wrong dimension") + end select + res = res / (n - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_1_rqp_rqp + module function var_mask_2_rqp_rqp(x, dim, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:) + logical, intent(in), optional :: corrected + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_2_rqp_rqp + module function var_mask_3_rqp_rqp(x, dim, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_3_rqp_rqp + module function var_mask_4_rqp_rqp(x, dim, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_4_rqp_rqp + module function var_mask_5_rqp_rqp(x, dim, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_5_rqp_rqp + module function var_mask_6_rqp_rqp(x, dim, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_6_rqp_rqp + module function var_mask_7_rqp_rqp(x, dim, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_7_rqp_rqp + module function var_mask_8_rqp_rqp(x, dim, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_8_rqp_rqp + module function var_mask_9_rqp_rqp(x, dim, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_9_rqp_rqp + module function var_mask_10_rqp_rqp(x, dim, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_10_rqp_rqp + module function var_mask_11_rqp_rqp(x, dim, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_11_rqp_rqp + module function var_mask_12_rqp_rqp(x, dim, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_12_rqp_rqp + module function var_mask_13_rqp_rqp(x, dim, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_13_rqp_rqp + module function var_mask_14_rqp_rqp(x, dim, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_14_rqp_rqp + module function var_mask_15_rqp_rqp(x, dim, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_15_rqp_rqp + module function var_mask_1_csp_csp(x, dim, mask, corrected) result(res) + complex(sp), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:) + logical, intent(in), optional :: corrected + real(sp) :: res + + integer :: i + real(sp) :: n + complex(sp) :: mean + + res = 0._sp + select case(dim) + case(1) + n = count(mask, dim) + mean = sum(x, dim, mask) / n + do i = 1, size(x, dim) + res = res + merge( abs(x(i) - mean)**2,& + 0._sp,& + mask(i)) + end do + case default + call error_stop("ERROR (var): wrong dimension") + end select + res = res / (n - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_1_csp_csp + module function var_mask_2_csp_csp(x, dim, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:) + logical, intent(in), optional :: corrected + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_2_csp_csp + module function var_mask_3_csp_csp(x, dim, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_3_csp_csp + module function var_mask_4_csp_csp(x, dim, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_4_csp_csp + module function var_mask_5_csp_csp(x, dim, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_5_csp_csp + module function var_mask_6_csp_csp(x, dim, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_6_csp_csp + module function var_mask_7_csp_csp(x, dim, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_7_csp_csp + module function var_mask_8_csp_csp(x, dim, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_8_csp_csp + module function var_mask_9_csp_csp(x, dim, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_9_csp_csp + module function var_mask_10_csp_csp(x, dim, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_10_csp_csp + module function var_mask_11_csp_csp(x, dim, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_11_csp_csp + module function var_mask_12_csp_csp(x, dim, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_12_csp_csp + module function var_mask_13_csp_csp(x, dim, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_13_csp_csp + module function var_mask_14_csp_csp(x, dim, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_14_csp_csp + module function var_mask_15_csp_csp(x, dim, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_15_csp_csp + module function var_mask_1_cdp_cdp(x, dim, mask, corrected) result(res) + complex(dp), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:) + logical, intent(in), optional :: corrected + real(dp) :: res + + integer :: i + real(dp) :: n + complex(dp) :: mean + + res = 0._dp + select case(dim) + case(1) + n = count(mask, dim) + mean = sum(x, dim, mask) / n + do i = 1, size(x, dim) + res = res + merge( abs(x(i) - mean)**2,& + 0._dp,& + mask(i)) + end do + case default + call error_stop("ERROR (var): wrong dimension") + end select + res = res / (n - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_1_cdp_cdp + module function var_mask_2_cdp_cdp(x, dim, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_2_cdp_cdp + module function var_mask_3_cdp_cdp(x, dim, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_3_cdp_cdp + module function var_mask_4_cdp_cdp(x, dim, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_4_cdp_cdp + module function var_mask_5_cdp_cdp(x, dim, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_5_cdp_cdp + module function var_mask_6_cdp_cdp(x, dim, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_6_cdp_cdp + module function var_mask_7_cdp_cdp(x, dim, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_7_cdp_cdp + module function var_mask_8_cdp_cdp(x, dim, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_8_cdp_cdp + module function var_mask_9_cdp_cdp(x, dim, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_9_cdp_cdp + module function var_mask_10_cdp_cdp(x, dim, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_10_cdp_cdp + module function var_mask_11_cdp_cdp(x, dim, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_11_cdp_cdp + module function var_mask_12_cdp_cdp(x, dim, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_12_cdp_cdp + module function var_mask_13_cdp_cdp(x, dim, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_13_cdp_cdp + module function var_mask_14_cdp_cdp(x, dim, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_14_cdp_cdp + module function var_mask_15_cdp_cdp(x, dim, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_15_cdp_cdp + module function var_mask_1_cqp_cqp(x, dim, mask, corrected) result(res) + complex(qp), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:) + logical, intent(in), optional :: corrected + real(qp) :: res + + integer :: i + real(qp) :: n + complex(qp) :: mean + + res = 0._qp + select case(dim) + case(1) + n = count(mask, dim) + mean = sum(x, dim, mask) / n + do i = 1, size(x, dim) + res = res + merge( abs(x(i) - mean)**2,& + 0._qp,& + mask(i)) + end do + case default + call error_stop("ERROR (var): wrong dimension") + end select + res = res / (n - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_1_cqp_cqp + module function var_mask_2_cqp_cqp(x, dim, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:) + logical, intent(in), optional :: corrected + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_2_cqp_cqp + module function var_mask_3_cqp_cqp(x, dim, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_3_cqp_cqp + module function var_mask_4_cqp_cqp(x, dim, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_4_cqp_cqp + module function var_mask_5_cqp_cqp(x, dim, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_5_cqp_cqp + module function var_mask_6_cqp_cqp(x, dim, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_6_cqp_cqp + module function var_mask_7_cqp_cqp(x, dim, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_7_cqp_cqp + module function var_mask_8_cqp_cqp(x, dim, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_8_cqp_cqp + module function var_mask_9_cqp_cqp(x, dim, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_9_cqp_cqp + module function var_mask_10_cqp_cqp(x, dim, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_10_cqp_cqp + module function var_mask_11_cqp_cqp(x, dim, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_11_cqp_cqp + module function var_mask_12_cqp_cqp(x, dim, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_12_cqp_cqp + module function var_mask_13_cqp_cqp(x, dim, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_13_cqp_cqp + module function var_mask_14_cqp_cqp(x, dim, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_14_cqp_cqp + module function var_mask_15_cqp_cqp(x, dim, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_15_cqp_cqp + + + module function var_mask_1_iint8_dp(x, dim, mask, corrected) result(res) + integer(int8), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:) + logical, intent(in), optional :: corrected + real(dp) :: res + + integer :: i + real(dp) :: n + real(dp) :: mean + + res = 0._dp + select case(dim) + case(1) + n = count(mask, dim) + mean = sum(real(x, dp), dim, mask) / n + do i = 1, size(x, dim) + res = res + merge((real(x(i), dp) - mean)**2,& + 0._dp, mask(i)) + end do + case default + call error_stop("ERROR (var): wrong dimension") + end select + res = res / (n - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_1_iint8_dp + module function var_mask_2_iint8_dp(x, dim, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_2_iint8_dp + module function var_mask_3_iint8_dp(x, dim, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_3_iint8_dp + module function var_mask_4_iint8_dp(x, dim, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_4_iint8_dp + module function var_mask_5_iint8_dp(x, dim, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_5_iint8_dp + module function var_mask_6_iint8_dp(x, dim, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_6_iint8_dp + module function var_mask_7_iint8_dp(x, dim, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_7_iint8_dp + module function var_mask_8_iint8_dp(x, dim, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_8_iint8_dp + module function var_mask_9_iint8_dp(x, dim, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_9_iint8_dp + module function var_mask_10_iint8_dp(x, dim, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_10_iint8_dp + module function var_mask_11_iint8_dp(x, dim, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_11_iint8_dp + module function var_mask_12_iint8_dp(x, dim, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_12_iint8_dp + module function var_mask_13_iint8_dp(x, dim, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_13_iint8_dp + module function var_mask_14_iint8_dp(x, dim, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_14_iint8_dp + module function var_mask_15_iint8_dp(x, dim, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_15_iint8_dp + module function var_mask_1_iint16_dp(x, dim, mask, corrected) result(res) + integer(int16), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:) + logical, intent(in), optional :: corrected + real(dp) :: res + + integer :: i + real(dp) :: n + real(dp) :: mean + + res = 0._dp + select case(dim) + case(1) + n = count(mask, dim) + mean = sum(real(x, dp), dim, mask) / n + do i = 1, size(x, dim) + res = res + merge((real(x(i), dp) - mean)**2,& + 0._dp, mask(i)) + end do + case default + call error_stop("ERROR (var): wrong dimension") + end select + res = res / (n - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_1_iint16_dp + module function var_mask_2_iint16_dp(x, dim, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_2_iint16_dp + module function var_mask_3_iint16_dp(x, dim, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_3_iint16_dp + module function var_mask_4_iint16_dp(x, dim, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_4_iint16_dp + module function var_mask_5_iint16_dp(x, dim, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_5_iint16_dp + module function var_mask_6_iint16_dp(x, dim, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_6_iint16_dp + module function var_mask_7_iint16_dp(x, dim, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_7_iint16_dp + module function var_mask_8_iint16_dp(x, dim, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_8_iint16_dp + module function var_mask_9_iint16_dp(x, dim, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_9_iint16_dp + module function var_mask_10_iint16_dp(x, dim, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_10_iint16_dp + module function var_mask_11_iint16_dp(x, dim, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_11_iint16_dp + module function var_mask_12_iint16_dp(x, dim, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_12_iint16_dp + module function var_mask_13_iint16_dp(x, dim, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_13_iint16_dp + module function var_mask_14_iint16_dp(x, dim, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_14_iint16_dp + module function var_mask_15_iint16_dp(x, dim, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_15_iint16_dp + module function var_mask_1_iint32_dp(x, dim, mask, corrected) result(res) + integer(int32), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:) + logical, intent(in), optional :: corrected + real(dp) :: res + + integer :: i + real(dp) :: n + real(dp) :: mean + + res = 0._dp + select case(dim) + case(1) + n = count(mask, dim) + mean = sum(real(x, dp), dim, mask) / n + do i = 1, size(x, dim) + res = res + merge((real(x(i), dp) - mean)**2,& + 0._dp, mask(i)) + end do + case default + call error_stop("ERROR (var): wrong dimension") + end select + res = res / (n - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_1_iint32_dp + module function var_mask_2_iint32_dp(x, dim, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_2_iint32_dp + module function var_mask_3_iint32_dp(x, dim, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_3_iint32_dp + module function var_mask_4_iint32_dp(x, dim, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_4_iint32_dp + module function var_mask_5_iint32_dp(x, dim, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_5_iint32_dp + module function var_mask_6_iint32_dp(x, dim, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_6_iint32_dp + module function var_mask_7_iint32_dp(x, dim, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_7_iint32_dp + module function var_mask_8_iint32_dp(x, dim, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_8_iint32_dp + module function var_mask_9_iint32_dp(x, dim, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_9_iint32_dp + module function var_mask_10_iint32_dp(x, dim, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_10_iint32_dp + module function var_mask_11_iint32_dp(x, dim, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_11_iint32_dp + module function var_mask_12_iint32_dp(x, dim, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_12_iint32_dp + module function var_mask_13_iint32_dp(x, dim, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_13_iint32_dp + module function var_mask_14_iint32_dp(x, dim, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_14_iint32_dp + module function var_mask_15_iint32_dp(x, dim, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_15_iint32_dp + module function var_mask_1_iint64_dp(x, dim, mask, corrected) result(res) + integer(int64), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:) + logical, intent(in), optional :: corrected + real(dp) :: res + + integer :: i + real(dp) :: n + real(dp) :: mean + + res = 0._dp + select case(dim) + case(1) + n = count(mask, dim) + mean = sum(real(x, dp), dim, mask) / n + do i = 1, size(x, dim) + res = res + merge((real(x(i), dp) - mean)**2,& + 0._dp, mask(i)) + end do + case default + call error_stop("ERROR (var): wrong dimension") + end select + res = res / (n - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_1_iint64_dp + module function var_mask_2_iint64_dp(x, dim, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_2_iint64_dp + module function var_mask_3_iint64_dp(x, dim, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_3_iint64_dp + module function var_mask_4_iint64_dp(x, dim, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_4_iint64_dp + module function var_mask_5_iint64_dp(x, dim, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_5_iint64_dp + module function var_mask_6_iint64_dp(x, dim, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_6_iint64_dp + module function var_mask_7_iint64_dp(x, dim, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_7_iint64_dp + module function var_mask_8_iint64_dp(x, dim, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_8_iint64_dp + module function var_mask_9_iint64_dp(x, dim, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_9_iint64_dp + module function var_mask_10_iint64_dp(x, dim, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_10_iint64_dp + module function var_mask_11_iint64_dp(x, dim, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_11_iint64_dp + module function var_mask_12_iint64_dp(x, dim, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_12_iint64_dp + module function var_mask_13_iint64_dp(x, dim, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_13_iint64_dp + module function var_mask_14_iint64_dp(x, dim, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_14_iint64_dp + module function var_mask_15_iint64_dp(x, dim, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_15_iint64_dp + +end submodule diff --git a/src/fpm/stdlib_string_type.f90 b/src/fpm/stdlib_string_type.f90 new file mode 100644 index 000000000..14581437e --- /dev/null +++ b/src/fpm/stdlib_string_type.f90 @@ -0,0 +1,1272 @@ +! SPDX-Identifier: MIT + +!> Implementation of a string type to hold an arbitrary sequence of characters. +!> +!> This module provides string type compatible with all Fortran instrinsic character +!> procedures as well as overloaded operators for working with character variables. +!> +!> A string type can be easily constructed by creating a new instance from a +!> character variable or literal by invoking its constructor or by assigning it +!> to a string type. Generally, the string type behaves similar to a deferred +!> length character in most regards but adds memory access safety. +!> +!> The specification of this module is available [here](../page/specs/stdlib_string_type.html). +module stdlib_string_type + use stdlib_ascii, only: to_lower_ => to_lower, to_upper_ => to_upper, & + & to_title_ => to_title, to_sentence_ => to_sentence, reverse_ => reverse, to_string + use stdlib_kinds, only : int8, int16, int32, int64, lk, c_bool + implicit none + private + + public :: string_type + public :: len, len_trim, trim, index, scan, verify, repeat, adjustr, adjustl + public :: lgt, lge, llt, lle, char, ichar, iachar + public :: to_lower, to_upper, to_title, to_sentence, reverse + public :: assignment(=) + public :: operator(>), operator(>=), operator(<), operator(<=) + public :: operator(==), operator(/=), operator(//) + public :: write(formatted), write(unformatted) + public :: read(formatted), read(unformatted) + + + integer, parameter :: long = selected_int_kind(18) + + + !> String type holding an arbitrary sequence of characters. + type :: string_type + ! Use the sequence statement below as a hack to prevent extending this type. + ! It is not used for storage association. + sequence + private + character(len=:), allocatable :: raw + end type string_type + + !> Constructor for new string instances + interface string_type + module procedure :: new_string + module procedure :: new_string_from_integer_int8 + module procedure :: new_string_from_integer_int16 + module procedure :: new_string_from_integer_int32 + module procedure :: new_string_from_integer_int64 + module procedure :: new_string_from_logical_lk + module procedure :: new_string_from_logical_c_bool + end interface string_type + + + !> Returns the length of the character sequence represented by the string. + !> + !> This method is elemental and returns a default integer scalar value. + interface len + module procedure :: len_string + end interface len + + !> Returns the length of the character sequence without trailing spaces + !> represented by the string. + !> + !> This method is elemental and returns a default integer scalar value. + interface len_trim + module procedure :: len_trim_string + end interface len_trim + + !> Returns the character sequence hold by the string without trailing spaces. + !> + !> This method is elemental and returns a scalar character value. + interface trim + module procedure :: trim_string + end interface trim + + !> Left-adjust the character sequence represented by the string. + !> The length of the character sequence remains unchanged. + !> + !> This method is elemental and returns a scalar character value. + interface adjustl + module procedure :: adjustl_string + end interface adjustl + + !> Right-adjust the character sequence represented by the string. + !> The length of the character sequence remains unchanged. + !> + !> This method is elemental and returns a scalar character value. + interface adjustr + module procedure :: adjustr_string + end interface adjustr + + !> Repeats the character sequence hold by the string by the number of + !> specified copies. + !> + !> This method is elemental and returns a scalar character value. + interface repeat + module procedure :: repeat_string + end interface repeat + + !> Returns the lowercase version of the character sequence hold by the input string + !> + !> This method is Elemental and returns a new string_type instance which holds this + !> lowercase character sequence + interface to_lower + module procedure :: to_lower_string + end interface to_lower + + !> Returns the uppercase version of the character sequence hold by the input string + !> + !> This method is Elemental and returns a new string_type instance which holds this + !> uppercase character sequence + interface to_upper + module procedure :: to_upper_string + end interface to_upper + + !> Returns the titlecase version of the character sequence hold by the input string + !> + !> This method is Elemental and returns a new string_type instance which holds this + !> titlecase character sequence + interface to_title + module procedure :: to_title_string + end interface to_title + + !> Returns the sentencecase version of the character sequence hold by the input string + !> + !> This method is elemental and returns a new string_type instance which holds this + !> sentencecase character sequence + interface to_sentence + module procedure :: to_sentence_string + end interface to_sentence + + !> Reverses the character sequence hold by the input string + !> + !> This method is elemental and returns a new string_type instance which holds this + !> reverse character sequence + interface reverse + module procedure :: reverse_string + end interface reverse + + !> Return the character sequence represented by the string. + !> + !> This method is elemental and returns a scalar character value. + interface char + module procedure :: char_string + module procedure :: char_string_pos + module procedure :: char_string_range + end interface char + + !> Character-to-integer conversion function. + !> + !> This method is elemental and returns a default integer scalar value. + interface ichar + module procedure :: ichar_string + end interface ichar + + !> Code in ASCII collating sequence. + !> + !> This method is elemental and returns a default integer scalar value. + interface iachar + module procedure :: iachar_string + end interface iachar + + !> Position of a *substring* within a *string*. + !> + !> Returns the position of the start of the leftmost or rightmost occurrence + !> of string *substring* in *string*, counting from one. If *substring* is not + !> present in *string*, zero is returned. + !> + !> This method is elemental and returns a default integer scalar value. + interface index + module procedure :: index_string_string + module procedure :: index_string_char + module procedure :: index_char_string + end interface index + + !> Scan a *string* for the presence of a *set* of characters. Scans a *string* for + !> any of the characters in a *set* of characters. + !> + !> If *back* is either absent or *false*, this function returns the position + !> of the leftmost character of *string* that is in *set*. If *back* is *true*, + !> the rightmost position is returned. If no character of *set* is found in + !> *string*, the result is zero. + !> + !> This method is elemental and returns a default integer scalar value. + interface scan + module procedure :: scan_string_string + module procedure :: scan_string_char + module procedure :: scan_char_string + end interface scan + + !> Scan a string for the absence of a set of characters. Verifies that all + !> the characters in string belong to the set of characters in set. + !> + !> If *back* is either absent or *false*, this function returns the position + !> of the leftmost character of *string* that is not in *set*. If *back* is *true*, + !> the rightmost position is returned. If all characters of *string* are found + !> in *set*, the result is zero. + !> + !> This method is elemental and returns a default integer scalar value. + interface verify + module procedure :: verify_string_string + module procedure :: verify_string_char + module procedure :: verify_char_string + end interface verify + + !> Lexically compare the order of two character sequences being greater, + !> The left-hand side, the right-hand side or both character sequences can + !> be represented by a string. + !> + !> This method is elemental and returns a default logical scalar value. + interface lgt + module procedure :: lgt_string_string + module procedure :: lgt_string_char + module procedure :: lgt_char_string + end interface lgt + + !> Lexically compare the order of two character sequences being less, + !> The left-hand side, the right-hand side or both character sequences can + !> be represented by a string. + !> + !> This method is elemental and returns a default logical scalar value. + interface llt + module procedure :: llt_string_string + module procedure :: llt_string_char + module procedure :: llt_char_string + end interface llt + + !> Lexically compare the order of two character sequences being greater equal, + !> The left-hand side, the right-hand side or both character sequences can + !> be represented by a string. + !> + !> This method is elemental and returns a default logical scalar value. + interface lge + module procedure :: lge_string_string + module procedure :: lge_string_char + module procedure :: lge_char_string + end interface lge + + !> Lexically compare the order of two character sequences being less equal, + !> The left-hand side, the right-hand side or both character sequences can + !> be represented by a string. + !> + !> This method is elemental and returns a default logical scalar value. + interface lle + module procedure :: lle_string_string + module procedure :: lle_string_char + module procedure :: lle_char_string + end interface lle + + !> Assign a character sequence to a string. + interface assignment(=) + module procedure :: assign_string_char + end interface assignment(=) + + !> Compare two character sequences for being greater, the left-hand side, + !> the right-hand side or both character sequences can be represented by + !> a string. + !> + !> This operator is elemental and returns a default logical scalar value. + interface operator(>) + module procedure :: gt_string_string + module procedure :: gt_string_char + module procedure :: gt_char_string + end interface operator(>) + + !> Compare two character sequences for being less, the left-hand side, + !> the right-hand side or both character sequences can be represented by + !> a string. + !> + !> This operator is elemental and returns a default logical scalar value. + interface operator(<) + module procedure :: lt_string_string + module procedure :: lt_string_char + module procedure :: lt_char_string + end interface operator(<) + + !> Compare two character sequences for being greater than, the left-hand side, + !> the right-hand side or both character sequences can be represented by + !> a string. + !> + !> This operator is elemental and returns a default logical scalar value. + interface operator(>=) + module procedure :: ge_string_string + module procedure :: ge_string_char + module procedure :: ge_char_string + end interface operator(>=) + + !> Compare two character sequences for being less than, the left-hand side, + !> the right-hand side or both character sequences can be represented by + !> a string. + !> + !> This operator is elemental and returns a default logical scalar value. + interface operator(<=) + module procedure :: le_string_string + module procedure :: le_string_char + module procedure :: le_char_string + end interface operator(<=) + + !> Compare two character sequences for equality, the left-hand side, + !> the right-hand side or both character sequences can be represented by + !> a string. + !> + !> This operator is elemental and returns a default logical scalar value. + interface operator(==) + module procedure :: eq_string_string + module procedure :: eq_string_char + module procedure :: eq_char_string + end interface operator(==) + + !> Compare two character sequences for inequality, the left-hand side, + !> the right-hand side or both character sequences can be represented by + !> a string. + !> + !> This operator is elemental and returns a default logical scalar value. + interface operator(/=) + module procedure :: ne_string_string + module procedure :: ne_string_char + module procedure :: ne_char_string + end interface operator(/=) + + !> Concatenate two character sequences, the left-hand side, the right-hand side + !> or both character sequences can be represented by a string. + !> + !> This operator is elemental and returns a scalar character value. + interface operator(//) + module procedure :: concat_string_string + module procedure :: concat_string_char + module procedure :: concat_char_string + end interface operator(//) + + !> Write the character sequence hold by the string to a connected formatted + !> unit. + interface write(formatted) + module procedure :: write_formatted + end interface + + !> Write the character sequence hold by the string to a connected unformatted + !> unit. + interface write(unformatted) + module procedure :: write_unformatted + end interface + + !> Read a character sequence from a connected unformatted unit into the string. + interface read(formatted) + module procedure :: read_formatted + end interface + + !> Read a character sequence from a connected unformatted unit into the string. + interface read(unformatted) + module procedure :: read_unformatted + end interface + + +contains + + + !> Constructor for new string instances from a scalar character value. + elemental function new_string(string) result(new) + character(len=*), intent(in), optional :: string + type(string_type) :: new + if (present(string)) then + new%raw = string + end if + end function new_string + + !> Constructor for new string instances from an integer of kind int8. + elemental function new_string_from_integer_int8(val) result(new) + integer(int8), intent(in) :: val + type(string_type) :: new + new%raw = to_string(val) + end function new_string_from_integer_int8 + !> Constructor for new string instances from an integer of kind int16. + elemental function new_string_from_integer_int16(val) result(new) + integer(int16), intent(in) :: val + type(string_type) :: new + new%raw = to_string(val) + end function new_string_from_integer_int16 + !> Constructor for new string instances from an integer of kind int32. + elemental function new_string_from_integer_int32(val) result(new) + integer(int32), intent(in) :: val + type(string_type) :: new + new%raw = to_string(val) + end function new_string_from_integer_int32 + !> Constructor for new string instances from an integer of kind int64. + elemental function new_string_from_integer_int64(val) result(new) + integer(int64), intent(in) :: val + type(string_type) :: new + new%raw = to_string(val) + end function new_string_from_integer_int64 + + !> Constructor for new string instances from a logical of kind lk. + elemental function new_string_from_logical_lk(val) result(new) + logical(lk), intent(in) :: val + type(string_type) :: new + new%raw = to_string(val) + end function new_string_from_logical_lk + !> Constructor for new string instances from a logical of kind c_bool. + elemental function new_string_from_logical_c_bool(val) result(new) + logical(c_bool), intent(in) :: val + type(string_type) :: new + new%raw = to_string(val) + end function new_string_from_logical_c_bool + + + !> Assign a character sequence to a string. + elemental subroutine assign_string_char(lhs, rhs) + type(string_type), intent(inout) :: lhs + character(len=*), intent(in) :: rhs + lhs%raw = rhs + end subroutine assign_string_char + + + !> Returns the length of the character sequence represented by the string. + elemental function len_string(string) result(length) + type(string_type), intent(in) :: string + integer :: length + + if (allocated(string%raw)) then + length = len(string%raw) + else + length = 0 + end if + + end function len_string + + + !> Returns the length of the character sequence without trailing spaces + !> represented by the string. + elemental function len_trim_string(string) result(length) + type(string_type), intent(in) :: string + integer :: length + + length = merge(len_trim(string%raw), 0, allocated(string%raw)) + + end function len_trim_string + + + !> Character-to-integer conversion function. + elemental function ichar_string(string) result(ich) + type(string_type), intent(in) :: string + integer :: ich + + if (allocated(string%raw) .and. len(string) > 0) then + ich = ichar(string%raw(1:1)) + else + ich = 0 + end if + + end function ichar_string + + + !> Code in ASCII collating sequence. + elemental function iachar_string(string) result(ich) + type(string_type), intent(in) :: string + integer :: ich + + if (allocated(string%raw) .and. len(string) > 0) then + ich = iachar(string%raw(1:1)) + else + ich = 0 + end if + + end function iachar_string + + + !> Return the character sequence represented by the string. + pure function char_string(string) result(character_string) + type(string_type), intent(in) :: string + character(len=len(string)) :: character_string + + character_string = maybe(string) + + end function char_string + + !> Return the character sequence represented by the string. + elemental function char_string_pos(string, pos) result(character_string) + type(string_type), intent(in) :: string + integer, intent(in) :: pos + character(len=1) :: character_string + + character_string = merge(string%raw(pos:pos), ' ', allocated(string%raw)) + + end function char_string_pos + + !> Return the character sequence represented by the string. + pure function char_string_range(string, start, last) result(character_string) + type(string_type), intent(in) :: string + integer, intent(in) :: start + integer, intent(in) :: last + character(len=last-start+1) :: character_string + + character_string = merge(string%raw(int(start, long):int(last, long)), & + repeat(' ', int(len(character_string), long)), allocated(string%raw)) + + end function char_string_range + + + !> Returns the character sequence hold by the string without trailing spaces. + elemental function trim_string(string) result(trimmed_string) + type(string_type), intent(in) :: string + type(string_type) :: trimmed_string + + trimmed_string = trim(maybe(string)) + + end function trim_string + + + !> Left-adjust the character sequence represented by the string. + !> The length of the character sequence remains unchanged. + elemental function adjustl_string(string) result(adjusted_string) + type(string_type), intent(in) :: string + type(string_type) :: adjusted_string + + adjusted_string = adjustl(maybe(string)) + + end function adjustl_string + + + !> Right-adjust the character sequence represented by the string. + !> The length of the character sequence remains unchanged. + elemental function adjustr_string(string) result(adjusted_string) + type(string_type), intent(in) :: string + type(string_type) :: adjusted_string + + adjusted_string = adjustr(maybe(string)) + + end function adjustr_string + + + !> Repeats the character sequence hold by the string by the number of + !> specified copies. + elemental function repeat_string(string, ncopies) result(repeated_string) + type(string_type), intent(in) :: string + integer, intent(in) :: ncopies + type(string_type) :: repeated_string + + repeated_string = repeat(maybe(string), ncopies) + + end function repeat_string + + + !> Convert the character sequence hold by the input string to lower case + elemental function to_lower_string(string) result(lowercase_string) + type(string_type), intent(in) :: string + type(string_type) :: lowercase_string + + lowercase_string%raw = to_lower_(maybe(string)) + + end function to_lower_string + + + !> Convert the character sequence hold by the input string to upper case + elemental function to_upper_string(string) result(uppercase_string) + type(string_type), intent(in) :: string + type(string_type) :: uppercase_string + + uppercase_string%raw = to_upper_(maybe(string)) + + end function to_upper_string + + + !> Convert the character sequence hold by the input string to title case + elemental function to_title_string(string) result(titlecase_string) + type(string_type), intent(in) :: string + type(string_type) :: titlecase_string + + titlecase_string%raw = to_title_(maybe(string)) + + end function to_title_string + + !> Convert the character sequence hold by the input string to sentence case + elemental function to_sentence_string(string) result(sentence_string) + type(string_type), intent(in) :: string + type(string_type) :: sentence_string + + sentence_string%raw = to_sentence_(maybe(string)) + + end function to_sentence_string + + + !> Reverse the character sequence hold by the input string + elemental function reverse_string(string) result(reversed_string) + type(string_type), intent(in) :: string + type(string_type) :: reversed_string + + reversed_string%raw = reverse_(maybe(string)) + + end function reverse_string + + + !> Position of a sequence of character within a character sequence. + !> In this version both character sequences are represented by a string. + elemental function index_string_string(string, substring, back) result(pos) + type(string_type), intent(in) :: string + type(string_type), intent(in) :: substring + logical, intent(in), optional :: back + integer :: pos + + if (present(back)) then + pos = index(maybe(string), maybe(substring), back) + else + pos = index(maybe(string), maybe(substring), .false.) + end if + + end function index_string_string + + !> Position of a sequence of character within a character sequence. + !> In this version the main character sequence is represented by a string. + elemental function index_string_char(string, substring, back) result(pos) + type(string_type), intent(in) :: string + character(len=*), intent(in) :: substring + logical, intent(in), optional :: back + integer :: pos + + if (present(back)) then + pos = index(maybe(string), substring, back) + else + pos = index(maybe(string), substring, .false.) + end if + + end function index_string_char + + !> Position of a sequence of character within a character sequence. + !> In this version the sub character sequence is represented by a string. + elemental function index_char_string(string, substring, back) result(pos) + character(len=*), intent(in) :: string + type(string_type), intent(in) :: substring + logical, intent(in), optional :: back + integer :: pos + + if (present(back)) then + pos = index(string, maybe(substring), back) + else + pos = index(string, maybe(substring), .false.) + end if + + end function index_char_string + + + !> Scan a character sequence for any of the characters in a set of characters. + !> In this version both the character sequence and the character set are + !> represented by a string. + elemental function scan_string_string(string, set, back) result(pos) + type(string_type), intent(in) :: string + type(string_type), intent(in) :: set + logical, intent(in), optional :: back + integer :: pos + + if (present(back)) then + pos = scan(maybe(string), maybe(set), back) + else + pos = scan(maybe(string), maybe(set), .false.) + end if + + end function scan_string_string + + !> Scan a character sequence for any of the characters in a set of characters. + !> In this version the character sequences is represented by a string. + elemental function scan_string_char(string, set, back) result(pos) + type(string_type), intent(in) :: string + character(len=*), intent(in) :: set + logical, intent(in), optional :: back + integer :: pos + + if (present(back)) then + pos = scan(maybe(string), set, back) + else + pos = scan(maybe(string), set, .false.) + end if + + end function scan_string_char + + !> Scan a character sequence for any of the characters in a set of characters. + !> In this version the set of characters is represented by a string. + elemental function scan_char_string(string, set, back) result(pos) + character(len=*), intent(in) :: string + type(string_type), intent(in) :: set + logical, intent(in), optional :: back + integer :: pos + + if (present(back)) then + pos = scan(string, maybe(set), back) + else + pos = scan(string, maybe(set), .false.) + end if + + end function scan_char_string + + + !> Verify a character sequence for the absence any of the characters in + !> a set of characters. In this version both the character sequence and + !> the character set are represented by a string. + elemental function verify_string_string(string, set, back) result(pos) + type(string_type), intent(in) :: string + type(string_type), intent(in) :: set + logical, intent(in), optional :: back + integer :: pos + + if (present(back)) then + pos = verify(maybe(string), maybe(set), back) + else + pos = verify(maybe(string), maybe(set), .false.) + end if + + end function verify_string_string + + !> Verify a character sequence for the absence any of the characters in + !> a set of characters. In this version the character sequences is + !> represented by a string. + elemental function verify_string_char(string, set, back) result(pos) + type(string_type), intent(in) :: string + character(len=*), intent(in) :: set + logical, intent(in), optional :: back + integer :: pos + + if (present(back)) then + pos = verify(maybe(string), set, back) + else + pos = verify(maybe(string), set, .false.) + end if + + end function verify_string_char + + !> Verify a character sequence for the absence any of the characters in + !> a set of characters. In this version the set of characters is + !> represented by a string. + elemental function verify_char_string(string, set, back) result(pos) + character(len=*), intent(in) :: string + type(string_type), intent(in) :: set + logical, intent(in), optional :: back + integer :: pos + + if (present(back)) then + pos = verify(string, maybe(set), back) + else + pos = verify(string, maybe(set), .false.) + end if + + end function verify_char_string + + + !> Compare two character sequences for being greater. + !> In this version both character sequences are by a string. + elemental function gt_string_string(lhs, rhs) result(is_gt) + type(string_type), intent(in) :: lhs + type(string_type), intent(in) :: rhs + logical :: is_gt + + is_gt = maybe(lhs) > maybe(rhs) + + end function gt_string_string + + !> Compare two character sequences for being greater. + !> In this version the left-hand side character sequences is by a string. + elemental function gt_string_char(lhs, rhs) result(is_gt) + type(string_type), intent(in) :: lhs + character(len=*), intent(in) :: rhs + logical :: is_gt + + is_gt = maybe(lhs) > rhs + + end function gt_string_char + + !> Compare two character sequences for being greater. + !> In this version the right-hand side character sequences is by a string. + elemental function gt_char_string(lhs, rhs) result(is_gt) + character(len=*), intent(in) :: lhs + type(string_type), intent(in) :: rhs + logical :: is_gt + + is_gt = lhs > maybe(rhs) + + end function gt_char_string + + + !> Compare two character sequences for being less. + !> In this version both character sequences are by a string. + elemental function lt_string_string(lhs, rhs) result(is_lt) + type(string_type), intent(in) :: lhs + type(string_type), intent(in) :: rhs + logical :: is_lt + + is_lt = rhs > lhs + + end function lt_string_string + + + !> Compare two character sequences for being less. + !> In this version the left-hand side character sequences is by a string. + elemental function lt_string_char(lhs, rhs) result(is_lt) + type(string_type), intent(in) :: lhs + character(len=*), intent(in) :: rhs + logical :: is_lt + + is_lt = rhs > lhs + + end function lt_string_char + + !> Compare two character sequences for being less. + !> In this version the right-hand side character sequences is by a string. + elemental function lt_char_string(lhs, rhs) result(is_lt) + character(len=*), intent(in) :: lhs + type(string_type), intent(in) :: rhs + logical :: is_lt + + is_lt = rhs > lhs + + end function lt_char_string + + + !> Compare two character sequences for being greater or equal. + !> In this version both character sequences are by a string. + elemental function ge_string_string(lhs, rhs) result(is_ge) + type(string_type), intent(in) :: lhs + type(string_type), intent(in) :: rhs + logical :: is_ge + + is_ge = .not. (rhs > lhs) + + end function ge_string_string + + !> Compare two character sequences for being greater or equal. + !> In this version the left-hand side character sequences is by a string. + elemental function ge_string_char(lhs, rhs) result(is_ge) + type(string_type), intent(in) :: lhs + character(len=*), intent(in) :: rhs + logical :: is_ge + + is_ge = .not. (rhs > lhs) + + end function ge_string_char + + !> Compare two character sequences for being greater or equal + !> In this version the right-hand side character sequences is by a string. + elemental function ge_char_string(lhs, rhs) result(is_ge) + character(len=*), intent(in) :: lhs + type(string_type), intent(in) :: rhs + logical :: is_ge + + is_ge = .not. (rhs > lhs) + + end function ge_char_string + + + !> Compare two character sequences for being less or equal. + !> In this version both character sequences are by a string. + elemental function le_string_string(lhs, rhs) result(is_le) + type(string_type), intent(in) :: lhs + type(string_type), intent(in) :: rhs + logical :: is_le + + is_le = .not. (lhs > rhs) + + end function le_string_string + + !> Compare two character sequences for being less or equal. + !> In this version the left-hand side character sequences is by a string. + elemental function le_string_char(lhs, rhs) result(is_le) + type(string_type), intent(in) :: lhs + character(len=*), intent(in) :: rhs + logical :: is_le + + is_le = .not. (lhs > rhs) + + end function le_string_char + + !> Compare two character sequences for being less or equal + !> In this version the right-hand side character sequences is by a string. + elemental function le_char_string(lhs, rhs) result(is_le) + character(len=*), intent(in) :: lhs + type(string_type), intent(in) :: rhs + logical :: is_le + + is_le = .not. (lhs > rhs) + + end function le_char_string + + + !> Compare two character sequences for equality. + !> In this version both character sequences are by a string. + elemental function eq_string_string(lhs, rhs) result(is_eq) + type(string_type), intent(in) :: lhs + type(string_type), intent(in) :: rhs + logical :: is_eq + + is_eq = .not.(lhs > rhs) + if (is_eq) then + is_eq = .not.(rhs > lhs) + end if + + end function eq_string_string + + !> Compare two character sequences for equality. + !> In this version the left-hand side character sequences is by a string. + elemental function eq_string_char(lhs, rhs) result(is_eq) + type(string_type), intent(in) :: lhs + character(len=*), intent(in) :: rhs + logical :: is_eq + + is_eq = .not.(lhs > rhs) + if (is_eq) then + is_eq = .not.(rhs > lhs) + end if + + end function eq_string_char + + !> Compare two character sequences for equality. + !> In this version the right-hand side character sequences is by a string. + elemental function eq_char_string(lhs, rhs) result(is_eq) + character(len=*), intent(in) :: lhs + type(string_type), intent(in) :: rhs + logical :: is_eq + + is_eq = .not.(lhs > rhs) + if (is_eq) then + is_eq = .not.(rhs > lhs) + end if + + end function eq_char_string + + + !> Compare two character sequences for inequality. + !> In this version both character sequences are by a string. + elemental function ne_string_string(lhs, rhs) result(is_ne) + type(string_type), intent(in) :: lhs + type(string_type), intent(in) :: rhs + logical :: is_ne + + is_ne = lhs > rhs + if (.not.is_ne) then + is_ne = rhs > lhs + end if + + end function ne_string_string + + !> Compare two character sequences for inequality. + !> In this version the left-hand side character sequences is by a string. + elemental function ne_string_char(lhs, rhs) result(is_ne) + type(string_type), intent(in) :: lhs + character(len=*), intent(in) :: rhs + logical :: is_ne + + is_ne = lhs > rhs + if (.not.is_ne) then + is_ne = rhs > lhs + end if + + end function ne_string_char + + !> Compare two character sequences for inequality. + !> In this version the right-hand side character sequences is by a string. + elemental function ne_char_string(lhs, rhs) result(is_ne) + character(len=*), intent(in) :: lhs + type(string_type), intent(in) :: rhs + logical :: is_ne + + is_ne = lhs > rhs + if (.not.is_ne) then + is_ne = rhs > lhs + end if + + end function ne_char_string + + + !> Lexically compare two character sequences for being greater. + !> In this version both character sequences are by a string. + elemental function lgt_string_string(lhs, rhs) result(is_lgt) + type(string_type), intent(in) :: lhs + type(string_type), intent(in) :: rhs + logical :: is_lgt + + is_lgt = lgt(maybe(lhs), maybe(rhs)) + + end function lgt_string_string + + !> Lexically compare two character sequences for being greater. + !> In this version the left-hand side character sequences is by a string. + elemental function lgt_string_char(lhs, rhs) result(is_lgt) + type(string_type), intent(in) :: lhs + character(len=*), intent(in) :: rhs + logical :: is_lgt + + is_lgt = lgt(maybe(lhs), rhs) + + end function lgt_string_char + + !> Lexically compare two character sequences for being greater. + !> In this version the right-hand side character sequences is by a string. + elemental function lgt_char_string(lhs, rhs) result(is_lgt) + character(len=*), intent(in) :: lhs + type(string_type), intent(in) :: rhs + logical :: is_lgt + + is_lgt = lgt(lhs, maybe(rhs)) + + end function lgt_char_string + + + !> Lexically compare two character sequences for being less. + !> In this version both character sequences are by a string. + elemental function llt_string_string(lhs, rhs) result(is_llt) + type(string_type), intent(in) :: lhs + type(string_type), intent(in) :: rhs + logical :: is_llt + + is_llt = llt(maybe(lhs), maybe(rhs)) + + end function llt_string_string + + !> Lexically compare two character sequences for being less. + !> In this version the left-hand side character sequences is by a string. + elemental function llt_string_char(lhs, rhs) result(is_llt) + type(string_type), intent(in) :: lhs + character(len=*), intent(in) :: rhs + logical :: is_llt + + is_llt = llt(maybe(lhs), rhs) + + end function llt_string_char + + !> Lexically compare two character sequences for being less. + !> In this version the right-hand side character sequences is by a string. + elemental function llt_char_string(lhs, rhs) result(is_llt) + character(len=*), intent(in) :: lhs + type(string_type), intent(in) :: rhs + logical :: is_llt + + is_llt = llt(lhs, maybe(rhs)) + + end function llt_char_string + + + !> Lexically compare two character sequences for being greater or equal. + !> In this version both character sequences are by a string. + elemental function lge_string_string(lhs, rhs) result(is_lge) + type(string_type), intent(in) :: lhs + type(string_type), intent(in) :: rhs + logical :: is_lge + + is_lge = lge(maybe(lhs), maybe(rhs)) + + end function lge_string_string + + !> Lexically compare two character sequences for being greater or equal. + !> In this version the left-hand side character sequences is by a string. + elemental function lge_string_char(lhs, rhs) result(is_lge) + type(string_type), intent(in) :: lhs + character(len=*), intent(in) :: rhs + logical :: is_lge + + is_lge = lge(maybe(lhs), rhs) + + end function lge_string_char + + !> Lexically compare two character sequences for being greater or equal + !> In this version the right-hand side character sequences is by a string. + elemental function lge_char_string(lhs, rhs) result(is_lge) + character(len=*), intent(in) :: lhs + type(string_type), intent(in) :: rhs + logical :: is_lge + + is_lge = lge(lhs, maybe(rhs)) + + end function lge_char_string + + + !> Lexically compare two character sequences for being less or equal. + !> In this version both character sequences are by a string. + elemental function lle_string_string(lhs, rhs) result(is_lle) + type(string_type), intent(in) :: lhs + type(string_type), intent(in) :: rhs + logical :: is_lle + + is_lle = lle(maybe(lhs), maybe(rhs)) + + end function lle_string_string + + !> Lexically compare two character sequences for being less or equal. + !> In this version the left-hand side character sequences is by a string. + elemental function lle_string_char(lhs, rhs) result(is_lle) + type(string_type), intent(in) :: lhs + character(len=*), intent(in) :: rhs + logical :: is_lle + + is_lle = lle(maybe(lhs), rhs) + + end function lle_string_char + + !> Lexically compare two character sequences for being less or equal + !> In this version the right-hand side character sequences is by a string. + elemental function lle_char_string(lhs, rhs) result(is_lle) + character(len=*), intent(in) :: lhs + type(string_type), intent(in) :: rhs + logical :: is_lle + + is_lle = lle(lhs, maybe(rhs)) + + end function lle_char_string + + + !> Concatenate two character sequences. + !> In this version both character sequences are by a string. + elemental function concat_string_string(lhs, rhs) result(string) + type(string_type), intent(in) :: lhs + type(string_type), intent(in) :: rhs + type(string_type) :: string + + string%raw = maybe(rhs) // maybe(lhs) + + end function concat_string_string + + !> Concatenate two character sequences. + !> In this version the left-hand side character sequences is by a string. + elemental function concat_string_char(lhs, rhs) result(string) + type(string_type), intent(in) :: lhs + character(len=*), intent(in) :: rhs + type(string_type) :: string + + string%raw = maybe(lhs) // rhs + + end function concat_string_char + + !> Concatenate two character sequences. + !> In this version the right-hand side character sequences is by a string. + elemental function concat_char_string(lhs, rhs) result(string) + character(len=*), intent(in) :: lhs + type(string_type), intent(in) :: rhs + type(string_type) :: string + + string%raw = lhs // maybe(rhs) + + end function concat_char_string + + + !> Write the character sequence hold by the string to a connected unformatted + !> unit. + subroutine write_unformatted(string, unit, iostat, iomsg) + type(string_type), intent(in) :: string + integer, intent(in) :: unit + integer, intent(out) :: iostat + character(len=*), intent(inout) :: iomsg + + write(unit, iostat=iostat, iomsg=iomsg) int(len(string), long) + if (iostat == 0) then + write(unit, iostat=iostat, iomsg=iomsg) maybe(string) + end if + + end subroutine write_unformatted + + !> Write the character sequence hold by the string to a connected formatted + !> unit. + subroutine write_formatted(string, unit, iotype, v_list, iostat, iomsg) + type(string_type), intent(in) :: string + integer, intent(in) :: unit + character(len=*), intent(in) :: iotype + integer, intent(in) :: v_list(:) + integer, intent(out) :: iostat + character(len=*), intent(inout) :: iomsg + + select case(iotype) + case("LISTDIRECTED") + write(unit, '(a)', iostat=iostat, iomsg=iomsg) maybe(string) + case("NAMELIST") + error stop "[Fatal] This implementation does not support namelist output" + case default ! DT* + select case(size(v_list)) + case(0) ! DT + write(unit, '(a)', iostat=iostat, iomsg=iomsg) maybe(string) + case default + error stop "[Fatal] This implementation does not support v_list formatters" + end select + end select + + end subroutine write_formatted + + + !> Read a character sequence from a connected unformatted unit into the string. + subroutine read_unformatted(string, unit, iostat, iomsg) + type(string_type), intent(inout) :: string + integer, intent(in) :: unit + integer, intent(out) :: iostat + character(len=*), intent(inout) :: iomsg + character(len=:), allocatable :: buffer + integer(long) :: chunk + + read(unit, iostat=iostat, iomsg=iomsg) chunk + if (iostat == 0) then + allocate(character(len=chunk) :: buffer) + read(unit, iostat=iostat, iomsg=iomsg) buffer + string%raw = buffer + end if + + end subroutine read_unformatted + + !> Read a character sequence from a connected formatted unit into the string. + subroutine read_formatted(string, unit, iotype, v_list, iostat, iomsg) + type(string_type), intent(inout) :: string + integer, intent(in) :: unit + character(len=*), intent(in) :: iotype + integer, intent(in) :: v_list(:) + integer, intent(out) :: iostat + character(len=*), intent(inout) :: iomsg + character(len=:), allocatable :: line + + call unused_dummy_argument(v_list) + + select case(iotype) + case("LISTDIRECTED") + call read_line(unit, line, iostat, iomsg) + case("NAMELIST") + error stop "[Fatal] This implementation does not support namelist input" + case default ! DT* + error stop "[Fatal] This implementation does not support dt formatters" + end select + + string%raw = line + + contains + + !> Internal routine to read a whole record from a formatted unit + subroutine read_line(unit, line, iostat, iomsg) + integer, intent(in) :: unit + character(len=:), allocatable, intent(out) :: line + integer, intent(out) :: iostat + character(len=*), intent(inout) :: iomsg + integer, parameter :: buffer_size = 512 + character(len=buffer_size) :: buffer + integer :: chunk + line = '' + do + read(unit, '(a)', iostat=iostat, iomsg=iomsg, size=chunk, advance='no') & + buffer + if (iostat > 0) exit + line = line // buffer(:chunk) + if (iostat < 0) exit + end do + + if (is_iostat_eor(iostat)) then + iostat = 0 + end if + end subroutine read_line + + end subroutine read_formatted + + + !> Do nothing but mark an unused dummy argument as such to acknowledge compile + !> time warning like: + !> + !> Warning: Unused dummy argument ‘dummy’ at (1) [-Wunused-dummy-argument] + !> + !> We deeply trust in the compiler to inline and optimize this piece of code away. + elemental subroutine unused_dummy_argument(dummy) + class(*), intent(in) :: dummy + associate(dummy => dummy); end associate + end subroutine unused_dummy_argument + + + !> Safely return the character sequences represented by the string + pure function maybe(string) result(maybe_string) + type(string_type), intent(in) :: string + character(len=len(string)) :: maybe_string + if (allocated(string%raw)) then + maybe_string = string%raw + else + maybe_string = '' + end if + end function maybe + + +end module stdlib_string_type diff --git a/src/fpm/stdlib_strings.f90 b/src/fpm/stdlib_strings.f90 new file mode 100644 index 000000000..158b06588 --- /dev/null +++ b/src/fpm/stdlib_strings.f90 @@ -0,0 +1,370 @@ +! SPDX-Identifier: MIT + +!> This module implements basic string handling routines. +!> +!> The specification of this module is available [here](../page/specs/stdlib_strings.html). +module stdlib_strings + use stdlib_ascii, only : whitespace + use stdlib_string_type, only : string_type, char, verify + implicit none + private + + public :: strip, chomp + public :: starts_with, ends_with + public :: slice + + + !> Remove leading and trailing whitespace characters. + !> + !> Version: experimental + interface strip + module procedure :: strip_string + module procedure :: strip_char + end interface strip + + !> Remove trailing characters in set from string. + !> If no character set is provided trailing whitespace is removed. + !> + !> Version: experimental + interface chomp + module procedure :: chomp_string + module procedure :: chomp_char + module procedure :: chomp_set_string_char + module procedure :: chomp_set_char_char + module procedure :: chomp_substring_string_string + module procedure :: chomp_substring_char_string + module procedure :: chomp_substring_string_char + module procedure :: chomp_substring_char_char + end interface chomp + + + !> Check whether a string starts with substring or not + !> + !> Version: experimental + interface starts_with + module procedure :: starts_with_string_string + module procedure :: starts_with_string_char + module procedure :: starts_with_char_string + module procedure :: starts_with_char_char + end interface starts_with + + + !> Check whether a string ends with substring or not + !> + !> Version: experimental + interface ends_with + module procedure :: ends_with_string_string + module procedure :: ends_with_string_char + module procedure :: ends_with_char_string + module procedure :: ends_with_char_char + end interface ends_with + + !> Extracts characters from the input string to return a new string + !> + !> Version: experimental + interface slice + module procedure :: slice_string + module procedure :: slice_char + end interface slice + + +contains + + + !> Remove leading and trailing whitespace characters. + pure function strip_string(string) result(stripped_string) + ! Avoid polluting the module scope and use the assignment only in this scope + use stdlib_string_type, only : assignment(=) + type(string_type), intent(in) :: string + type(string_type) :: stripped_string + + stripped_string = strip(char(string)) + end function strip_string + + !> Remove leading and trailing whitespace characters. + pure function strip_char(string) result(stripped_string) + character(len=*), intent(in) :: string + character(len=:), allocatable :: stripped_string + integer :: first, last + + first = verify(string, whitespace) + if (first == 0) then + stripped_string = "" + else + last = verify(string, whitespace, back=.true.) + stripped_string = string(first:last) + end if + + end function strip_char + + + !> Remove trailing characters in set from string. + !> Default character set variant where trailing whitespace is removed. + pure function chomp_string(string) result(chomped_string) + ! Avoid polluting the module scope and use the assignment only in this scope + use stdlib_string_type, only : assignment(=) + type(string_type), intent(in) :: string + type(string_type) :: chomped_string + integer :: last + + last = verify(string, whitespace, back=.true.) + chomped_string = char(string, 1, last) + end function chomp_string + + !> Remove trailing characters in set from string. + !> Default character set variant where trailing whitespace is removed. + pure function chomp_char(string) result(chomped_string) + character(len=*), intent(in) :: string + character(len=:), allocatable :: chomped_string + integer :: last + + last = verify(string, whitespace, back=.true.) + chomped_string = string(1:last) + end function chomp_char + + !> Remove trailing characters in set from string. + pure function chomp_set_string_char(string, set) result(chomped_string) + ! Avoid polluting the module scope and use the assignment only in this scope + use stdlib_string_type, only : assignment(=) + type(string_type), intent(in) :: string + character(len=1), intent(in) :: set(:) + type(string_type) :: chomped_string + + chomped_string = chomp(char(string), set) + end function chomp_set_string_char + + !> Remove trailing characters in set from string. + pure function chomp_set_char_char(string, set) result(chomped_string) + character(len=*), intent(in) :: string + character(len=1), intent(in) :: set(:) + character(len=:), allocatable :: chomped_string + integer :: last + + last = verify(string, set_to_string(set), back=.true.) + chomped_string = string(1:last) + + end function chomp_set_char_char + + !> Remove trailing substrings from string. + pure function chomp_substring_string_string(string, substring) result(chomped_string) + ! Avoid polluting the module scope and use the assignment only in this scope + use stdlib_string_type, only : assignment(=) + type(string_type), intent(in) :: string + type(string_type), intent(in) :: substring + type(string_type) :: chomped_string + + chomped_string = chomp(char(string), char(substring)) + end function chomp_substring_string_string + + !> Remove trailing substrings from string. + pure function chomp_substring_string_char(string, substring) result(chomped_string) + ! Avoid polluting the module scope and use the assignment only in this scope + use stdlib_string_type, only : assignment(=) + type(string_type), intent(in) :: string + character(len=*), intent(in) :: substring + type(string_type) :: chomped_string + + chomped_string = chomp(char(string), substring) + end function chomp_substring_string_char + + !> Remove trailing substrings from string. + pure function chomp_substring_char_string(string, substring) result(chomped_string) + character(len=*), intent(in) :: string + type(string_type), intent(in) :: substring + character(len=:), allocatable :: chomped_string + + chomped_string = chomp(string, char(substring)) + end function chomp_substring_char_string + + !> Remove trailing substrings from string. + pure function chomp_substring_char_char(string, substring) result(chomped_string) + character(len=*), intent(in) :: string + character(len=*), intent(in) :: substring + character(len=:), allocatable :: chomped_string + integer :: last, nsub + + last = len(string) + nsub = len(substring) + if (nsub > 0) then + do while(string(last-nsub+1:last) == substring) + last = last - nsub + end do + end if + chomped_string = string(1:last) + + end function chomp_substring_char_char + + !> Implementation to transfer a set of characters to a string representing the set. + !> + !> This function is internal and not part of the public API. + pure function set_to_string(set) result(string) + character(len=1), intent(in) :: set(:) + character(len=size(set)) :: string + + string = transfer(set, string) + end function set_to_string + + + !> Check whether a string starts with substring or not + pure function starts_with_char_char(string, substring) result(match) + character(len=*), intent(in) :: string + character(len=*), intent(in) :: substring + logical :: match + integer :: nsub + + nsub = len(substring) + if (len(string) < nsub) then + match = .false. + return + end if + match = string(1:nsub) == substring + + end function starts_with_char_char + + !> Check whether a string starts with substring or not + elemental function starts_with_string_char(string, substring) result(match) + type(string_type), intent(in) :: string + character(len=*), intent(in) :: substring + logical :: match + + match = starts_with(char(string), substring) + + end function starts_with_string_char + + !> Check whether a string starts with substring or not + elemental function starts_with_char_string(string, substring) result(match) + character(len=*), intent(in) :: string + type(string_type), intent(in) :: substring + logical :: match + + match = starts_with(string, char(substring)) + + end function starts_with_char_string + + !> Check whether a string starts with substring or not + elemental function starts_with_string_string(string, substring) result(match) + type(string_type), intent(in) :: string + type(string_type), intent(in) :: substring + logical :: match + + match = starts_with(char(string), char(substring)) + + end function starts_with_string_string + + + !> Check whether a string ends with substring or not + pure function ends_with_char_char(string, substring) result(match) + character(len=*), intent(in) :: string + character(len=*), intent(in) :: substring + logical :: match + integer :: last, nsub + + last = len(string) + nsub = len(substring) + if (last < nsub) then + match = .false. + return + end if + match = string(last-nsub+1:last) == substring + + end function ends_with_char_char + + !> Check whether a string ends with substring or not + elemental function ends_with_string_char(string, substring) result(match) + type(string_type), intent(in) :: string + character(len=*), intent(in) :: substring + logical :: match + + match = ends_with(char(string), substring) + + end function ends_with_string_char + + !> Check whether a string ends with substring or not + elemental function ends_with_char_string(string, substring) result(match) + character(len=*), intent(in) :: string + type(string_type), intent(in) :: substring + logical :: match + + match = ends_with(string, char(substring)) + + end function ends_with_char_string + + !> Check whether a string ends with substring or not + elemental function ends_with_string_string(string, substring) result(match) + type(string_type), intent(in) :: string + type(string_type), intent(in) :: substring + logical :: match + + match = ends_with(char(string), char(substring)) + + end function ends_with_string_string + + !> Extract the characters from the region between 'first' and 'last' index (both inclusive) + !> of the input 'string' by taking strides of length 'stride' + !> Returns a new string + elemental function slice_string(string, first, last, stride) result(sliced_string) + type(string_type), intent(in) :: string + integer, intent(in), optional :: first, last, stride + type(string_type) :: sliced_string + + sliced_string = string_type(slice(char(string), first, last, stride)) + + end function slice_string + + !> Extract the characters from the region between 'first' and 'last' index (both inclusive) + !> of the input 'string' by taking strides of length 'stride' + !> Returns a new string + pure function slice_char(string, first, last, stride) result(sliced_string) + character(len=*), intent(in) :: string + integer, intent(in), optional :: first, last, stride + integer :: first_index, last_index, stride_vector, strides_taken, length_string, i, j + character(len=:), allocatable :: sliced_string + length_string = len(string) + + first_index = 0 ! first_index = -infinity + last_index = length_string + 1 ! last_index = +infinity + stride_vector = 1 + + if (present(stride)) then + if (stride /= 0) then + if (stride < 0) then + first_index = length_string + 1 ! first_index = +infinity + last_index = 0 ! last_index = -infinity + end if + stride_vector = stride + end if + else + if (present(first) .and. present(last)) then + if (last < first) then + stride_vector = -1 + end if + end if + end if + + if (present(first)) then + first_index = first + end if + if (present(last)) then + last_index = last + end if + + if (stride_vector > 0) then + first_index = max(first_index, 1) + last_index = min(last_index, length_string) + else + first_index = min(first_index, length_string) + last_index = max(last_index, 1) + end if + + strides_taken = floor( real(last_index - first_index)/real(stride_vector) ) + allocate(character(len=max(0, strides_taken + 1)) :: sliced_string) + + j = 1 + do i = first_index, last_index, stride_vector + sliced_string(j:j) = string(i:i) + j = j + 1 + end do + end function slice_char + + +end module stdlib_strings diff --git a/src/fpm/stdlib_system.F90 b/src/fpm/stdlib_system.F90 new file mode 100644 index 000000000..7bcc78baf --- /dev/null +++ b/src/fpm/stdlib_system.F90 @@ -0,0 +1,49 @@ +module stdlib_system +use, intrinsic :: iso_c_binding, only : c_int, c_long +implicit none +private +public :: sleep + +interface +#ifdef _WIN32 +subroutine winsleep(dwMilliseconds) bind (C, name='Sleep') +!! version: experimental +!! +!! void Sleep(DWORD dwMilliseconds) +!! https://docs.microsoft.com/en-us/windows/win32/api/synchapi/nf-synchapi-sleep +import c_long +integer(c_long), value, intent(in) :: dwMilliseconds +end subroutine winsleep +#else +integer(c_int) function usleep(usec) bind (C) +!! version: experimental +!! +!! int usleep(useconds_t usec); +!! https://linux.die.net/man/3/usleep +import c_int +integer(c_int), value, intent(in) :: usec +end function usleep +#endif +end interface + +contains + +subroutine sleep(millisec) +!! version: experimental +!! +integer, intent(in) :: millisec +integer(c_int) :: ierr + +#ifdef _WIN32 +!! PGI Windows, Ifort Windows, .... +call winsleep(int(millisec, c_long)) +#else +!! Linux, Unix, MacOS, MSYS2, ... +ierr = usleep(int(millisec * 1000, c_int)) +if (ierr/=0) error stop 'problem with usleep() system call' +#endif + + +end subroutine sleep + +end module stdlib_system From 1589588ad8a417d62658b3d5cc8af488ae579294 Mon Sep 17 00:00:00 2001 From: zoziha13 <1325686572@qq.com> Date: Wed, 16 Jun 2021 13:44:17 +0800 Subject: [PATCH 2/8] modify README.md --- README.md | 37 +++++++++++++++++++++++++------------ 1 file changed, 25 insertions(+), 12 deletions(-) diff --git a/README.md b/README.md index 5615c4bba..96659a181 100644 --- a/README.md +++ b/README.md @@ -3,18 +3,20 @@ [![Actions Status](https://github.com/fortran-lang/stdlib/workflows/CI/badge.svg)](https://github.com/fortran-lang/stdlib/actions) [![Actions Status](https://github.com/fortran-lang/stdlib/workflows/CI_windows/badge.svg)](https://github.com/fortran-lang/stdlib/actions) -* [Goals and Motivation](#goals-and-motivation) -* [Scope](#scope) -* [Getting started](#getting-started) - - [Get the code](#get-the-code) - - [Requirements](#requirements) - - [Supported compilers](#supported-compilers) - - [Build with CMake](#build-with-cmake) - - [Build with make](#build-with-make) -* [Using stdlib in your project](#using-stdlib-in-your-project) -* [Documentation](#documentation) -* [Contributing](#contributing) -* [Links](#links) +- [Fortran Standard Library](#fortran-standard-library) + - [Goals and Motivation](#goals-and-motivation) + - [Scope](#scope) + - [Getting started](#getting-started) + - [Get the code](#get-the-code) + - [Requirements](#requirements) + - [Supported Compilers](#supported-compilers) + - [Build with CMake](#build-with-cmake) + - [Build with make](#build-with-make) + - [Build with fpm](#build-with-fpm) + - [Using stdlib in your project](#using-stdlib-in-your-project) + - [Documentation](#documentation) + - [Contributing](#contributing) + - [Links](#links) ## Goals and Motivation @@ -175,6 +177,17 @@ You can limit the maximum rank by setting ``-DMAXRANK=`` in the ``FYPPFLAGS make -f Makefile.manual FYPPFLAGS=-DMAXRANK=4 ``` +### Build with [fpm](https://github.com/fortran-lang/fpm) +You can build using provided `fpm.toml`: +```bash +fpm build +fpm test +``` +To use `stdlib` within your fpm project, add the following to fpm.toml file: +```toml +[dependencies] +forlab = { git = "https://github.com/zoziha/stdlib.git" } +``` ## Using stdlib in your project From 191f078aa31bac59c789c26b28038356310bca0a Mon Sep 17 00:00:00 2001 From: zoziha13 <1325686572@qq.com> Date: Wed, 16 Jun 2021 13:59:32 +0800 Subject: [PATCH 3/8] modify makefile & README.md --- Makefile | 12 ------------ Makefile.manual | 5 +++++ README.md | 6 ++++-- fpm.toml | 4 ++-- src/Makefile.fpm | 2 ++ 5 files changed, 13 insertions(+), 16 deletions(-) delete mode 100644 Makefile diff --git a/Makefile b/Makefile deleted file mode 100644 index dc33c64a1..000000000 --- a/Makefile +++ /dev/null @@ -1,12 +0,0 @@ -# Fortran STDLIB Makefile for FPM BUILD -FYPPFLAGS= - -export FYPPFLAGS - -.PHONY: dev clean - -dev: - $(MAKE) -f Makefile.fpm --directory=src - -clean: - $(MAKE) -f Makefile.fpm clean --directory=src \ No newline at end of file diff --git a/Makefile.manual b/Makefile.manual index b8280b102..ec9b5e5ee 100644 --- a/Makefile.manual +++ b/Makefile.manual @@ -19,6 +19,11 @@ test: @echo @echo "All tests passed." +# Fortran STDLIB Makefile for FPM BUILD +dev: + $(MAKE) -f Makefile.fpm --directory=src + clean: $(MAKE) -f Makefile.manual clean --directory=src $(MAKE) -f Makefile.manual clean --directory=src/tests + $(MAKE) -f Makefile.fpm clean --directory=src \ No newline at end of file diff --git a/README.md b/README.md index 96659a181..ab8cea693 100644 --- a/README.md +++ b/README.md @@ -180,13 +180,15 @@ make -f Makefile.manual FYPPFLAGS=-DMAXRANK=4 ### Build with [fpm](https://github.com/fortran-lang/fpm) You can build using provided `fpm.toml`: ```bash +make -f Makefile.manual +--- fpm build fpm test ``` -To use `stdlib` within your fpm project, add the following to fpm.toml file: +To use `stdlib` within your fpm project, add the following to `fpm.toml` file: ```toml [dependencies] -forlab = { git = "https://github.com/zoziha/stdlib.git" } +forlab = { git = "https://github.com/fortran-lang/stdlib.git" } ``` diff --git a/fpm.toml b/fpm.toml index 1d747683b..b34d093dc 100644 --- a/fpm.toml +++ b/fpm.toml @@ -1,5 +1,5 @@ name = "stdlib" -version = "fpm version 0.0.1" +version = "0.0.1" license = "MIT" author = "stdlib contributors" maintainer = "https://github.com/fortran-lang/stdlib" @@ -8,7 +8,7 @@ description = "Fortran Standard Library" categories = ["numerical"] keywords = ["numerical", "stdlib"] -# cd stdlib && make && fpm build +# cd stdlib && make dev -f Makefile.manual && fpm build [library] source-dir="src/fpm" diff --git a/src/Makefile.fpm b/src/Makefile.fpm index b857b229a..ec12933ff 100644 --- a/src/Makefile.fpm +++ b/src/Makefile.fpm @@ -20,8 +20,10 @@ clean: # GEN F90 files to `fpm/` from FYPP files $(SRCGEN): %.f90: %.fypp + @mkdir -p fpm fypp $(FYPPFLAGS) $< $(FPMSRCDIR)$@ # COPY F90 files to `fpm/` CPF90: $(SRCF90) + @mkdir -p fpm cp -u $^ $(FPMSRCDIR) From cdea679f5702ed33639c8fde941b7b586144be27 Mon Sep 17 00:00:00 2001 From: zoziha13 <1325686572@qq.com> Date: Wed, 16 Jun 2021 14:02:36 +0800 Subject: [PATCH 4/8] fix README.md --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index ab8cea693..be66f77f0 100644 --- a/README.md +++ b/README.md @@ -180,7 +180,7 @@ make -f Makefile.manual FYPPFLAGS=-DMAXRANK=4 ### Build with [fpm](https://github.com/fortran-lang/fpm) You can build using provided `fpm.toml`: ```bash -make -f Makefile.manual +make dev -f Makefile.manual --- fpm build fpm test From 5ce422a1dbbeb15ade1b272e62b8e46cb5a84082 Mon Sep 17 00:00:00 2001 From: zoziha13 <1325686572@qq.com> Date: Wed, 16 Jun 2021 14:16:31 +0800 Subject: [PATCH 5/8] fix fpm.toml --- fpm.toml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/fpm.toml b/fpm.toml index b34d093dc..9d0e1d659 100644 --- a/fpm.toml +++ b/fpm.toml @@ -3,7 +3,7 @@ version = "0.0.1" license = "MIT" author = "stdlib contributors" maintainer = "https://github.com/fortran-lang/stdlib" -copyright = "2019-2021 forlab contributors" +copyright = "2019-2021 stdlib contributors" description = "Fortran Standard Library" categories = ["numerical"] keywords = ["numerical", "stdlib"] From eeab2ba28385f5acb7663f0499e47f786a2287ef Mon Sep 17 00:00:00 2001 From: zoziha13 <1325686572@qq.com> Date: Wed, 16 Jun 2021 14:29:55 +0800 Subject: [PATCH 6/8] rm fpm test --- README.md | 1 - 1 file changed, 1 deletion(-) diff --git a/README.md b/README.md index be66f77f0..ddf523aca 100644 --- a/README.md +++ b/README.md @@ -183,7 +183,6 @@ You can build using provided `fpm.toml`: make dev -f Makefile.manual --- fpm build -fpm test ``` To use `stdlib` within your fpm project, add the following to `fpm.toml` file: ```toml From 38d3c0736de7872dd7b45705cc0d9f82a52790b3 Mon Sep 17 00:00:00 2001 From: zoziha <1325686572@qq.com> Date: Wed, 16 Jun 2021 15:43:00 +0800 Subject: [PATCH 7/8] fix README.md --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index ddf523aca..724009b9d 100644 --- a/README.md +++ b/README.md @@ -187,7 +187,7 @@ fpm build To use `stdlib` within your fpm project, add the following to `fpm.toml` file: ```toml [dependencies] -forlab = { git = "https://github.com/fortran-lang/stdlib.git" } +stdlib = { git = "https://github.com/fortran-lang/stdlib.git" } ``` From e079083a674133396cb28a05cd6a8f94e2f24784 Mon Sep 17 00:00:00 2001 From: zoziha13 <1325686572@qq.com> Date: Sat, 19 Jun 2021 21:28:41 +0800 Subject: [PATCH 8/8] fix common.fypp --- src/Makefile.fpm | 2 +- src/common.fypp | 2 +- src/fpm/stdlib_stats.f90 | 10858 +------- src/fpm/stdlib_stats_mean.f90 | 5978 +---- src/fpm/stdlib_stats_moment.f90 | 17182 ++----------- src/fpm/stdlib_stats_moment_all.f90 | 5234 +--- src/fpm/stdlib_stats_moment_mask.f90 | 22616 ++--------------- src/fpm/stdlib_stats_moment_scalar.f90 | 4922 +--- src/fpm/stdlib_stats_var.f90 | 30874 ++++------------------- 9 files changed, 11770 insertions(+), 85898 deletions(-) diff --git a/src/Makefile.fpm b/src/Makefile.fpm index ec12933ff..40153be1d 100644 --- a/src/Makefile.fpm +++ b/src/Makefile.fpm @@ -19,7 +19,7 @@ clean: cd $(FPMSRCDIR); $(RM) $(SRCGEN) $(SRCF90) # GEN F90 files to `fpm/` from FYPP files -$(SRCGEN): %.f90: %.fypp +$(SRCGEN): %.f90: %.fypp common.fypp @mkdir -p fpm fypp $(FYPPFLAGS) $< $(FPMSRCDIR)$@ diff --git a/src/common.fypp b/src/common.fypp index 4c4fbe18b..e90133bec 100644 --- a/src/common.fypp +++ b/src/common.fypp @@ -52,7 +52,7 @@ #! Ranks to be generated when templates are created #:if not defined('MAXRANK') - #:if VERSION90 + #:if defined('VERSION90') #:set MAXRANK = 7 #:else #:set MAXRANK = 15 diff --git a/src/fpm/stdlib_stats.f90 b/src/fpm/stdlib_stats.f90 index 06237c13c..f22fcbffd 100644 --- a/src/fpm/stdlib_stats.f90 +++ b/src/fpm/stdlib_stats.f90 @@ -641,46 +641,6 @@ module function mean_all_7_rsp_rsp (x, mask) result(res) logical, intent(in), optional :: mask real(sp) :: res end function mean_all_7_rsp_rsp - module function mean_all_8_rsp_rsp (x, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(sp) :: res - end function mean_all_8_rsp_rsp - module function mean_all_9_rsp_rsp (x, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(sp) :: res - end function mean_all_9_rsp_rsp - module function mean_all_10_rsp_rsp (x, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(sp) :: res - end function mean_all_10_rsp_rsp - module function mean_all_11_rsp_rsp (x, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(sp) :: res - end function mean_all_11_rsp_rsp - module function mean_all_12_rsp_rsp (x, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(sp) :: res - end function mean_all_12_rsp_rsp - module function mean_all_13_rsp_rsp (x, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(sp) :: res - end function mean_all_13_rsp_rsp - module function mean_all_14_rsp_rsp (x, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(sp) :: res - end function mean_all_14_rsp_rsp - module function mean_all_15_rsp_rsp (x, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(sp) :: res - end function mean_all_15_rsp_rsp module function mean_all_1_rdp_rdp (x, mask) result(res) real(dp), intent(in) :: x(:) logical, intent(in), optional :: mask @@ -716,46 +676,6 @@ module function mean_all_7_rdp_rdp (x, mask) result(res) logical, intent(in), optional :: mask real(dp) :: res end function mean_all_7_rdp_rdp - module function mean_all_8_rdp_rdp (x, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(dp) :: res - end function mean_all_8_rdp_rdp - module function mean_all_9_rdp_rdp (x, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(dp) :: res - end function mean_all_9_rdp_rdp - module function mean_all_10_rdp_rdp (x, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(dp) :: res - end function mean_all_10_rdp_rdp - module function mean_all_11_rdp_rdp (x, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(dp) :: res - end function mean_all_11_rdp_rdp - module function mean_all_12_rdp_rdp (x, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(dp) :: res - end function mean_all_12_rdp_rdp - module function mean_all_13_rdp_rdp (x, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(dp) :: res - end function mean_all_13_rdp_rdp - module function mean_all_14_rdp_rdp (x, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(dp) :: res - end function mean_all_14_rdp_rdp - module function mean_all_15_rdp_rdp (x, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(dp) :: res - end function mean_all_15_rdp_rdp module function mean_all_1_rqp_rqp (x, mask) result(res) real(qp), intent(in) :: x(:) logical, intent(in), optional :: mask @@ -791,46 +711,6 @@ module function mean_all_7_rqp_rqp (x, mask) result(res) logical, intent(in), optional :: mask real(qp) :: res end function mean_all_7_rqp_rqp - module function mean_all_8_rqp_rqp (x, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(qp) :: res - end function mean_all_8_rqp_rqp - module function mean_all_9_rqp_rqp (x, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(qp) :: res - end function mean_all_9_rqp_rqp - module function mean_all_10_rqp_rqp (x, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(qp) :: res - end function mean_all_10_rqp_rqp - module function mean_all_11_rqp_rqp (x, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(qp) :: res - end function mean_all_11_rqp_rqp - module function mean_all_12_rqp_rqp (x, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(qp) :: res - end function mean_all_12_rqp_rqp - module function mean_all_13_rqp_rqp (x, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(qp) :: res - end function mean_all_13_rqp_rqp - module function mean_all_14_rqp_rqp (x, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(qp) :: res - end function mean_all_14_rqp_rqp - module function mean_all_15_rqp_rqp (x, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(qp) :: res - end function mean_all_15_rqp_rqp module function mean_all_1_csp_csp (x, mask) result(res) complex(sp), intent(in) :: x(:) logical, intent(in), optional :: mask @@ -866,46 +746,6 @@ module function mean_all_7_csp_csp (x, mask) result(res) logical, intent(in), optional :: mask complex(sp) :: res end function mean_all_7_csp_csp - module function mean_all_8_csp_csp (x, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - complex(sp) :: res - end function mean_all_8_csp_csp - module function mean_all_9_csp_csp (x, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - complex(sp) :: res - end function mean_all_9_csp_csp - module function mean_all_10_csp_csp (x, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - complex(sp) :: res - end function mean_all_10_csp_csp - module function mean_all_11_csp_csp (x, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - complex(sp) :: res - end function mean_all_11_csp_csp - module function mean_all_12_csp_csp (x, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - complex(sp) :: res - end function mean_all_12_csp_csp - module function mean_all_13_csp_csp (x, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - complex(sp) :: res - end function mean_all_13_csp_csp - module function mean_all_14_csp_csp (x, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - complex(sp) :: res - end function mean_all_14_csp_csp - module function mean_all_15_csp_csp (x, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - complex(sp) :: res - end function mean_all_15_csp_csp module function mean_all_1_cdp_cdp (x, mask) result(res) complex(dp), intent(in) :: x(:) logical, intent(in), optional :: mask @@ -941,46 +781,6 @@ module function mean_all_7_cdp_cdp (x, mask) result(res) logical, intent(in), optional :: mask complex(dp) :: res end function mean_all_7_cdp_cdp - module function mean_all_8_cdp_cdp (x, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - complex(dp) :: res - end function mean_all_8_cdp_cdp - module function mean_all_9_cdp_cdp (x, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - complex(dp) :: res - end function mean_all_9_cdp_cdp - module function mean_all_10_cdp_cdp (x, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - complex(dp) :: res - end function mean_all_10_cdp_cdp - module function mean_all_11_cdp_cdp (x, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - complex(dp) :: res - end function mean_all_11_cdp_cdp - module function mean_all_12_cdp_cdp (x, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - complex(dp) :: res - end function mean_all_12_cdp_cdp - module function mean_all_13_cdp_cdp (x, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - complex(dp) :: res - end function mean_all_13_cdp_cdp - module function mean_all_14_cdp_cdp (x, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - complex(dp) :: res - end function mean_all_14_cdp_cdp - module function mean_all_15_cdp_cdp (x, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - complex(dp) :: res - end function mean_all_15_cdp_cdp module function mean_all_1_cqp_cqp (x, mask) result(res) complex(qp), intent(in) :: x(:) logical, intent(in), optional :: mask @@ -1016,46 +816,6 @@ module function mean_all_7_cqp_cqp (x, mask) result(res) logical, intent(in), optional :: mask complex(qp) :: res end function mean_all_7_cqp_cqp - module function mean_all_8_cqp_cqp (x, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - complex(qp) :: res - end function mean_all_8_cqp_cqp - module function mean_all_9_cqp_cqp (x, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - complex(qp) :: res - end function mean_all_9_cqp_cqp - module function mean_all_10_cqp_cqp (x, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - complex(qp) :: res - end function mean_all_10_cqp_cqp - module function mean_all_11_cqp_cqp (x, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - complex(qp) :: res - end function mean_all_11_cqp_cqp - module function mean_all_12_cqp_cqp (x, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - complex(qp) :: res - end function mean_all_12_cqp_cqp - module function mean_all_13_cqp_cqp (x, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - complex(qp) :: res - end function mean_all_13_cqp_cqp - module function mean_all_14_cqp_cqp (x, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - complex(qp) :: res - end function mean_all_14_cqp_cqp - module function mean_all_15_cqp_cqp (x, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - complex(qp) :: res - end function mean_all_15_cqp_cqp module function mean_all_1_iint8_dp(x, mask) result(res) integer(int8), intent(in) :: x(:) @@ -1092,46 +852,6 @@ module function mean_all_7_iint8_dp(x, mask) result(res) logical, intent(in), optional :: mask real(dp) :: res end function mean_all_7_iint8_dp - module function mean_all_8_iint8_dp(x, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(dp) :: res - end function mean_all_8_iint8_dp - module function mean_all_9_iint8_dp(x, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(dp) :: res - end function mean_all_9_iint8_dp - module function mean_all_10_iint8_dp(x, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(dp) :: res - end function mean_all_10_iint8_dp - module function mean_all_11_iint8_dp(x, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(dp) :: res - end function mean_all_11_iint8_dp - module function mean_all_12_iint8_dp(x, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(dp) :: res - end function mean_all_12_iint8_dp - module function mean_all_13_iint8_dp(x, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(dp) :: res - end function mean_all_13_iint8_dp - module function mean_all_14_iint8_dp(x, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(dp) :: res - end function mean_all_14_iint8_dp - module function mean_all_15_iint8_dp(x, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(dp) :: res - end function mean_all_15_iint8_dp module function mean_all_1_iint16_dp(x, mask) result(res) integer(int16), intent(in) :: x(:) logical, intent(in), optional :: mask @@ -1167,46 +887,6 @@ module function mean_all_7_iint16_dp(x, mask) result(res) logical, intent(in), optional :: mask real(dp) :: res end function mean_all_7_iint16_dp - module function mean_all_8_iint16_dp(x, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(dp) :: res - end function mean_all_8_iint16_dp - module function mean_all_9_iint16_dp(x, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(dp) :: res - end function mean_all_9_iint16_dp - module function mean_all_10_iint16_dp(x, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(dp) :: res - end function mean_all_10_iint16_dp - module function mean_all_11_iint16_dp(x, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(dp) :: res - end function mean_all_11_iint16_dp - module function mean_all_12_iint16_dp(x, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(dp) :: res - end function mean_all_12_iint16_dp - module function mean_all_13_iint16_dp(x, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(dp) :: res - end function mean_all_13_iint16_dp - module function mean_all_14_iint16_dp(x, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(dp) :: res - end function mean_all_14_iint16_dp - module function mean_all_15_iint16_dp(x, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(dp) :: res - end function mean_all_15_iint16_dp module function mean_all_1_iint32_dp(x, mask) result(res) integer(int32), intent(in) :: x(:) logical, intent(in), optional :: mask @@ -1242,46 +922,6 @@ module function mean_all_7_iint32_dp(x, mask) result(res) logical, intent(in), optional :: mask real(dp) :: res end function mean_all_7_iint32_dp - module function mean_all_8_iint32_dp(x, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(dp) :: res - end function mean_all_8_iint32_dp - module function mean_all_9_iint32_dp(x, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(dp) :: res - end function mean_all_9_iint32_dp - module function mean_all_10_iint32_dp(x, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(dp) :: res - end function mean_all_10_iint32_dp - module function mean_all_11_iint32_dp(x, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(dp) :: res - end function mean_all_11_iint32_dp - module function mean_all_12_iint32_dp(x, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(dp) :: res - end function mean_all_12_iint32_dp - module function mean_all_13_iint32_dp(x, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(dp) :: res - end function mean_all_13_iint32_dp - module function mean_all_14_iint32_dp(x, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(dp) :: res - end function mean_all_14_iint32_dp - module function mean_all_15_iint32_dp(x, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(dp) :: res - end function mean_all_15_iint32_dp module function mean_all_1_iint64_dp(x, mask) result(res) integer(int64), intent(in) :: x(:) logical, intent(in), optional :: mask @@ -1317,46 +957,6 @@ module function mean_all_7_iint64_dp(x, mask) result(res) logical, intent(in), optional :: mask real(dp) :: res end function mean_all_7_iint64_dp - module function mean_all_8_iint64_dp(x, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(dp) :: res - end function mean_all_8_iint64_dp - module function mean_all_9_iint64_dp(x, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(dp) :: res - end function mean_all_9_iint64_dp - module function mean_all_10_iint64_dp(x, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(dp) :: res - end function mean_all_10_iint64_dp - module function mean_all_11_iint64_dp(x, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(dp) :: res - end function mean_all_11_iint64_dp - module function mean_all_12_iint64_dp(x, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(dp) :: res - end function mean_all_12_iint64_dp - module function mean_all_13_iint64_dp(x, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(dp) :: res - end function mean_all_13_iint64_dp - module function mean_all_14_iint64_dp(x, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(dp) :: res - end function mean_all_14_iint64_dp - module function mean_all_15_iint64_dp(x, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - real(dp) :: res - end function mean_all_15_iint64_dp module function mean_1_rsp_rsp(x, dim, mask) result(res) real(sp), intent(in) :: x(:) @@ -1405,83 +1005,6 @@ module function mean_7_rsp_rsp(x, dim, mask) result(res) & size(x, 4), mask=3= 1 .and. dim <= 1) then + res = sum(x, dim) / real(size(x, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if - end function mean_all_14_iint16_dp - module function mean_all_15_iint16_dp(x, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function mean_1_rsp_rsp + module function mean_2_rsp_rsp(x, dim, mask) result(res) + real(sp), intent(in) :: x(:,:) + integer, intent(in) :: dim logical, intent(in), optional :: mask - real(dp) :: res + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then + res = sum(x, dim) / real(size(x, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if - end function mean_all_15_iint16_dp - module function mean_all_1_iint32_dp(x, mask) result(res) - integer(int32), intent(in) :: x(:) + end function mean_2_rsp_rsp + module function mean_3_rsp_rsp(x, dim, mask) result(res) + real(sp), intent(in) :: x(:,:,:) + integer, intent(in) :: dim logical, intent(in), optional :: mask - real(dp) :: res + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then + res = sum(x, dim) / real(size(x, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if - end function mean_all_1_iint32_dp - module function mean_all_2_iint32_dp(x, mask) result(res) - integer(int32), intent(in) :: x(:,:) + end function mean_3_rsp_rsp + module function mean_4_rsp_rsp(x, dim, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:) + integer, intent(in) :: dim logical, intent(in), optional :: mask - real(dp) :: res + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then + res = sum(x, dim) / real(size(x, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if - end function mean_all_2_iint32_dp - module function mean_all_3_iint32_dp(x, mask) result(res) - integer(int32), intent(in) :: x(:,:,:) + end function mean_4_rsp_rsp + module function mean_5_rsp_rsp(x, dim, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: dim logical, intent(in), optional :: mask - real(dp) :: res + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then + res = sum(x, dim) / real(size(x, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if - end function mean_all_3_iint32_dp - module function mean_all_4_iint32_dp(x, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:) + end function mean_5_rsp_rsp + module function mean_6_rsp_rsp(x, dim, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: dim logical, intent(in), optional :: mask - real(dp) :: res + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then + res = sum(x, dim) / real(size(x, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if - end function mean_all_4_iint32_dp - module function mean_all_5_iint32_dp(x, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:) + end function mean_6_rsp_rsp + module function mean_7_rsp_rsp(x, dim, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: dim logical, intent(in), optional :: mask - real(dp) :: res + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then + res = sum(x, dim) / real(size(x, dim), sp) + else + call error_stop("ERROR (mean): wrong dimension") + end if - end function mean_all_5_iint32_dp - module function mean_all_6_iint32_dp(x, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:) + end function mean_7_rsp_rsp + module function mean_1_rdp_rdp(x, dim, mask) result(res) + real(dp), intent(in) :: x(:) + integer, intent(in) :: dim logical, intent(in), optional :: mask real(dp) :: res @@ -1643,2458 +1062,393 @@ module function mean_all_6_iint32_dp(x, mask) result(res) return end if - res = sum(real(x, dp)) / real(size(x, kind = int64), dp) + if (dim >= 1 .and. dim <= 1) then + res = sum(x, dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if - end function mean_all_6_iint32_dp - module function mean_all_7_iint32_dp(x, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:) + end function mean_1_rdp_rdp + module function mean_2_rdp_rdp(x, dim, mask) result(res) + real(dp), intent(in) :: x(:,:) + integer, intent(in) :: dim logical, intent(in), optional :: mask - real(dp) :: res + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then + res = sum(x, dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if - end function mean_all_7_iint32_dp - module function mean_all_8_iint32_dp(x, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:) + end function mean_2_rdp_rdp + module function mean_3_rdp_rdp(x, dim, mask) result(res) + real(dp), intent(in) :: x(:,:,:) + integer, intent(in) :: dim logical, intent(in), optional :: mask - real(dp) :: res + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then + res = sum(x, dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if - end function mean_all_8_iint32_dp - module function mean_all_9_iint32_dp(x, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:) + end function mean_3_rdp_rdp + module function mean_4_rdp_rdp(x, dim, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:) + integer, intent(in) :: dim logical, intent(in), optional :: mask - real(dp) :: res + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then + res = sum(x, dim) / real(size(x, dim), dp) + else + call error_stop("ERROR (mean): wrong dimension") + end if - end function mean_all_9_iint32_dp - module function mean_all_10_iint32_dp(x, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + end function mean_4_rdp_rdp + module function mean_5_rdp_rdp(x, dim, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: dim logical, intent(in), optional :: mask - real(dp) :: res + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 1) then - res = sum(x, dim) / real(size(x, dim), sp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_1_rsp_rsp - module function mean_2_rsp_rsp(x, dim, mask) result(res) - real(sp), intent(in) :: x(:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then - res = sum(x, dim) / real(size(x, dim), sp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_2_rsp_rsp - module function mean_3_rsp_rsp(x, dim, mask) result(res) - real(sp), intent(in) :: x(:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then - res = sum(x, dim) / real(size(x, dim), sp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_3_rsp_rsp - module function mean_4_rsp_rsp(x, dim, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then - res = sum(x, dim) / real(size(x, dim), sp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_4_rsp_rsp - module function mean_5_rsp_rsp(x, dim, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then - res = sum(x, dim) / real(size(x, dim), sp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_5_rsp_rsp - module function mean_6_rsp_rsp(x, dim, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then - res = sum(x, dim) / real(size(x, dim), sp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_6_rsp_rsp - module function mean_7_rsp_rsp(x, dim, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then - res = sum(x, dim) / real(size(x, dim), sp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_7_rsp_rsp - module function mean_8_rsp_rsp(x, dim, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then - res = sum(x, dim) / real(size(x, dim), sp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_8_rsp_rsp - module function mean_9_rsp_rsp(x, dim, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then - res = sum(x, dim) / real(size(x, dim), sp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_9_rsp_rsp - module function mean_10_rsp_rsp(x, dim, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then - res = sum(x, dim) / real(size(x, dim), sp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_10_rsp_rsp - module function mean_11_rsp_rsp(x, dim, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then - res = sum(x, dim) / real(size(x, dim), sp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_11_rsp_rsp - module function mean_12_rsp_rsp(x, dim, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then - res = sum(x, dim) / real(size(x, dim), sp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_12_rsp_rsp - module function mean_13_rsp_rsp(x, dim, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then - res = sum(x, dim) / real(size(x, dim), sp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_13_rsp_rsp - module function mean_14_rsp_rsp(x, dim, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then - res = sum(x, dim) / real(size(x, dim), sp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_14_rsp_rsp - module function mean_15_rsp_rsp(x, dim, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then - res = sum(x, dim) / real(size(x, dim), sp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_15_rsp_rsp - module function mean_1_rdp_rdp(x, dim, mask) result(res) - real(dp), intent(in) :: x(:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - real(dp) :: res - - if (.not.optval(mask, .true.)) then - res = ieee_value(1._dp, ieee_quiet_nan) - return - end if - - if (dim >= 1 .and. dim <= 1) then - res = sum(x, dim) / real(size(x, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_1_rdp_rdp - module function mean_2_rdp_rdp(x, dim, mask) result(res) - real(dp), intent(in) :: x(:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then - res = sum(x, dim) / real(size(x, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_2_rdp_rdp - module function mean_3_rdp_rdp(x, dim, mask) result(res) - real(dp), intent(in) :: x(:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then - res = sum(x, dim) / real(size(x, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_3_rdp_rdp - module function mean_4_rdp_rdp(x, dim, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then - res = sum(x, dim) / real(size(x, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_4_rdp_rdp - module function mean_5_rdp_rdp(x, dim, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then - res = sum(x, dim) / real(size(x, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_5_rdp_rdp - module function mean_6_rdp_rdp(x, dim, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then - res = sum(x, dim) / real(size(x, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_6_rdp_rdp - module function mean_7_rdp_rdp(x, dim, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then - res = sum(x, dim) / real(size(x, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_7_rdp_rdp - module function mean_8_rdp_rdp(x, dim, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then - res = sum(x, dim) / real(size(x, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_8_rdp_rdp - module function mean_9_rdp_rdp(x, dim, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then - res = sum(x, dim) / real(size(x, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_9_rdp_rdp - module function mean_10_rdp_rdp(x, dim, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then - res = sum(x, dim) / real(size(x, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_10_rdp_rdp - module function mean_11_rdp_rdp(x, dim, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then - res = sum(x, dim) / real(size(x, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_11_rdp_rdp - module function mean_12_rdp_rdp(x, dim, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then - res = sum(x, dim) / real(size(x, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_12_rdp_rdp - module function mean_13_rdp_rdp(x, dim, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then - res = sum(x, dim) / real(size(x, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_13_rdp_rdp - module function mean_14_rdp_rdp(x, dim, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then - res = sum(x, dim) / real(size(x, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_14_rdp_rdp - module function mean_15_rdp_rdp(x, dim, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then - res = sum(x, dim) / real(size(x, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_15_rdp_rdp - module function mean_1_rqp_rqp(x, dim, mask) result(res) - real(qp), intent(in) :: x(:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - real(qp) :: res - - if (.not.optval(mask, .true.)) then - res = ieee_value(1._qp, ieee_quiet_nan) - return - end if - - if (dim >= 1 .and. dim <= 1) then - res = sum(x, dim) / real(size(x, dim), qp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_1_rqp_rqp - module function mean_2_rqp_rqp(x, dim, mask) result(res) - real(qp), intent(in) :: x(:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then - res = sum(x, dim) / real(size(x, dim), qp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_2_rqp_rqp - module function mean_3_rqp_rqp(x, dim, mask) result(res) - real(qp), intent(in) :: x(:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then - res = sum(x, dim) / real(size(x, dim), qp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_3_rqp_rqp - module function mean_4_rqp_rqp(x, dim, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then - res = sum(x, dim) / real(size(x, dim), qp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_4_rqp_rqp - module function mean_5_rqp_rqp(x, dim, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then - res = sum(x, dim) / real(size(x, dim), qp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_5_rqp_rqp - module function mean_6_rqp_rqp(x, dim, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then - res = sum(x, dim) / real(size(x, dim), qp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_6_rqp_rqp - module function mean_7_rqp_rqp(x, dim, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then - res = sum(x, dim) / real(size(x, dim), qp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_7_rqp_rqp - module function mean_8_rqp_rqp(x, dim, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then - res = sum(x, dim) / real(size(x, dim), qp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_8_rqp_rqp - module function mean_9_rqp_rqp(x, dim, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then - res = sum(x, dim) / real(size(x, dim), qp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_9_rqp_rqp - module function mean_10_rqp_rqp(x, dim, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then - res = sum(x, dim) / real(size(x, dim), qp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_10_rqp_rqp - module function mean_11_rqp_rqp(x, dim, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then - res = sum(x, dim) / real(size(x, dim), qp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_11_rqp_rqp - module function mean_12_rqp_rqp(x, dim, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then - res = sum(x, dim) / real(size(x, dim), qp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_12_rqp_rqp - module function mean_13_rqp_rqp(x, dim, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then - res = sum(x, dim) / real(size(x, dim), qp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_13_rqp_rqp - module function mean_14_rqp_rqp(x, dim, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then - res = sum(x, dim) / real(size(x, dim), qp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_14_rqp_rqp - module function mean_15_rqp_rqp(x, dim, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then - res = sum(x, dim) / real(size(x, dim), qp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_15_rqp_rqp - module function mean_1_csp_csp(x, dim, mask) result(res) - complex(sp), intent(in) :: x(:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - complex(sp) :: res - - if (.not.optval(mask, .true.)) then - res = ieee_value(1._sp, ieee_quiet_nan) - return - end if - - if (dim >= 1 .and. dim <= 1) then - res = sum(x, dim) / real(size(x, dim), sp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_1_csp_csp - module function mean_2_csp_csp(x, dim, mask) result(res) - complex(sp), intent(in) :: x(:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then - res = sum(x, dim) / real(size(x, dim), sp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_2_csp_csp - module function mean_3_csp_csp(x, dim, mask) result(res) - complex(sp), intent(in) :: x(:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then - res = sum(x, dim) / real(size(x, dim), sp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_3_csp_csp - module function mean_4_csp_csp(x, dim, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then - res = sum(x, dim) / real(size(x, dim), sp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_4_csp_csp - module function mean_5_csp_csp(x, dim, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then - res = sum(x, dim) / real(size(x, dim), sp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_5_csp_csp - module function mean_6_csp_csp(x, dim, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then - res = sum(x, dim) / real(size(x, dim), sp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_6_csp_csp - module function mean_7_csp_csp(x, dim, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then - res = sum(x, dim) / real(size(x, dim), sp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_7_csp_csp - module function mean_8_csp_csp(x, dim, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then - res = sum(x, dim) / real(size(x, dim), sp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_8_csp_csp - module function mean_9_csp_csp(x, dim, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then - res = sum(x, dim) / real(size(x, dim), sp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_9_csp_csp - module function mean_10_csp_csp(x, dim, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then - res = sum(x, dim) / real(size(x, dim), sp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_10_csp_csp - module function mean_11_csp_csp(x, dim, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then - res = sum(x, dim) / real(size(x, dim), sp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_11_csp_csp - module function mean_12_csp_csp(x, dim, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then - res = sum(x, dim) / real(size(x, dim), sp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_12_csp_csp - module function mean_13_csp_csp(x, dim, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then - res = sum(x, dim) / real(size(x, dim), sp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_13_csp_csp - module function mean_14_csp_csp(x, dim, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then - res = sum(x, dim) / real(size(x, dim), sp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_14_csp_csp - module function mean_15_csp_csp(x, dim, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then - res = sum(x, dim) / real(size(x, dim), sp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_15_csp_csp - module function mean_1_cdp_cdp(x, dim, mask) result(res) - complex(dp), intent(in) :: x(:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - complex(dp) :: res - - if (.not.optval(mask, .true.)) then - res = ieee_value(1._dp, ieee_quiet_nan) - return - end if - - if (dim >= 1 .and. dim <= 1) then - res = sum(x, dim) / real(size(x, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_1_cdp_cdp - module function mean_2_cdp_cdp(x, dim, mask) result(res) - complex(dp), intent(in) :: x(:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then - res = sum(x, dim) / real(size(x, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_2_cdp_cdp - module function mean_3_cdp_cdp(x, dim, mask) result(res) - complex(dp), intent(in) :: x(:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then - res = sum(x, dim) / real(size(x, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_3_cdp_cdp - module function mean_4_cdp_cdp(x, dim, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then - res = sum(x, dim) / real(size(x, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_4_cdp_cdp - module function mean_5_cdp_cdp(x, dim, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then - res = sum(x, dim) / real(size(x, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_5_cdp_cdp - module function mean_6_cdp_cdp(x, dim, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then - res = sum(x, dim) / real(size(x, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_6_cdp_cdp - module function mean_7_cdp_cdp(x, dim, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then - res = sum(x, dim) / real(size(x, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_7_cdp_cdp - module function mean_8_cdp_cdp(x, dim, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then - res = sum(x, dim) / real(size(x, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_8_cdp_cdp - module function mean_9_cdp_cdp(x, dim, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then - res = sum(x, dim) / real(size(x, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_9_cdp_cdp - module function mean_10_cdp_cdp(x, dim, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then - res = sum(x, dim) / real(size(x, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_10_cdp_cdp - module function mean_11_cdp_cdp(x, dim, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then - res = sum(x, dim) / real(size(x, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_11_cdp_cdp - module function mean_12_cdp_cdp(x, dim, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then - res = sum(x, dim) / real(size(x, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_12_cdp_cdp - module function mean_13_cdp_cdp(x, dim, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then - res = sum(x, dim) / real(size(x, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_13_cdp_cdp - module function mean_14_cdp_cdp(x, dim, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then - res = sum(x, dim) / real(size(x, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_14_cdp_cdp - module function mean_15_cdp_cdp(x, dim, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then - res = sum(x, dim) / real(size(x, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_15_cdp_cdp - module function mean_1_cqp_cqp(x, dim, mask) result(res) - complex(qp), intent(in) :: x(:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - complex(qp) :: res - - if (.not.optval(mask, .true.)) then - res = ieee_value(1._qp, ieee_quiet_nan) - return - end if - - if (dim >= 1 .and. dim <= 1) then - res = sum(x, dim) / real(size(x, dim), qp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_1_cqp_cqp - module function mean_2_cqp_cqp(x, dim, mask) result(res) - complex(qp), intent(in) :: x(:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then - res = sum(x, dim) / real(size(x, dim), qp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_2_cqp_cqp - module function mean_3_cqp_cqp(x, dim, mask) result(res) - complex(qp), intent(in) :: x(:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then - res = sum(x, dim) / real(size(x, dim), qp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_3_cqp_cqp - module function mean_4_cqp_cqp(x, dim, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then - res = sum(x, dim) / real(size(x, dim), qp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_4_cqp_cqp - module function mean_5_cqp_cqp(x, dim, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then - res = sum(x, dim) / real(size(x, dim), qp) + res = sum(x, dim) / real(size(x, dim), dp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_5_cqp_cqp - module function mean_6_cqp_cqp(x, dim, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:) + end function mean_5_rdp_rdp + module function mean_6_rdp_rdp(x, dim, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:) integer, intent(in) :: dim logical, intent(in), optional :: mask - complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then - res = sum(x, dim) / real(size(x, dim), qp) + res = sum(x, dim) / real(size(x, dim), dp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_6_cqp_cqp - module function mean_7_cqp_cqp(x, dim, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:) + end function mean_6_rdp_rdp + module function mean_7_rdp_rdp(x, dim, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:) integer, intent(in) :: dim logical, intent(in), optional :: mask - complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then - res = sum(x, dim) / real(size(x, dim), qp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_7_cqp_cqp - module function mean_8_cqp_cqp(x, dim, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then - res = sum(x, dim) / real(size(x, dim), qp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_8_cqp_cqp - module function mean_9_cqp_cqp(x, dim, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then - res = sum(x, dim) / real(size(x, dim), qp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_9_cqp_cqp - module function mean_10_cqp_cqp(x, dim, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then - res = sum(x, dim) / real(size(x, dim), qp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_10_cqp_cqp - module function mean_11_cqp_cqp(x, dim, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then - res = sum(x, dim) / real(size(x, dim), qp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_11_cqp_cqp - module function mean_12_cqp_cqp(x, dim, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then - res = sum(x, dim) / real(size(x, dim), qp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_12_cqp_cqp - module function mean_13_cqp_cqp(x, dim, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then - res = sum(x, dim) / real(size(x, dim), qp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_13_cqp_cqp - module function mean_14_cqp_cqp(x, dim, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then - res = sum(x, dim) / real(size(x, dim), qp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_14_cqp_cqp - module function mean_15_cqp_cqp(x, dim, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then - res = sum(x, dim) / real(size(x, dim), qp) + res = sum(x, dim) / real(size(x, dim), dp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_15_cqp_cqp - - - module function mean_1_iint8_dp(x, dim, mask) result(res) - integer(int8), intent(in) :: x(:) + end function mean_7_rdp_rdp + module function mean_1_rqp_rqp(x, dim, mask) result(res) + real(qp), intent(in) :: x(:) integer, intent(in) :: dim logical, intent(in), optional :: mask - real(dp) :: res + real(qp) :: res if (.not.optval(mask, .true.)) then - res = ieee_value(1._dp, ieee_quiet_nan) + res = ieee_value(1._qp, ieee_quiet_nan) return end if if (dim >= 1 .and. dim <= 1) then - res = sum(real(x, dp), dim) / real(size(x, dim), dp) + res = sum(x, dim) / real(size(x, dim), qp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_1_iint8_dp - module function mean_2_iint8_dp(x, dim, mask) result(res) - integer(int8), intent(in) :: x(:,:) + end function mean_1_rqp_rqp + module function mean_2_rqp_rqp(x, dim, mask) result(res) + real(qp), intent(in) :: x(:,:) integer, intent(in) :: dim logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then - res = sum(real(x, dp), dim) / real(size(x, dim), dp) + res = sum(x, dim) / real(size(x, dim), qp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_2_iint8_dp - module function mean_3_iint8_dp(x, dim, mask) result(res) - integer(int8), intent(in) :: x(:,:,:) + end function mean_2_rqp_rqp + module function mean_3_rqp_rqp(x, dim, mask) result(res) + real(qp), intent(in) :: x(:,:,:) integer, intent(in) :: dim logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then - res = sum(real(x, dp), dim) / real(size(x, dim), dp) + res = sum(x, dim) / real(size(x, dim), qp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_3_iint8_dp - module function mean_4_iint8_dp(x, dim, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:) + end function mean_3_rqp_rqp + module function mean_4_rqp_rqp(x, dim, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:) integer, intent(in) :: dim logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then - res = sum(real(x, dp), dim) / real(size(x, dim), dp) + res = sum(x, dim) / real(size(x, dim), qp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_4_iint8_dp - module function mean_5_iint8_dp(x, dim, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:) + end function mean_4_rqp_rqp + module function mean_5_rqp_rqp(x, dim, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:) integer, intent(in) :: dim logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then - res = sum(real(x, dp), dim) / real(size(x, dim), dp) + res = sum(x, dim) / real(size(x, dim), qp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_5_iint8_dp - module function mean_6_iint8_dp(x, dim, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:) + end function mean_5_rqp_rqp + module function mean_6_rqp_rqp(x, dim, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:) integer, intent(in) :: dim logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then - res = sum(real(x, dp), dim) / real(size(x, dim), dp) + res = sum(x, dim) / real(size(x, dim), qp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_6_iint8_dp - module function mean_7_iint8_dp(x, dim, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:) + end function mean_6_rqp_rqp + module function mean_7_rqp_rqp(x, dim, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:) integer, intent(in) :: dim logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then - res = sum(real(x, dp), dim) / real(size(x, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_7_iint8_dp - module function mean_8_iint8_dp(x, dim, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then - res = sum(real(x, dp), dim) / real(size(x, dim), dp) + res = sum(x, dim) / real(size(x, dim), qp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_8_iint8_dp - module function mean_9_iint8_dp(x, dim, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:) + end function mean_7_rqp_rqp + module function mean_1_csp_csp(x, dim, mask) result(res) + complex(sp), intent(in) :: x(:) integer, intent(in) :: dim logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then - res = sum(real(x, dp), dim) / real(size(x, dim), dp) + if (dim >= 1 .and. dim <= 1) then + res = sum(x, dim) / real(size(x, dim), sp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_9_iint8_dp - module function mean_10_iint8_dp(x, dim, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + end function mean_1_csp_csp + module function mean_2_csp_csp(x, dim, mask) result(res) + complex(sp), intent(in) :: x(:,:) integer, intent(in) :: dim logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then - res = sum(real(x, dp), dim) / real(size(x, dim), dp) + if (dim >= 1 .and. dim <= 2) then + res = sum(x, dim) / real(size(x, dim), sp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_10_iint8_dp - module function mean_11_iint8_dp(x, dim, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + end function mean_2_csp_csp + module function mean_3_csp_csp(x, dim, mask) result(res) + complex(sp), intent(in) :: x(:,:,:) integer, intent(in) :: dim logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then - res = sum(real(x, dp), dim) / real(size(x, dim), dp) + if (dim >= 1 .and. dim <= 3) then + res = sum(x, dim) / real(size(x, dim), sp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_11_iint8_dp - module function mean_12_iint8_dp(x, dim, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + end function mean_3_csp_csp + module function mean_4_csp_csp(x, dim, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:) integer, intent(in) :: dim logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then - res = sum(real(x, dp), dim) / real(size(x, dim), dp) + if (dim >= 1 .and. dim <= 4) then + res = sum(x, dim) / real(size(x, dim), sp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_12_iint8_dp - module function mean_13_iint8_dp(x, dim, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + end function mean_4_csp_csp + module function mean_5_csp_csp(x, dim, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:) integer, intent(in) :: dim logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then - res = sum(real(x, dp), dim) / real(size(x, dim), dp) + if (dim >= 1 .and. dim <= 5) then + res = sum(x, dim) / real(size(x, dim), sp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_13_iint8_dp - module function mean_14_iint8_dp(x, dim, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function mean_5_csp_csp + module function mean_6_csp_csp(x, dim, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:) integer, intent(in) :: dim logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then - res = sum(real(x, dp), dim) / real(size(x, dim), dp) + if (dim >= 1 .and. dim <= 6) then + res = sum(x, dim) / real(size(x, dim), sp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_14_iint8_dp - module function mean_15_iint8_dp(x, dim, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function mean_6_csp_csp + module function mean_7_csp_csp(x, dim, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:) integer, intent(in) :: dim logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then - res = sum(real(x, dp), dim) / real(size(x, dim), dp) + if (dim >= 1 .and. dim <= 7) then + res = sum(x, dim) / real(size(x, dim), sp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_15_iint8_dp - module function mean_1_iint16_dp(x, dim, mask) result(res) - integer(int16), intent(in) :: x(:) + end function mean_7_csp_csp + module function mean_1_cdp_cdp(x, dim, mask) result(res) + complex(dp), intent(in) :: x(:) integer, intent(in) :: dim logical, intent(in), optional :: mask - real(dp) :: res + complex(dp) :: res if (.not.optval(mask, .true.)) then res = ieee_value(1._dp, ieee_quiet_nan) @@ -4102,17 +1456,17 @@ module function mean_1_iint16_dp(x, dim, mask) result(res) end if if (dim >= 1 .and. dim <= 1) then - res = sum(real(x, dp), dim) / real(size(x, dim), dp) + res = sum(x, dim) / real(size(x, dim), dp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_1_iint16_dp - module function mean_2_iint16_dp(x, dim, mask) result(res) - integer(int16), intent(in) :: x(:,:) + end function mean_1_cdp_cdp + module function mean_2_cdp_cdp(x, dim, mask) result(res) + complex(dp), intent(in) :: x(:,:) integer, intent(in) :: dim logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then - res = sum(real(x, dp), dim) / real(size(x, dim), dp) + res = sum(x, dim) / real(size(x, dim), dp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_2_iint16_dp - module function mean_3_iint16_dp(x, dim, mask) result(res) - integer(int16), intent(in) :: x(:,:,:) + end function mean_2_cdp_cdp + module function mean_3_cdp_cdp(x, dim, mask) result(res) + complex(dp), intent(in) :: x(:,:,:) integer, intent(in) :: dim logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then - res = sum(real(x, dp), dim) / real(size(x, dim), dp) + res = sum(x, dim) / real(size(x, dim), dp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_3_iint16_dp - module function mean_4_iint16_dp(x, dim, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:) + end function mean_3_cdp_cdp + module function mean_4_cdp_cdp(x, dim, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:) integer, intent(in) :: dim logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then - res = sum(real(x, dp), dim) / real(size(x, dim), dp) + res = sum(x, dim) / real(size(x, dim), dp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_4_iint16_dp - module function mean_5_iint16_dp(x, dim, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:) + end function mean_4_cdp_cdp + module function mean_5_cdp_cdp(x, dim, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:) integer, intent(in) :: dim logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then - res = sum(real(x, dp), dim) / real(size(x, dim), dp) + res = sum(x, dim) / real(size(x, dim), dp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_5_iint16_dp - module function mean_6_iint16_dp(x, dim, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:) + end function mean_5_cdp_cdp + module function mean_6_cdp_cdp(x, dim, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:) integer, intent(in) :: dim logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then - res = sum(real(x, dp), dim) / real(size(x, dim), dp) + res = sum(x, dim) / real(size(x, dim), dp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_6_iint16_dp - module function mean_7_iint16_dp(x, dim, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:) + end function mean_6_cdp_cdp + module function mean_7_cdp_cdp(x, dim, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:) integer, intent(in) :: dim logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then - res = sum(real(x, dp), dim) / real(size(x, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_7_iint16_dp - module function mean_8_iint16_dp(x, dim, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then - res = sum(real(x, dp), dim) / real(size(x, dim), dp) + if (dim >= 1 .and. dim <= 7) then + res = sum(x, dim) / real(size(x, dim), dp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_8_iint16_dp - module function mean_9_iint16_dp(x, dim, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:) + end function mean_7_cdp_cdp + module function mean_1_cqp_cqp(x, dim, mask) result(res) + complex(qp), intent(in) :: x(:) integer, intent(in) :: dim logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then - res = sum(real(x, dp), dim) / real(size(x, dim), dp) + if (dim >= 1 .and. dim <= 1) then + res = sum(x, dim) / real(size(x, dim), qp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_9_iint16_dp - module function mean_10_iint16_dp(x, dim, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + end function mean_1_cqp_cqp + module function mean_2_cqp_cqp(x, dim, mask) result(res) + complex(qp), intent(in) :: x(:,:) integer, intent(in) :: dim logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then - res = sum(real(x, dp), dim) / real(size(x, dim), dp) + if (dim >= 1 .and. dim <= 2) then + res = sum(x, dim) / real(size(x, dim), qp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_10_iint16_dp - module function mean_11_iint16_dp(x, dim, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + end function mean_2_cqp_cqp + module function mean_3_cqp_cqp(x, dim, mask) result(res) + complex(qp), intent(in) :: x(:,:,:) integer, intent(in) :: dim logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then - res = sum(real(x, dp), dim) / real(size(x, dim), dp) + if (dim >= 1 .and. dim <= 3) then + res = sum(x, dim) / real(size(x, dim), qp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_11_iint16_dp - module function mean_12_iint16_dp(x, dim, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + end function mean_3_cqp_cqp + module function mean_4_cqp_cqp(x, dim, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:) integer, intent(in) :: dim logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then - res = sum(real(x, dp), dim) / real(size(x, dim), dp) + if (dim >= 1 .and. dim <= 4) then + res = sum(x, dim) / real(size(x, dim), qp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_12_iint16_dp - module function mean_13_iint16_dp(x, dim, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + end function mean_4_cqp_cqp + module function mean_5_cqp_cqp(x, dim, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:) integer, intent(in) :: dim logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then - res = sum(real(x, dp), dim) / real(size(x, dim), dp) + if (dim >= 1 .and. dim <= 5) then + res = sum(x, dim) / real(size(x, dim), qp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_13_iint16_dp - module function mean_14_iint16_dp(x, dim, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function mean_5_cqp_cqp + module function mean_6_cqp_cqp(x, dim, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:) integer, intent(in) :: dim logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then - res = sum(real(x, dp), dim) / real(size(x, dim), dp) + if (dim >= 1 .and. dim <= 6) then + res = sum(x, dim) / real(size(x, dim), qp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_14_iint16_dp - module function mean_15_iint16_dp(x, dim, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function mean_6_cqp_cqp + module function mean_7_cqp_cqp(x, dim, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:) integer, intent(in) :: dim logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then - res = sum(real(x, dp), dim) / real(size(x, dim), dp) + if (dim >= 1 .and. dim <= 7) then + res = sum(x, dim) / real(size(x, dim), qp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_15_iint16_dp - module function mean_1_iint32_dp(x, dim, mask) result(res) - integer(int32), intent(in) :: x(:) + end function mean_7_cqp_cqp + + + module function mean_1_iint8_dp(x, dim, mask) result(res) + integer(int8), intent(in) :: x(:) integer, intent(in) :: dim logical, intent(in), optional :: mask real(dp) :: res @@ -4411,9 +1725,9 @@ module function mean_1_iint32_dp(x, dim, mask) result(res) call error_stop("ERROR (mean): wrong dimension") end if - end function mean_1_iint32_dp - module function mean_2_iint32_dp(x, dim, mask) result(res) - integer(int32), intent(in) :: x(:,:) + end function mean_1_iint8_dp + module function mean_2_iint8_dp(x, dim, mask) result(res) + integer(int8), intent(in) :: x(:,:) integer, intent(in) :: dim logical, intent(in), optional :: mask real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then - res = sum(real(x, dp), dim) / real(size(x, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_8_iint32_dp - module function mean_9_iint32_dp(x, dim, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:) + end function mean_7_iint8_dp + module function mean_1_iint16_dp(x, dim, mask) result(res) + integer(int16), intent(in) :: x(:) integer, intent(in) :: dim logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then + if (dim >= 1 .and. dim <= 1) then res = sum(real(x, dp), dim) / real(size(x, dim), dp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_9_iint32_dp - module function mean_10_iint32_dp(x, dim, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + end function mean_1_iint16_dp + module function mean_2_iint16_dp(x, dim, mask) result(res) + integer(int16), intent(in) :: x(:,:) integer, intent(in) :: dim logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then + if (dim >= 1 .and. dim <= 2) then res = sum(real(x, dp), dim) / real(size(x, dim), dp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_10_iint32_dp - module function mean_11_iint32_dp(x, dim, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + end function mean_2_iint16_dp + module function mean_3_iint16_dp(x, dim, mask) result(res) + integer(int16), intent(in) :: x(:,:,:) integer, intent(in) :: dim logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then + if (dim >= 1 .and. dim <= 3) then res = sum(real(x, dp), dim) / real(size(x, dim), dp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_11_iint32_dp - module function mean_12_iint32_dp(x, dim, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + end function mean_3_iint16_dp + module function mean_4_iint16_dp(x, dim, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:) integer, intent(in) :: dim logical, intent(in), optional :: mask real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then + if (dim >= 1 .and. dim <= 4) then res = sum(real(x, dp), dim) / real(size(x, dim), dp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_12_iint32_dp - module function mean_13_iint32_dp(x, dim, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + end function mean_4_iint16_dp + module function mean_5_iint16_dp(x, dim, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:) integer, intent(in) :: dim logical, intent(in), optional :: mask real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then + if (dim >= 1 .and. dim <= 5) then res = sum(real(x, dp), dim) / real(size(x, dim), dp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_13_iint32_dp - module function mean_14_iint32_dp(x, dim, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function mean_5_iint16_dp + module function mean_6_iint16_dp(x, dim, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:) integer, intent(in) :: dim logical, intent(in), optional :: mask real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + if (dim >= 1 .and. dim <= 6) then res = sum(real(x, dp), dim) / real(size(x, dim), dp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_14_iint32_dp - module function mean_15_iint32_dp(x, dim, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function mean_6_iint16_dp + module function mean_7_iint16_dp(x, dim, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:) integer, intent(in) :: dim logical, intent(in), optional :: mask real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + if (dim >= 1 .and. dim <= 7) then res = sum(real(x, dp), dim) / real(size(x, dim), dp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_15_iint32_dp - module function mean_1_iint64_dp(x, dim, mask) result(res) - integer(int64), intent(in) :: x(:) + end function mean_7_iint16_dp + module function mean_1_iint32_dp(x, dim, mask) result(res) + integer(int32), intent(in) :: x(:) integer, intent(in) :: dim logical, intent(in), optional :: mask real(dp) :: res @@ -4715,9 +1987,9 @@ module function mean_1_iint64_dp(x, dim, mask) result(res) call error_stop("ERROR (mean): wrong dimension") end if - end function mean_1_iint64_dp - module function mean_2_iint64_dp(x, dim, mask) result(res) - integer(int64), intent(in) :: x(:,:) + end function mean_1_iint32_dp + module function mean_2_iint32_dp(x, dim, mask) result(res) + integer(int32), intent(in) :: x(:,:) integer, intent(in) :: dim logical, intent(in), optional :: mask real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then - res = sum(real(x, dp), dim) / real(size(x, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_8_iint64_dp - module function mean_9_iint64_dp(x, dim, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:) + end function mean_7_iint32_dp + module function mean_1_iint64_dp(x, dim, mask) result(res) + integer(int64), intent(in) :: x(:) integer, intent(in) :: dim logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then + if (dim >= 1 .and. dim <= 1) then res = sum(real(x, dp), dim) / real(size(x, dim), dp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_9_iint64_dp - module function mean_10_iint64_dp(x, dim, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + end function mean_1_iint64_dp + module function mean_2_iint64_dp(x, dim, mask) result(res) + integer(int64), intent(in) :: x(:,:) integer, intent(in) :: dim - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then + if (dim >= 1 .and. dim <= 2) then res = sum(real(x, dp), dim) / real(size(x, dim), dp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_10_iint64_dp - module function mean_11_iint64_dp(x, dim, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + end function mean_2_iint64_dp + module function mean_3_iint64_dp(x, dim, mask) result(res) + integer(int64), intent(in) :: x(:,:,:) integer, intent(in) :: dim logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then + if (dim >= 1 .and. dim <= 3) then res = sum(real(x, dp), dim) / real(size(x, dim), dp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_11_iint64_dp - module function mean_12_iint64_dp(x, dim, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + end function mean_3_iint64_dp + module function mean_4_iint64_dp(x, dim, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:) integer, intent(in) :: dim logical, intent(in), optional :: mask real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then + if (dim >= 1 .and. dim <= 4) then res = sum(real(x, dp), dim) / real(size(x, dim), dp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_12_iint64_dp - module function mean_13_iint64_dp(x, dim, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + end function mean_4_iint64_dp + module function mean_5_iint64_dp(x, dim, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:) integer, intent(in) :: dim logical, intent(in), optional :: mask real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then + if (dim >= 1 .and. dim <= 5) then res = sum(real(x, dp), dim) / real(size(x, dim), dp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_13_iint64_dp - module function mean_14_iint64_dp(x, dim, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function mean_5_iint64_dp + module function mean_6_iint64_dp(x, dim, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:) integer, intent(in) :: dim logical, intent(in), optional :: mask real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + if (dim >= 1 .and. dim <= 6) then res = sum(real(x, dp), dim) / real(size(x, dim), dp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_14_iint64_dp - module function mean_15_iint64_dp(x, dim, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function mean_6_iint64_dp + module function mean_7_iint64_dp(x, dim, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:) integer, intent(in) :: dim logical, intent(in), optional :: mask real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + if (dim >= 1 .and. dim <= 7) then res = sum(real(x, dp), dim) / real(size(x, dim), dp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_15_iint64_dp + end function mean_7_iint64_dp module function mean_mask_all_1_rsp_rsp(x, mask) result(res) real(sp), intent(in) :: x(:) @@ -5059,70 +2289,6 @@ module function mean_mask_all_7_rsp_rsp(x, mask) result(res) res = sum(x, mask) / real(count(mask, kind = int64), sp) end function mean_mask_all_7_rsp_rsp - module function mean_mask_all_8_rsp_rsp(x, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:) - real(sp) :: res - - res = sum(x, mask) / real(count(mask, kind = int64), sp) - - end function mean_mask_all_8_rsp_rsp - module function mean_mask_all_9_rsp_rsp(x, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) - real(sp) :: res - - res = sum(x, mask) / real(count(mask, kind = int64), sp) - - end function mean_mask_all_9_rsp_rsp - module function mean_mask_all_10_rsp_rsp(x, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) - real(sp) :: res - - res = sum(x, mask) / real(count(mask, kind = int64), sp) - - end function mean_mask_all_10_rsp_rsp - module function mean_mask_all_11_rsp_rsp(x, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) - real(sp) :: res - - res = sum(x, mask) / real(count(mask, kind = int64), sp) - - end function mean_mask_all_11_rsp_rsp - module function mean_mask_all_12_rsp_rsp(x, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) - real(sp) :: res - - res = sum(x, mask) / real(count(mask, kind = int64), sp) - - end function mean_mask_all_12_rsp_rsp - module function mean_mask_all_13_rsp_rsp(x, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) - real(sp) :: res - - res = sum(x, mask) / real(count(mask, kind = int64), sp) - - end function mean_mask_all_13_rsp_rsp - module function mean_mask_all_14_rsp_rsp(x, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - real(sp) :: res - - res = sum(x, mask) / real(count(mask, kind = int64), sp) - - end function mean_mask_all_14_rsp_rsp - module function mean_mask_all_15_rsp_rsp(x, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - real(sp) :: res - - res = sum(x, mask) / real(count(mask, kind = int64), sp) - - end function mean_mask_all_15_rsp_rsp module function mean_mask_all_1_rdp_rdp(x, mask) result(res) real(dp), intent(in) :: x(:) logical, intent(in) :: mask(:) @@ -5179,70 +2345,6 @@ module function mean_mask_all_7_rdp_rdp(x, mask) result(res) res = sum(x, mask) / real(count(mask, kind = int64), dp) end function mean_mask_all_7_rdp_rdp - module function mean_mask_all_8_rdp_rdp(x, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:) - real(dp) :: res - - res = sum(x, mask) / real(count(mask, kind = int64), dp) - - end function mean_mask_all_8_rdp_rdp - module function mean_mask_all_9_rdp_rdp(x, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) - real(dp) :: res - - res = sum(x, mask) / real(count(mask, kind = int64), dp) - - end function mean_mask_all_9_rdp_rdp - module function mean_mask_all_10_rdp_rdp(x, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) - real(dp) :: res - - res = sum(x, mask) / real(count(mask, kind = int64), dp) - - end function mean_mask_all_10_rdp_rdp - module function mean_mask_all_11_rdp_rdp(x, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res - - res = sum(x, mask) / real(count(mask, kind = int64), dp) - - end function mean_mask_all_11_rdp_rdp - module function mean_mask_all_12_rdp_rdp(x, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res - - res = sum(x, mask) / real(count(mask, kind = int64), dp) - - end function mean_mask_all_12_rdp_rdp - module function mean_mask_all_13_rdp_rdp(x, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res - - res = sum(x, mask) / real(count(mask, kind = int64), dp) - - end function mean_mask_all_13_rdp_rdp - module function mean_mask_all_14_rdp_rdp(x, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res - - res = sum(x, mask) / real(count(mask, kind = int64), dp) - - end function mean_mask_all_14_rdp_rdp - module function mean_mask_all_15_rdp_rdp(x, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res - - res = sum(x, mask) / real(count(mask, kind = int64), dp) - - end function mean_mask_all_15_rdp_rdp module function mean_mask_all_1_rqp_rqp(x, mask) result(res) real(qp), intent(in) :: x(:) logical, intent(in) :: mask(:) @@ -5299,70 +2401,6 @@ module function mean_mask_all_7_rqp_rqp(x, mask) result(res) res = sum(x, mask) / real(count(mask, kind = int64), qp) end function mean_mask_all_7_rqp_rqp - module function mean_mask_all_8_rqp_rqp(x, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:) - real(qp) :: res - - res = sum(x, mask) / real(count(mask, kind = int64), qp) - - end function mean_mask_all_8_rqp_rqp - module function mean_mask_all_9_rqp_rqp(x, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) - real(qp) :: res - - res = sum(x, mask) / real(count(mask, kind = int64), qp) - - end function mean_mask_all_9_rqp_rqp - module function mean_mask_all_10_rqp_rqp(x, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) - real(qp) :: res - - res = sum(x, mask) / real(count(mask, kind = int64), qp) - - end function mean_mask_all_10_rqp_rqp - module function mean_mask_all_11_rqp_rqp(x, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) - real(qp) :: res - - res = sum(x, mask) / real(count(mask, kind = int64), qp) - - end function mean_mask_all_11_rqp_rqp - module function mean_mask_all_12_rqp_rqp(x, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) - real(qp) :: res - - res = sum(x, mask) / real(count(mask, kind = int64), qp) - - end function mean_mask_all_12_rqp_rqp - module function mean_mask_all_13_rqp_rqp(x, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) - real(qp) :: res - - res = sum(x, mask) / real(count(mask, kind = int64), qp) - - end function mean_mask_all_13_rqp_rqp - module function mean_mask_all_14_rqp_rqp(x, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - real(qp) :: res - - res = sum(x, mask) / real(count(mask, kind = int64), qp) - - end function mean_mask_all_14_rqp_rqp - module function mean_mask_all_15_rqp_rqp(x, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - real(qp) :: res - - res = sum(x, mask) / real(count(mask, kind = int64), qp) - - end function mean_mask_all_15_rqp_rqp module function mean_mask_all_1_csp_csp(x, mask) result(res) complex(sp), intent(in) :: x(:) logical, intent(in) :: mask(:) @@ -5419,70 +2457,6 @@ module function mean_mask_all_7_csp_csp(x, mask) result(res) res = sum(x, mask) / real(count(mask, kind = int64), sp) end function mean_mask_all_7_csp_csp - module function mean_mask_all_8_csp_csp(x, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:) - complex(sp) :: res - - res = sum(x, mask) / real(count(mask, kind = int64), sp) - - end function mean_mask_all_8_csp_csp - module function mean_mask_all_9_csp_csp(x, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) - complex(sp) :: res - - res = sum(x, mask) / real(count(mask, kind = int64), sp) - - end function mean_mask_all_9_csp_csp - module function mean_mask_all_10_csp_csp(x, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) - complex(sp) :: res - - res = sum(x, mask) / real(count(mask, kind = int64), sp) - - end function mean_mask_all_10_csp_csp - module function mean_mask_all_11_csp_csp(x, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) - complex(sp) :: res - - res = sum(x, mask) / real(count(mask, kind = int64), sp) - - end function mean_mask_all_11_csp_csp - module function mean_mask_all_12_csp_csp(x, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) - complex(sp) :: res - - res = sum(x, mask) / real(count(mask, kind = int64), sp) - - end function mean_mask_all_12_csp_csp - module function mean_mask_all_13_csp_csp(x, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) - complex(sp) :: res - - res = sum(x, mask) / real(count(mask, kind = int64), sp) - - end function mean_mask_all_13_csp_csp - module function mean_mask_all_14_csp_csp(x, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - complex(sp) :: res - - res = sum(x, mask) / real(count(mask, kind = int64), sp) - - end function mean_mask_all_14_csp_csp - module function mean_mask_all_15_csp_csp(x, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - complex(sp) :: res - - res = sum(x, mask) / real(count(mask, kind = int64), sp) - - end function mean_mask_all_15_csp_csp module function mean_mask_all_1_cdp_cdp(x, mask) result(res) complex(dp), intent(in) :: x(:) logical, intent(in) :: mask(:) @@ -5536,193 +2510,65 @@ module function mean_mask_all_7_cdp_cdp(x, mask) result(res) logical, intent(in) :: mask(:,:,:,:,:,:,:) complex(dp) :: res - res = sum(x, mask) / real(count(mask, kind = int64), dp) - - end function mean_mask_all_7_cdp_cdp - module function mean_mask_all_8_cdp_cdp(x, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:) - complex(dp) :: res - - res = sum(x, mask) / real(count(mask, kind = int64), dp) - - end function mean_mask_all_8_cdp_cdp - module function mean_mask_all_9_cdp_cdp(x, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) - complex(dp) :: res - - res = sum(x, mask) / real(count(mask, kind = int64), dp) - - end function mean_mask_all_9_cdp_cdp - module function mean_mask_all_10_cdp_cdp(x, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) - complex(dp) :: res - - res = sum(x, mask) / real(count(mask, kind = int64), dp) - - end function mean_mask_all_10_cdp_cdp - module function mean_mask_all_11_cdp_cdp(x, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) - complex(dp) :: res - - res = sum(x, mask) / real(count(mask, kind = int64), dp) - - end function mean_mask_all_11_cdp_cdp - module function mean_mask_all_12_cdp_cdp(x, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) - complex(dp) :: res - - res = sum(x, mask) / real(count(mask, kind = int64), dp) - - end function mean_mask_all_12_cdp_cdp - module function mean_mask_all_13_cdp_cdp(x, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) - complex(dp) :: res - - res = sum(x, mask) / real(count(mask, kind = int64), dp) - - end function mean_mask_all_13_cdp_cdp - module function mean_mask_all_14_cdp_cdp(x, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - complex(dp) :: res - - res = sum(x, mask) / real(count(mask, kind = int64), dp) - - end function mean_mask_all_14_cdp_cdp - module function mean_mask_all_15_cdp_cdp(x, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - complex(dp) :: res - - res = sum(x, mask) / real(count(mask, kind = int64), dp) - - end function mean_mask_all_15_cdp_cdp - module function mean_mask_all_1_cqp_cqp(x, mask) result(res) - complex(qp), intent(in) :: x(:) - logical, intent(in) :: mask(:) - complex(qp) :: res - - res = sum(x, mask) / real(count(mask, kind = int64), qp) - - end function mean_mask_all_1_cqp_cqp - module function mean_mask_all_2_cqp_cqp(x, mask) result(res) - complex(qp), intent(in) :: x(:,:) - logical, intent(in) :: mask(:,:) - complex(qp) :: res - - res = sum(x, mask) / real(count(mask, kind = int64), qp) - - end function mean_mask_all_2_cqp_cqp - module function mean_mask_all_3_cqp_cqp(x, mask) result(res) - complex(qp), intent(in) :: x(:,:,:) - logical, intent(in) :: mask(:,:,:) - complex(qp) :: res - - res = sum(x, mask) / real(count(mask, kind = int64), qp) - - end function mean_mask_all_3_cqp_cqp - module function mean_mask_all_4_cqp_cqp(x, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:) - logical, intent(in) :: mask(:,:,:,:) - complex(qp) :: res - - res = sum(x, mask) / real(count(mask, kind = int64), qp) - - end function mean_mask_all_4_cqp_cqp - module function mean_mask_all_5_cqp_cqp(x, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:) - complex(qp) :: res - - res = sum(x, mask) / real(count(mask, kind = int64), qp) - - end function mean_mask_all_5_cqp_cqp - module function mean_mask_all_6_cqp_cqp(x, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:) - complex(qp) :: res - - res = sum(x, mask) / real(count(mask, kind = int64), qp) - - end function mean_mask_all_6_cqp_cqp - module function mean_mask_all_7_cqp_cqp(x, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:) - complex(qp) :: res - - res = sum(x, mask) / real(count(mask, kind = int64), qp) - - end function mean_mask_all_7_cqp_cqp - module function mean_mask_all_8_cqp_cqp(x, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:) - complex(qp) :: res - - res = sum(x, mask) / real(count(mask, kind = int64), qp) + res = sum(x, mask) / real(count(mask, kind = int64), dp) - end function mean_mask_all_8_cqp_cqp - module function mean_mask_all_9_cqp_cqp(x, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + end function mean_mask_all_7_cdp_cdp + module function mean_mask_all_1_cqp_cqp(x, mask) result(res) + complex(qp), intent(in) :: x(:) + logical, intent(in) :: mask(:) complex(qp) :: res res = sum(x, mask) / real(count(mask, kind = int64), qp) - end function mean_mask_all_9_cqp_cqp - module function mean_mask_all_10_cqp_cqp(x, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + end function mean_mask_all_1_cqp_cqp + module function mean_mask_all_2_cqp_cqp(x, mask) result(res) + complex(qp), intent(in) :: x(:,:) + logical, intent(in) :: mask(:,:) complex(qp) :: res res = sum(x, mask) / real(count(mask, kind = int64), qp) - end function mean_mask_all_10_cqp_cqp - module function mean_mask_all_11_cqp_cqp(x, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + end function mean_mask_all_2_cqp_cqp + module function mean_mask_all_3_cqp_cqp(x, mask) result(res) + complex(qp), intent(in) :: x(:,:,:) + logical, intent(in) :: mask(:,:,:) complex(qp) :: res res = sum(x, mask) / real(count(mask, kind = int64), qp) - end function mean_mask_all_11_cqp_cqp - module function mean_mask_all_12_cqp_cqp(x, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + end function mean_mask_all_3_cqp_cqp + module function mean_mask_all_4_cqp_cqp(x, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:) + logical, intent(in) :: mask(:,:,:,:) complex(qp) :: res res = sum(x, mask) / real(count(mask, kind = int64), qp) - end function mean_mask_all_12_cqp_cqp - module function mean_mask_all_13_cqp_cqp(x, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + end function mean_mask_all_4_cqp_cqp + module function mean_mask_all_5_cqp_cqp(x, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:) complex(qp) :: res res = sum(x, mask) / real(count(mask, kind = int64), qp) - end function mean_mask_all_13_cqp_cqp - module function mean_mask_all_14_cqp_cqp(x, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function mean_mask_all_5_cqp_cqp + module function mean_mask_all_6_cqp_cqp(x, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:) complex(qp) :: res res = sum(x, mask) / real(count(mask, kind = int64), qp) - end function mean_mask_all_14_cqp_cqp - module function mean_mask_all_15_cqp_cqp(x, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function mean_mask_all_6_cqp_cqp + module function mean_mask_all_7_cqp_cqp(x, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:) complex(qp) :: res res = sum(x, mask) / real(count(mask, kind = int64), qp) - end function mean_mask_all_15_cqp_cqp + end function mean_mask_all_7_cqp_cqp module function mean_mask_all_1_iint8_dp(x, mask) result(res) @@ -5781,70 +2627,6 @@ module function mean_mask_all_7_iint8_dp(x, mask) result(res) res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) end function mean_mask_all_7_iint8_dp - module function mean_mask_all_8_iint8_dp(x, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:) - real(dp) :: res - - res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) - - end function mean_mask_all_8_iint8_dp - module function mean_mask_all_9_iint8_dp(x, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) - real(dp) :: res - - res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) - - end function mean_mask_all_9_iint8_dp - module function mean_mask_all_10_iint8_dp(x, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) - real(dp) :: res - - res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) - - end function mean_mask_all_10_iint8_dp - module function mean_mask_all_11_iint8_dp(x, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res - - res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) - - end function mean_mask_all_11_iint8_dp - module function mean_mask_all_12_iint8_dp(x, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res - - res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) - - end function mean_mask_all_12_iint8_dp - module function mean_mask_all_13_iint8_dp(x, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res - - res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) - - end function mean_mask_all_13_iint8_dp - module function mean_mask_all_14_iint8_dp(x, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res - - res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) - - end function mean_mask_all_14_iint8_dp - module function mean_mask_all_15_iint8_dp(x, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res - - res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) - - end function mean_mask_all_15_iint8_dp module function mean_mask_all_1_iint16_dp(x, mask) result(res) integer(int16), intent(in) :: x(:) logical, intent(in) :: mask(:) @@ -5901,70 +2683,6 @@ module function mean_mask_all_7_iint16_dp(x, mask) result(res) res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) end function mean_mask_all_7_iint16_dp - module function mean_mask_all_8_iint16_dp(x, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:) - real(dp) :: res - - res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) - - end function mean_mask_all_8_iint16_dp - module function mean_mask_all_9_iint16_dp(x, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) - real(dp) :: res - - res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) - - end function mean_mask_all_9_iint16_dp - module function mean_mask_all_10_iint16_dp(x, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) - real(dp) :: res - - res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) - - end function mean_mask_all_10_iint16_dp - module function mean_mask_all_11_iint16_dp(x, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res - - res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) - - end function mean_mask_all_11_iint16_dp - module function mean_mask_all_12_iint16_dp(x, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res - - res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) - - end function mean_mask_all_12_iint16_dp - module function mean_mask_all_13_iint16_dp(x, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res - - res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) - - end function mean_mask_all_13_iint16_dp - module function mean_mask_all_14_iint16_dp(x, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res - - res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) - - end function mean_mask_all_14_iint16_dp - module function mean_mask_all_15_iint16_dp(x, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res - - res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) - - end function mean_mask_all_15_iint16_dp module function mean_mask_all_1_iint32_dp(x, mask) result(res) integer(int32), intent(in) :: x(:) logical, intent(in) :: mask(:) @@ -6021,70 +2739,6 @@ module function mean_mask_all_7_iint32_dp(x, mask) result(res) res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) end function mean_mask_all_7_iint32_dp - module function mean_mask_all_8_iint32_dp(x, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:) - real(dp) :: res - - res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) - - end function mean_mask_all_8_iint32_dp - module function mean_mask_all_9_iint32_dp(x, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) - real(dp) :: res - - res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) - - end function mean_mask_all_9_iint32_dp - module function mean_mask_all_10_iint32_dp(x, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) - real(dp) :: res - - res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) - - end function mean_mask_all_10_iint32_dp - module function mean_mask_all_11_iint32_dp(x, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res - - res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) - - end function mean_mask_all_11_iint32_dp - module function mean_mask_all_12_iint32_dp(x, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res - - res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) - - end function mean_mask_all_12_iint32_dp - module function mean_mask_all_13_iint32_dp(x, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res - - res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) - - end function mean_mask_all_13_iint32_dp - module function mean_mask_all_14_iint32_dp(x, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res - - res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) - - end function mean_mask_all_14_iint32_dp - module function mean_mask_all_15_iint32_dp(x, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res - - res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) - - end function mean_mask_all_15_iint32_dp module function mean_mask_all_1_iint64_dp(x, mask) result(res) integer(int64), intent(in) :: x(:) logical, intent(in) :: mask(:) @@ -6141,70 +2795,6 @@ module function mean_mask_all_7_iint64_dp(x, mask) result(res) res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) end function mean_mask_all_7_iint64_dp - module function mean_mask_all_8_iint64_dp(x, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:) - real(dp) :: res - - res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) - - end function mean_mask_all_8_iint64_dp - module function mean_mask_all_9_iint64_dp(x, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) - real(dp) :: res - - res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) - - end function mean_mask_all_9_iint64_dp - module function mean_mask_all_10_iint64_dp(x, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) - real(dp) :: res - - res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) - - end function mean_mask_all_10_iint64_dp - module function mean_mask_all_11_iint64_dp(x, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res - - res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) - - end function mean_mask_all_11_iint64_dp - module function mean_mask_all_12_iint64_dp(x, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res - - res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) - - end function mean_mask_all_12_iint64_dp - module function mean_mask_all_13_iint64_dp(x, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res - - res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) - - end function mean_mask_all_13_iint64_dp - module function mean_mask_all_14_iint64_dp(x, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res - - res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) - - end function mean_mask_all_14_iint64_dp - module function mean_mask_all_15_iint64_dp(x, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res - - res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp) - - end function mean_mask_all_15_iint64_dp module function mean_mask_1_rsp_rsp(x, dim, mask) result(res) real(sp), intent(in) :: x(:) @@ -6234,207 +2824,74 @@ module function mean_mask_2_rsp_rsp(x, dim, mask) result(res) end function mean_mask_2_rsp_rsp module function mean_mask_3_rsp_rsp(x, dim, mask) result(res) real(sp), intent(in) :: x(:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:) - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then - res = sum(x, dim, mask) / real(count(mask, dim), sp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_3_rsp_rsp - module function mean_mask_4_rsp_rsp(x, dim, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:) - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then - res = sum(x, dim, mask) / real(count(mask, dim), sp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_4_rsp_rsp - module function mean_mask_5_rsp_rsp(x, dim, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:) - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then - res = sum(x, dim, mask) / real(count(mask, dim), sp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_5_rsp_rsp - module function mean_mask_6_rsp_rsp(x, dim, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:) - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then - res = sum(x, dim, mask) / real(count(mask, dim), sp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_6_rsp_rsp - module function mean_mask_7_rsp_rsp(x, dim, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:) - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then - res = sum(x, dim, mask) / real(count(mask, dim), sp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_7_rsp_rsp - module function mean_mask_8_rsp_rsp(x, dim, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:) - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then - res = sum(x, dim, mask) / real(count(mask, dim), sp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_8_rsp_rsp - module function mean_mask_9_rsp_rsp(x, dim, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then - res = sum(x, dim, mask) / real(count(mask, dim), sp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_9_rsp_rsp - module function mean_mask_10_rsp_rsp(x, dim, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then - res = sum(x, dim, mask) / real(count(mask, dim), sp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_10_rsp_rsp - module function mean_mask_11_rsp_rsp(x, dim, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then + if (dim >= 1 .and. dim <= 3) then res = sum(x, dim, mask) / real(count(mask, dim), sp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_mask_11_rsp_rsp - module function mean_mask_12_rsp_rsp(x, dim, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + end function mean_mask_3_rsp_rsp + module function mean_mask_4_rsp_rsp(x, dim, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:) real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then + if (dim >= 1 .and. dim <= 4) then res = sum(x, dim, mask) / real(count(mask, dim), sp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_mask_12_rsp_rsp - module function mean_mask_13_rsp_rsp(x, dim, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + end function mean_mask_4_rsp_rsp + module function mean_mask_5_rsp_rsp(x, dim, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:) real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then + if (dim >= 1 .and. dim <= 5) then res = sum(x, dim, mask) / real(count(mask, dim), sp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_mask_13_rsp_rsp - module function mean_mask_14_rsp_rsp(x, dim, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function mean_mask_5_rsp_rsp + module function mean_mask_6_rsp_rsp(x, dim, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:) real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + if (dim >= 1 .and. dim <= 6) then res = sum(x, dim, mask) / real(count(mask, dim), sp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_mask_14_rsp_rsp - module function mean_mask_15_rsp_rsp(x, dim, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function mean_mask_6_rsp_rsp + module function mean_mask_7_rsp_rsp(x, dim, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:) real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + if (dim >= 1 .and. dim <= 7) then res = sum(x, dim, mask) / real(count(mask, dim), sp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_mask_15_rsp_rsp + end function mean_mask_7_rsp_rsp module function mean_mask_1_rdp_rdp(x, dim, mask) result(res) real(dp), intent(in) :: x(:) integer, intent(in) :: dim @@ -6531,139 +2988,6 @@ module function mean_mask_7_rdp_rdp(x, dim, mask) result(res) end if end function mean_mask_7_rdp_rdp - module function mean_mask_8_rdp_rdp(x, dim, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then - res = sum(x, dim, mask) / real(count(mask, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_8_rdp_rdp - module function mean_mask_9_rdp_rdp(x, dim, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then - res = sum(x, dim, mask) / real(count(mask, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_9_rdp_rdp - module function mean_mask_10_rdp_rdp(x, dim, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then - res = sum(x, dim, mask) / real(count(mask, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_10_rdp_rdp - module function mean_mask_11_rdp_rdp(x, dim, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then - res = sum(x, dim, mask) / real(count(mask, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_11_rdp_rdp - module function mean_mask_12_rdp_rdp(x, dim, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then - res = sum(x, dim, mask) / real(count(mask, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_12_rdp_rdp - module function mean_mask_13_rdp_rdp(x, dim, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then - res = sum(x, dim, mask) / real(count(mask, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_13_rdp_rdp - module function mean_mask_14_rdp_rdp(x, dim, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then - res = sum(x, dim, mask) / real(count(mask, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_14_rdp_rdp - module function mean_mask_15_rdp_rdp(x, dim, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then - res = sum(x, dim, mask) / real(count(mask, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_15_rdp_rdp module function mean_mask_1_rqp_rqp(x, dim, mask) result(res) real(qp), intent(in) :: x(:) integer, intent(in) :: dim @@ -6760,139 +3084,6 @@ module function mean_mask_7_rqp_rqp(x, dim, mask) result(res) end if end function mean_mask_7_rqp_rqp - module function mean_mask_8_rqp_rqp(x, dim, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:) - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then - res = sum(x, dim, mask) / real(count(mask, dim), qp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_8_rqp_rqp - module function mean_mask_9_rqp_rqp(x, dim, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then - res = sum(x, dim, mask) / real(count(mask, dim), qp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_9_rqp_rqp - module function mean_mask_10_rqp_rqp(x, dim, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then - res = sum(x, dim, mask) / real(count(mask, dim), qp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_10_rqp_rqp - module function mean_mask_11_rqp_rqp(x, dim, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then - res = sum(x, dim, mask) / real(count(mask, dim), qp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_11_rqp_rqp - module function mean_mask_12_rqp_rqp(x, dim, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then - res = sum(x, dim, mask) / real(count(mask, dim), qp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_12_rqp_rqp - module function mean_mask_13_rqp_rqp(x, dim, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then - res = sum(x, dim, mask) / real(count(mask, dim), qp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_13_rqp_rqp - module function mean_mask_14_rqp_rqp(x, dim, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then - res = sum(x, dim, mask) / real(count(mask, dim), qp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_14_rqp_rqp - module function mean_mask_15_rqp_rqp(x, dim, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then - res = sum(x, dim, mask) / real(count(mask, dim), qp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_15_rqp_rqp module function mean_mask_1_csp_csp(x, dim, mask) result(res) complex(sp), intent(in) :: x(:) integer, intent(in) :: dim @@ -6965,163 +3156,30 @@ module function mean_mask_6_csp_csp(x, dim, mask) result(res) integer, intent(in) :: dim logical, intent(in) :: mask(:,:,:,:,:,:) complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then - res = sum(x, dim, mask) / real(count(mask, dim), sp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_6_csp_csp - module function mean_mask_7_csp_csp(x, dim, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:) - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then - res = sum(x, dim, mask) / real(count(mask, dim), sp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_7_csp_csp - module function mean_mask_8_csp_csp(x, dim, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:) - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then - res = sum(x, dim, mask) / real(count(mask, dim), sp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_8_csp_csp - module function mean_mask_9_csp_csp(x, dim, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then - res = sum(x, dim, mask) / real(count(mask, dim), sp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_9_csp_csp - module function mean_mask_10_csp_csp(x, dim, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then - res = sum(x, dim, mask) / real(count(mask, dim), sp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_10_csp_csp - module function mean_mask_11_csp_csp(x, dim, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then - res = sum(x, dim, mask) / real(count(mask, dim), sp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_11_csp_csp - module function mean_mask_12_csp_csp(x, dim, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then - res = sum(x, dim, mask) / real(count(mask, dim), sp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_12_csp_csp - module function mean_mask_13_csp_csp(x, dim, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then - res = sum(x, dim, mask) / real(count(mask, dim), sp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_13_csp_csp - module function mean_mask_14_csp_csp(x, dim, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + if (dim >= 1 .and. dim <= 6) then res = sum(x, dim, mask) / real(count(mask, dim), sp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_mask_14_csp_csp - module function mean_mask_15_csp_csp(x, dim, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function mean_mask_6_csp_csp + module function mean_mask_7_csp_csp(x, dim, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:) complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + if (dim >= 1 .and. dim <= 7) then res = sum(x, dim, mask) / real(count(mask, dim), sp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_mask_15_csp_csp + end function mean_mask_7_csp_csp module function mean_mask_1_cdp_cdp(x, dim, mask) result(res) complex(dp), intent(in) :: x(:) integer, intent(in) :: dim @@ -7218,139 +3276,6 @@ module function mean_mask_7_cdp_cdp(x, dim, mask) result(res) end if end function mean_mask_7_cdp_cdp - module function mean_mask_8_cdp_cdp(x, dim, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:) - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then - res = sum(x, dim, mask) / real(count(mask, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_8_cdp_cdp - module function mean_mask_9_cdp_cdp(x, dim, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then - res = sum(x, dim, mask) / real(count(mask, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_9_cdp_cdp - module function mean_mask_10_cdp_cdp(x, dim, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then - res = sum(x, dim, mask) / real(count(mask, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_10_cdp_cdp - module function mean_mask_11_cdp_cdp(x, dim, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then - res = sum(x, dim, mask) / real(count(mask, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_11_cdp_cdp - module function mean_mask_12_cdp_cdp(x, dim, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then - res = sum(x, dim, mask) / real(count(mask, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_12_cdp_cdp - module function mean_mask_13_cdp_cdp(x, dim, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then - res = sum(x, dim, mask) / real(count(mask, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_13_cdp_cdp - module function mean_mask_14_cdp_cdp(x, dim, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then - res = sum(x, dim, mask) / real(count(mask, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_14_cdp_cdp - module function mean_mask_15_cdp_cdp(x, dim, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then - res = sum(x, dim, mask) / real(count(mask, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_15_cdp_cdp module function mean_mask_1_cqp_cqp(x, dim, mask) result(res) complex(qp), intent(in) :: x(:) integer, intent(in) :: dim @@ -7447,139 +3372,6 @@ module function mean_mask_7_cqp_cqp(x, dim, mask) result(res) end if end function mean_mask_7_cqp_cqp - module function mean_mask_8_cqp_cqp(x, dim, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:) - complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then - res = sum(x, dim, mask) / real(count(mask, dim), qp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_8_cqp_cqp - module function mean_mask_9_cqp_cqp(x, dim, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) - complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then - res = sum(x, dim, mask) / real(count(mask, dim), qp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_9_cqp_cqp - module function mean_mask_10_cqp_cqp(x, dim, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) - complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then - res = sum(x, dim, mask) / real(count(mask, dim), qp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_10_cqp_cqp - module function mean_mask_11_cqp_cqp(x, dim, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) - complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then - res = sum(x, dim, mask) / real(count(mask, dim), qp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_11_cqp_cqp - module function mean_mask_12_cqp_cqp(x, dim, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) - complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then - res = sum(x, dim, mask) / real(count(mask, dim), qp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_12_cqp_cqp - module function mean_mask_13_cqp_cqp(x, dim, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) - complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then - res = sum(x, dim, mask) / real(count(mask, dim), qp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_13_cqp_cqp - module function mean_mask_14_cqp_cqp(x, dim, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then - res = sum(x, dim, mask) / real(count(mask, dim), qp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_14_cqp_cqp - module function mean_mask_15_cqp_cqp(x, dim, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then - res = sum(x, dim, mask) / real(count(mask, dim), qp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_15_cqp_cqp module function mean_mask_1_iint8_dp(x, dim, mask) result(res) @@ -7597,220 +3389,87 @@ module function mean_mask_1_iint8_dp(x, dim, mask) result(res) end function mean_mask_1_iint8_dp module function mean_mask_2_iint8_dp(x, dim, mask) result(res) integer(int8), intent(in) :: x(:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then - res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_2_iint8_dp - module function mean_mask_3_iint8_dp(x, dim, mask) result(res) - integer(int8), intent(in) :: x(:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then - res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_3_iint8_dp - module function mean_mask_4_iint8_dp(x, dim, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then - res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_4_iint8_dp - module function mean_mask_5_iint8_dp(x, dim, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then - res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_5_iint8_dp - module function mean_mask_6_iint8_dp(x, dim, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then - res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_6_iint8_dp - module function mean_mask_7_iint8_dp(x, dim, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then - res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_7_iint8_dp - module function mean_mask_8_iint8_dp(x, dim, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then - res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_8_iint8_dp - module function mean_mask_9_iint8_dp(x, dim, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then - res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_9_iint8_dp - module function mean_mask_10_iint8_dp(x, dim, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then + if (dim >= 1 .and. dim <= 2) then res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_mask_10_iint8_dp - module function mean_mask_11_iint8_dp(x, dim, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + end function mean_mask_2_iint8_dp + module function mean_mask_3_iint8_dp(x, dim, mask) result(res) + integer(int8), intent(in) :: x(:,:,:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then + if (dim >= 1 .and. dim <= 3) then res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_mask_11_iint8_dp - module function mean_mask_12_iint8_dp(x, dim, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + end function mean_mask_3_iint8_dp + module function mean_mask_4_iint8_dp(x, dim, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:) real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then + if (dim >= 1 .and. dim <= 4) then res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_mask_12_iint8_dp - module function mean_mask_13_iint8_dp(x, dim, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + end function mean_mask_4_iint8_dp + module function mean_mask_5_iint8_dp(x, dim, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:) real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then + if (dim >= 1 .and. dim <= 5) then res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_mask_13_iint8_dp - module function mean_mask_14_iint8_dp(x, dim, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function mean_mask_5_iint8_dp + module function mean_mask_6_iint8_dp(x, dim, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:) real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + if (dim >= 1 .and. dim <= 6) then res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_mask_14_iint8_dp - module function mean_mask_15_iint8_dp(x, dim, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function mean_mask_6_iint8_dp + module function mean_mask_7_iint8_dp(x, dim, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:) real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + if (dim >= 1 .and. dim <= 7) then res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) else call error_stop("ERROR (mean): wrong dimension") end if - end function mean_mask_15_iint8_dp + end function mean_mask_7_iint8_dp module function mean_mask_1_iint16_dp(x, dim, mask) result(res) integer(int16), intent(in) :: x(:) integer, intent(in) :: dim @@ -7907,139 +3566,6 @@ module function mean_mask_7_iint16_dp(x, dim, mask) result(res) end if end function mean_mask_7_iint16_dp - module function mean_mask_8_iint16_dp(x, dim, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then - res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_8_iint16_dp - module function mean_mask_9_iint16_dp(x, dim, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then - res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_9_iint16_dp - module function mean_mask_10_iint16_dp(x, dim, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then - res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_10_iint16_dp - module function mean_mask_11_iint16_dp(x, dim, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then - res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_11_iint16_dp - module function mean_mask_12_iint16_dp(x, dim, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then - res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_12_iint16_dp - module function mean_mask_13_iint16_dp(x, dim, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then - res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_13_iint16_dp - module function mean_mask_14_iint16_dp(x, dim, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then - res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_14_iint16_dp - module function mean_mask_15_iint16_dp(x, dim, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then - res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_15_iint16_dp module function mean_mask_1_iint32_dp(x, dim, mask) result(res) integer(int32), intent(in) :: x(:) integer, intent(in) :: dim @@ -8136,139 +3662,6 @@ module function mean_mask_7_iint32_dp(x, dim, mask) result(res) end if end function mean_mask_7_iint32_dp - module function mean_mask_8_iint32_dp(x, dim, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then - res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_8_iint32_dp - module function mean_mask_9_iint32_dp(x, dim, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then - res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_9_iint32_dp - module function mean_mask_10_iint32_dp(x, dim, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then - res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_10_iint32_dp - module function mean_mask_11_iint32_dp(x, dim, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then - res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_11_iint32_dp - module function mean_mask_12_iint32_dp(x, dim, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then - res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_12_iint32_dp - module function mean_mask_13_iint32_dp(x, dim, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then - res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_13_iint32_dp - module function mean_mask_14_iint32_dp(x, dim, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then - res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_14_iint32_dp - module function mean_mask_15_iint32_dp(x, dim, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then - res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_15_iint32_dp module function mean_mask_1_iint64_dp(x, dim, mask) result(res) integer(int64), intent(in) :: x(:) integer, intent(in) :: dim @@ -8365,138 +3758,5 @@ module function mean_mask_7_iint64_dp(x, dim, mask) result(res) end if end function mean_mask_7_iint64_dp - module function mean_mask_8_iint64_dp(x, dim, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then - res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_8_iint64_dp - module function mean_mask_9_iint64_dp(x, dim, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then - res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_9_iint64_dp - module function mean_mask_10_iint64_dp(x, dim, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then - res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_10_iint64_dp - module function mean_mask_11_iint64_dp(x, dim, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then - res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_11_iint64_dp - module function mean_mask_12_iint64_dp(x, dim, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then - res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_12_iint64_dp - module function mean_mask_13_iint64_dp(x, dim, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then - res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_13_iint64_dp - module function mean_mask_14_iint64_dp(x, dim, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then - res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_14_iint64_dp - module function mean_mask_15_iint64_dp(x, dim, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then - res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp) - else - call error_stop("ERROR (mean): wrong dimension") - end if - - end function mean_mask_15_iint64_dp end submodule diff --git a/src/fpm/stdlib_stats_moment.f90 b/src/fpm/stdlib_stats_moment.f90 index 419855c8f..c023eed52 100644 --- a/src/fpm/stdlib_stats_moment.f90 +++ b/src/fpm/stdlib_stats_moment.f90 @@ -544,124 +544,151 @@ module function moment_7_rsp_rsp(x, order, dim, center, mask) result(res) res = res / n end function moment_7_rsp_rsp - module function moment_8_rsp_rsp(x, order, dim, center, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:) + module function moment_1_rdp_rdp(x, order, dim, center, mask) result(res) + real(dp), intent(in) :: x(:) integer, intent(in) :: order integer, intent(in) :: dim - real(sp), intent(in), optional :: center(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then + if (dim >= 1 .and. dim <= 2) then res = sum((x - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_8_rsp_rsp - module function moment_scalar_9_rsp_rsp(x, order, dim, center, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + end function moment_scalar_2_rdp_rdp + module function moment_scalar_3_rdp_rdp(x, order, dim, center, mask) result(res) + real(dp), intent(in) :: x(:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(sp), intent(in) :: center + real(dp), intent(in) :: center logical, intent(in), optional :: mask - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then + if (dim >= 1 .and. dim <= 3) then res = sum((x - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_9_rsp_rsp - module function moment_scalar_10_rsp_rsp(x, order, dim, center, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + end function moment_scalar_3_rdp_rdp + module function moment_scalar_4_rdp_rdp(x, order, dim, center, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(sp), intent(in) :: center + real(dp), intent(in) :: center logical, intent(in), optional :: mask - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then + if (dim >= 1 .and. dim <= 4) then res = sum((x - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_10_rsp_rsp - module function moment_scalar_11_rsp_rsp(x, order, dim, center, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + end function moment_scalar_4_rdp_rdp + module function moment_scalar_5_rdp_rdp(x, order, dim, center, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(sp), intent(in) :: center + real(dp), intent(in) :: center logical, intent(in), optional :: mask - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then + if (dim >= 1 .and. dim <= 5) then res = sum((x - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_11_rsp_rsp - module function moment_scalar_12_rsp_rsp(x, order, dim, center, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + end function moment_scalar_5_rdp_rdp + module function moment_scalar_6_rdp_rdp(x, order, dim, center, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(sp), intent(in) :: center + real(dp), intent(in) :: center logical, intent(in), optional :: mask - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then + if (dim >= 1 .and. dim <= 6) then res = sum((x - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_12_rsp_rsp - module function moment_scalar_13_rsp_rsp(x, order, dim, center, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + end function moment_scalar_6_rdp_rdp + module function moment_scalar_7_rdp_rdp(x, order, dim, center, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(sp), intent(in) :: center + real(dp), intent(in) :: center logical, intent(in), optional :: mask - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then + if (dim >= 1 .and. dim <= 7) then res = sum((x - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_13_rsp_rsp - module function moment_scalar_14_rsp_rsp(x, order, dim, center, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function moment_scalar_7_rdp_rdp + module function moment_scalar_2_rqp_rqp(x, order, dim, center, mask) result(res) + real(qp), intent(in) :: x(:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(sp), intent(in) :: center + real(qp), intent(in) :: center logical, intent(in), optional :: mask - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + if (dim >= 1 .and. dim <= 2) then res = sum((x - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_14_rsp_rsp - module function moment_scalar_15_rsp_rsp(x, order, dim, center, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function moment_scalar_2_rqp_rqp + module function moment_scalar_3_rqp_rqp(x, order, dim, center, mask) result(res) + real(qp), intent(in) :: x(:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(sp), intent(in) :: center + real(qp), intent(in) :: center logical, intent(in), optional :: mask - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + if (dim >= 1 .and. dim <= 3) then res = sum((x - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_15_rsp_rsp - module function moment_scalar_2_rdp_rdp(x, order, dim, center, mask) result(res) - real(dp), intent(in) :: x(:,:) + end function moment_scalar_3_rqp_rqp + module function moment_scalar_4_rqp_rqp(x, order, dim, center, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(dp), intent(in) :: center + real(qp), intent(in) :: center logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then + if (dim >= 1 .and. dim <= 4) then res = sum((x - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_2_rdp_rdp - module function moment_scalar_3_rdp_rdp(x, order, dim, center, mask) result(res) - real(dp), intent(in) :: x(:,:,:) + end function moment_scalar_4_rqp_rqp + module function moment_scalar_5_rqp_rqp(x, order, dim, center, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(dp), intent(in) :: center + real(qp), intent(in) :: center logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then + if (dim >= 1 .and. dim <= 5) then res = sum((x - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_3_rdp_rdp - module function moment_scalar_4_rdp_rdp(x, order, dim, center, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:) + end function moment_scalar_5_rqp_rqp + module function moment_scalar_6_rqp_rqp(x, order, dim, center, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(dp), intent(in) :: center + real(qp), intent(in) :: center logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then + if (dim >= 1 .and. dim <= 6) then res = sum((x - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_4_rdp_rdp - module function moment_scalar_5_rdp_rdp(x, order, dim, center, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:) + end function moment_scalar_6_rqp_rqp + module function moment_scalar_7_rqp_rqp(x, order, dim, center, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(dp), intent(in) :: center + real(qp), intent(in) :: center logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then + if (dim >= 1 .and. dim <= 7) then res = sum((x - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_5_rdp_rdp - module function moment_scalar_6_rdp_rdp(x, order, dim, center, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:) + end function moment_scalar_7_rqp_rqp + module function moment_scalar_2_csp_csp(x, order, dim, center, mask) result(res) + complex(sp), intent(in) :: x(:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(dp), intent(in) :: center + complex(sp), intent(in) :: center logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then + if (dim >= 1 .and. dim <= 2) then res = sum((x - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_6_rdp_rdp - module function moment_scalar_7_rdp_rdp(x, order, dim, center, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:) + end function moment_scalar_2_csp_csp + module function moment_scalar_3_csp_csp(x, order, dim, center, mask) result(res) + complex(sp), intent(in) :: x(:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(dp), intent(in) :: center + complex(sp), intent(in) :: center logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then + if (dim >= 1 .and. dim <= 3) then res = sum((x - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_7_rdp_rdp - module function moment_scalar_8_rdp_rdp(x, order, dim, center, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:) + end function moment_scalar_3_csp_csp + module function moment_scalar_4_csp_csp(x, order, dim, center, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(dp), intent(in) :: center + complex(sp), intent(in) :: center logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then + if (dim >= 1 .and. dim <= 4) then res = sum((x - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_8_rdp_rdp - module function moment_scalar_9_rdp_rdp(x, order, dim, center, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + end function moment_scalar_4_csp_csp + module function moment_scalar_5_csp_csp(x, order, dim, center, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(dp), intent(in) :: center + complex(sp), intent(in) :: center logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then + if (dim >= 1 .and. dim <= 5) then res = sum((x - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_9_rdp_rdp - module function moment_scalar_10_rdp_rdp(x, order, dim, center, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + end function moment_scalar_5_csp_csp + module function moment_scalar_6_csp_csp(x, order, dim, center, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(dp), intent(in) :: center + complex(sp), intent(in) :: center logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then + if (dim >= 1 .and. dim <= 6) then res = sum((x - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_10_rdp_rdp - module function moment_scalar_11_rdp_rdp(x, order, dim, center, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + end function moment_scalar_6_csp_csp + module function moment_scalar_7_csp_csp(x, order, dim, center, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(dp), intent(in) :: center + complex(sp), intent(in) :: center logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then + if (dim >= 1 .and. dim <= 7) then res = sum((x - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_11_rdp_rdp - module function moment_scalar_12_rdp_rdp(x, order, dim, center, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + end function moment_scalar_7_csp_csp + module function moment_scalar_2_cdp_cdp(x, order, dim, center, mask) result(res) + complex(dp), intent(in) :: x(:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(dp), intent(in) :: center + complex(dp), intent(in) :: center logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then + if (dim >= 1 .and. dim <= 2) then res = sum((x - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_12_rdp_rdp - module function moment_scalar_13_rdp_rdp(x, order, dim, center, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + end function moment_scalar_2_cdp_cdp + module function moment_scalar_3_cdp_cdp(x, order, dim, center, mask) result(res) + complex(dp), intent(in) :: x(:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(dp), intent(in) :: center + complex(dp), intent(in) :: center logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then + if (dim >= 1 .and. dim <= 3) then res = sum((x - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_13_rdp_rdp - module function moment_scalar_14_rdp_rdp(x, order, dim, center, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function moment_scalar_3_cdp_cdp + module function moment_scalar_4_cdp_cdp(x, order, dim, center, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(dp), intent(in) :: center + complex(dp), intent(in) :: center logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + if (dim >= 1 .and. dim <= 4) then res = sum((x - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_14_rdp_rdp - module function moment_scalar_15_rdp_rdp(x, order, dim, center, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function moment_scalar_4_cdp_cdp + module function moment_scalar_5_cdp_cdp(x, order, dim, center, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(dp), intent(in) :: center + complex(dp), intent(in) :: center logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + if (dim >= 1 .and. dim <= 5) then res = sum((x - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_15_rdp_rdp - module function moment_scalar_2_rqp_rqp(x, order, dim, center, mask) result(res) - real(qp), intent(in) :: x(:,:) + end function moment_scalar_5_cdp_cdp + module function moment_scalar_6_cdp_cdp(x, order, dim, center, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(qp), intent(in) :: center + complex(dp), intent(in) :: center logical, intent(in), optional :: mask - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then + if (dim >= 1 .and. dim <= 6) then res = sum((x - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_2_rqp_rqp - module function moment_scalar_3_rqp_rqp(x, order, dim, center, mask) result(res) - real(qp), intent(in) :: x(:,:,:) + end function moment_scalar_6_cdp_cdp + module function moment_scalar_7_cdp_cdp(x, order, dim, center, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(qp), intent(in) :: center + complex(dp), intent(in) :: center logical, intent(in), optional :: mask - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then + if (dim >= 1 .and. dim <= 7) then res = sum((x - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_3_rqp_rqp - module function moment_scalar_4_rqp_rqp(x, order, dim, center, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:) + end function moment_scalar_7_cdp_cdp + module function moment_scalar_2_cqp_cqp(x, order, dim, center, mask) result(res) + complex(qp), intent(in) :: x(:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(qp), intent(in) :: center + complex(qp), intent(in) :: center logical, intent(in), optional :: mask - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then + if (dim >= 1 .and. dim <= 2) then res = sum((x - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_4_rqp_rqp - module function moment_scalar_5_rqp_rqp(x, order, dim, center, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:) + end function moment_scalar_2_cqp_cqp + module function moment_scalar_3_cqp_cqp(x, order, dim, center, mask) result(res) + complex(qp), intent(in) :: x(:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(qp), intent(in) :: center + complex(qp), intent(in) :: center logical, intent(in), optional :: mask - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then + if (dim >= 1 .and. dim <= 3) then res = sum((x - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_5_rqp_rqp - module function moment_scalar_6_rqp_rqp(x, order, dim, center, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:) + end function moment_scalar_3_cqp_cqp + module function moment_scalar_4_cqp_cqp(x, order, dim, center, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(qp), intent(in) :: center + complex(qp), intent(in) :: center logical, intent(in), optional :: mask - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then + if (dim >= 1 .and. dim <= 4) then res = sum((x - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_6_rqp_rqp - module function moment_scalar_7_rqp_rqp(x, order, dim, center, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:) + end function moment_scalar_4_cqp_cqp + module function moment_scalar_5_cqp_cqp(x, order, dim, center, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(qp), intent(in) :: center + complex(qp), intent(in) :: center logical, intent(in), optional :: mask - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then + if (dim >= 1 .and. dim <= 5) then res = sum((x - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_7_rqp_rqp - module function moment_scalar_8_rqp_rqp(x, order, dim, center, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:) + end function moment_scalar_5_cqp_cqp + module function moment_scalar_6_cqp_cqp(x, order, dim, center, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(qp), intent(in) :: center + complex(qp), intent(in) :: center logical, intent(in), optional :: mask - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then + if (dim >= 1 .and. dim <= 6) then res = sum((x - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_8_rqp_rqp - module function moment_scalar_9_rqp_rqp(x, order, dim, center, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + end function moment_scalar_6_cqp_cqp + module function moment_scalar_7_cqp_cqp(x, order, dim, center, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(qp), intent(in) :: center + complex(qp), intent(in) :: center logical, intent(in), optional :: mask - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then + if (dim >= 1 .and. dim <= 7) then res = sum((x - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_9_rqp_rqp - module function moment_scalar_10_rqp_rqp(x, order, dim, center, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + end function moment_scalar_7_cqp_cqp + + module function moment_scalar_2_iint8_dp(x, order, dim, center, mask) result(res) + integer(int8), intent(in) :: x(:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(qp), intent(in) :: center + real(dp),intent(in) :: center logical, intent(in), optional :: mask - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then - res = sum((x - center)**order, dim) / size(x, dim) + if (dim >= 1 .and. dim <= 2) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_10_rqp_rqp - module function moment_scalar_11_rqp_rqp(x, order, dim, center, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + end function moment_scalar_2_iint8_dp + module function moment_scalar_3_iint8_dp(x, order, dim, center, mask) result(res) + integer(int8), intent(in) :: x(:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(qp), intent(in) :: center + real(dp),intent(in) :: center logical, intent(in), optional :: mask - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then - res = sum((x - center)**order, dim) / size(x, dim) + if (dim >= 1 .and. dim <= 3) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_11_rqp_rqp - module function moment_scalar_12_rqp_rqp(x, order, dim, center, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + end function moment_scalar_3_iint8_dp + module function moment_scalar_4_iint8_dp(x, order, dim, center, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(qp), intent(in) :: center + real(dp),intent(in) :: center logical, intent(in), optional :: mask - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then - res = sum((x - center)**order, dim) / size(x, dim) + if (dim >= 1 .and. dim <= 4) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_12_rqp_rqp - module function moment_scalar_13_rqp_rqp(x, order, dim, center, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + end function moment_scalar_4_iint8_dp + module function moment_scalar_5_iint8_dp(x, order, dim, center, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(qp), intent(in) :: center + real(dp),intent(in) :: center logical, intent(in), optional :: mask - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then - res = sum((x - center)**order, dim) / size(x, dim) + if (dim >= 1 .and. dim <= 5) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_13_rqp_rqp - module function moment_scalar_14_rqp_rqp(x, order, dim, center, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function moment_scalar_5_iint8_dp + module function moment_scalar_6_iint8_dp(x, order, dim, center, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(qp), intent(in) :: center + real(dp),intent(in) :: center logical, intent(in), optional :: mask - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then - res = sum((x - center)**order, dim) / size(x, dim) + if (dim >= 1 .and. dim <= 6) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_14_rqp_rqp - module function moment_scalar_15_rqp_rqp(x, order, dim, center, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function moment_scalar_6_iint8_dp + module function moment_scalar_7_iint8_dp(x, order, dim, center, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(qp), intent(in) :: center + real(dp),intent(in) :: center logical, intent(in), optional :: mask - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then - res = sum((x - center)**order, dim) / size(x, dim) + if (dim >= 1 .and. dim <= 7) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_15_rqp_rqp - module function moment_scalar_2_csp_csp(x, order, dim, center, mask) result(res) - complex(sp), intent(in) :: x(:,:) + end function moment_scalar_7_iint8_dp + module function moment_scalar_2_iint16_dp(x, order, dim, center, mask) result(res) + integer(int16), intent(in) :: x(:,:) integer, intent(in) :: order integer, intent(in) :: dim - complex(sp), intent(in) :: center + real(dp),intent(in) :: center logical, intent(in), optional :: mask - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then - res = sum((x - center)**order, dim) / size(x, dim) + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_2_csp_csp - module function moment_scalar_3_csp_csp(x, order, dim, center, mask) result(res) - complex(sp), intent(in) :: x(:,:,:) + end function moment_scalar_2_iint16_dp + module function moment_scalar_3_iint16_dp(x, order, dim, center, mask) result(res) + integer(int16), intent(in) :: x(:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - complex(sp), intent(in) :: center + real(dp),intent(in) :: center logical, intent(in), optional :: mask - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then - res = sum((x - center)**order, dim) / size(x, dim) + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_3_csp_csp - module function moment_scalar_4_csp_csp(x, order, dim, center, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:) + end function moment_scalar_3_iint16_dp + module function moment_scalar_4_iint16_dp(x, order, dim, center, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - complex(sp), intent(in) :: center + real(dp),intent(in) :: center logical, intent(in), optional :: mask - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then - res = sum((x - center)**order, dim) / size(x, dim) + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_4_csp_csp - module function moment_scalar_5_csp_csp(x, order, dim, center, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:) + end function moment_scalar_4_iint16_dp + module function moment_scalar_5_iint16_dp(x, order, dim, center, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - complex(sp), intent(in) :: center + real(dp),intent(in) :: center logical, intent(in), optional :: mask - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then - res = sum((x - center)**order, dim) / size(x, dim) + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_5_csp_csp - module function moment_scalar_6_csp_csp(x, order, dim, center, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:) + end function moment_scalar_5_iint16_dp + module function moment_scalar_6_iint16_dp(x, order, dim, center, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - complex(sp), intent(in) :: center + real(dp),intent(in) :: center logical, intent(in), optional :: mask - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then - res = sum((x - center)**order, dim) / size(x, dim) + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_6_csp_csp - module function moment_scalar_7_csp_csp(x, order, dim, center, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:) + end function moment_scalar_6_iint16_dp + module function moment_scalar_7_iint16_dp(x, order, dim, center, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - complex(sp), intent(in) :: center + real(dp),intent(in) :: center logical, intent(in), optional :: mask - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then - res = sum((x - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_7_csp_csp - module function moment_scalar_8_csp_csp(x, order, dim, center, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(sp), intent(in) :: center - logical, intent(in), optional :: mask - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then - res = sum((x - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_8_csp_csp - module function moment_scalar_9_csp_csp(x, order, dim, center, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(sp), intent(in) :: center - logical, intent(in), optional :: mask - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then - res = sum((x - center)**order, dim) / size(x, dim) + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_9_csp_csp - module function moment_scalar_10_csp_csp(x, order, dim, center, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + end function moment_scalar_7_iint16_dp + module function moment_scalar_2_iint32_dp(x, order, dim, center, mask) result(res) + integer(int32), intent(in) :: x(:,:) integer, intent(in) :: order integer, intent(in) :: dim - complex(sp), intent(in) :: center + real(dp),intent(in) :: center logical, intent(in), optional :: mask - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then - res = sum((x - center)**order, dim) / size(x, dim) + if (dim >= 1 .and. dim <= 2) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_10_csp_csp - module function moment_scalar_11_csp_csp(x, order, dim, center, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + end function moment_scalar_2_iint32_dp + module function moment_scalar_3_iint32_dp(x, order, dim, center, mask) result(res) + integer(int32), intent(in) :: x(:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - complex(sp), intent(in) :: center + real(dp),intent(in) :: center logical, intent(in), optional :: mask - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then - res = sum((x - center)**order, dim) / size(x, dim) + if (dim >= 1 .and. dim <= 3) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_11_csp_csp - module function moment_scalar_12_csp_csp(x, order, dim, center, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + end function moment_scalar_3_iint32_dp + module function moment_scalar_4_iint32_dp(x, order, dim, center, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - complex(sp), intent(in) :: center + real(dp),intent(in) :: center logical, intent(in), optional :: mask - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then - res = sum((x - center)**order, dim) / size(x, dim) + if (dim >= 1 .and. dim <= 4) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_12_csp_csp - module function moment_scalar_13_csp_csp(x, order, dim, center, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + end function moment_scalar_4_iint32_dp + module function moment_scalar_5_iint32_dp(x, order, dim, center, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - complex(sp), intent(in) :: center + real(dp),intent(in) :: center logical, intent(in), optional :: mask - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then - res = sum((x - center)**order, dim) / size(x, dim) + if (dim >= 1 .and. dim <= 5) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_13_csp_csp - module function moment_scalar_14_csp_csp(x, order, dim, center, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function moment_scalar_5_iint32_dp + module function moment_scalar_6_iint32_dp(x, order, dim, center, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - complex(sp), intent(in) :: center + real(dp),intent(in) :: center logical, intent(in), optional :: mask - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then - res = sum((x - center)**order, dim) / size(x, dim) + if (dim >= 1 .and. dim <= 6) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_14_csp_csp - module function moment_scalar_15_csp_csp(x, order, dim, center, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function moment_scalar_6_iint32_dp + module function moment_scalar_7_iint32_dp(x, order, dim, center, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - complex(sp), intent(in) :: center + real(dp),intent(in) :: center logical, intent(in), optional :: mask - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then - res = sum((x - center)**order, dim) / size(x, dim) + if (dim >= 1 .and. dim <= 7) then + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_15_csp_csp - module function moment_scalar_2_cdp_cdp(x, order, dim, center, mask) result(res) - complex(dp), intent(in) :: x(:,:) + end function moment_scalar_7_iint32_dp + module function moment_scalar_2_iint64_dp(x, order, dim, center, mask) result(res) + integer(int64), intent(in) :: x(:,:) integer, intent(in) :: order integer, intent(in) :: dim - complex(dp), intent(in) :: center + real(dp),intent(in) :: center logical, intent(in), optional :: mask - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then - res = sum((x - center)**order, dim) / size(x, dim) + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_2_cdp_cdp - module function moment_scalar_3_cdp_cdp(x, order, dim, center, mask) result(res) - complex(dp), intent(in) :: x(:,:,:) + end function moment_scalar_2_iint64_dp + module function moment_scalar_3_iint64_dp(x, order, dim, center, mask) result(res) + integer(int64), intent(in) :: x(:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - complex(dp), intent(in) :: center + real(dp),intent(in) :: center logical, intent(in), optional :: mask - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then - res = sum((x - center)**order, dim) / size(x, dim) + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_3_cdp_cdp - module function moment_scalar_4_cdp_cdp(x, order, dim, center, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:) + end function moment_scalar_3_iint64_dp + module function moment_scalar_4_iint64_dp(x, order, dim, center, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - complex(dp), intent(in) :: center + real(dp),intent(in) :: center logical, intent(in), optional :: mask - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then - res = sum((x - center)**order, dim) / size(x, dim) + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_4_cdp_cdp - module function moment_scalar_5_cdp_cdp(x, order, dim, center, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:) + end function moment_scalar_4_iint64_dp + module function moment_scalar_5_iint64_dp(x, order, dim, center, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - complex(dp), intent(in) :: center + real(dp),intent(in) :: center logical, intent(in), optional :: mask - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then - res = sum((x - center)**order, dim) / size(x, dim) + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_5_cdp_cdp - module function moment_scalar_6_cdp_cdp(x, order, dim, center, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:) + end function moment_scalar_5_iint64_dp + module function moment_scalar_6_iint64_dp(x, order, dim, center, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - complex(dp), intent(in) :: center + real(dp),intent(in) :: center logical, intent(in), optional :: mask - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then - res = sum((x - center)**order, dim) / size(x, dim) + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_6_cdp_cdp - module function moment_scalar_7_cdp_cdp(x, order, dim, center, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:) + end function moment_scalar_6_iint64_dp + module function moment_scalar_7_iint64_dp(x, order, dim, center, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - complex(dp), intent(in) :: center + real(dp),intent(in) :: center logical, intent(in), optional :: mask - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then - res = sum((x - center)**order, dim) / size(x, dim) + res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_7_cdp_cdp - module function moment_scalar_8_cdp_cdp(x, order, dim, center, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:) + end function moment_scalar_7_iint64_dp + + + module function moment_mask_scalar_2_rsp_rsp(x, order, dim, center, mask) result(res) + real(sp), intent(in) :: x(:,:) integer, intent(in) :: order integer, intent(in) :: dim - complex(dp), intent(in) :: center - logical, intent(in), optional :: mask - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then - res = sum((x - center)**order, dim) / size(x, dim) + if (dim >= 1 .and. dim <= 2) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_8_cdp_cdp - module function moment_scalar_9_cdp_cdp(x, order, dim, center, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + end function moment_mask_scalar_2_rsp_rsp + module function moment_mask_scalar_3_rsp_rsp(x, order, dim, center, mask) result(res) + real(sp), intent(in) :: x(:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - complex(dp), intent(in) :: center - logical, intent(in), optional :: mask - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then - res = sum((x - center)**order, dim) / size(x, dim) + if (dim >= 1 .and. dim <= 3) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_scalar_9_cdp_cdp - module function moment_scalar_10_cdp_cdp(x, order, dim, center, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + end function moment_mask_scalar_3_rsp_rsp + module function moment_mask_scalar_4_rsp_rsp(x, order, dim, center, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - complex(dp), intent(in) :: center - logical, intent(in), optional :: mask - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then - res = sum((x - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_10_cdp_cdp - module function moment_scalar_11_cdp_cdp(x, order, dim, center, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(dp), intent(in) :: center - logical, intent(in), optional :: mask - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then - res = sum((x - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_11_cdp_cdp - module function moment_scalar_12_cdp_cdp(x, order, dim, center, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(dp), intent(in) :: center - logical, intent(in), optional :: mask - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then - res = sum((x - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_12_cdp_cdp - module function moment_scalar_13_cdp_cdp(x, order, dim, center, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(dp), intent(in) :: center - logical, intent(in), optional :: mask - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then - res = sum((x - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_13_cdp_cdp - module function moment_scalar_14_cdp_cdp(x, order, dim, center, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(dp), intent(in) :: center - logical, intent(in), optional :: mask - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then - res = sum((x - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_14_cdp_cdp - module function moment_scalar_15_cdp_cdp(x, order, dim, center, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(dp), intent(in) :: center - logical, intent(in), optional :: mask - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then - res = sum((x - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_15_cdp_cdp - module function moment_scalar_2_cqp_cqp(x, order, dim, center, mask) result(res) - complex(qp), intent(in) :: x(:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(qp), intent(in) :: center - logical, intent(in), optional :: mask - complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then - res = sum((x - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_2_cqp_cqp - module function moment_scalar_3_cqp_cqp(x, order, dim, center, mask) result(res) - complex(qp), intent(in) :: x(:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(qp), intent(in) :: center - logical, intent(in), optional :: mask - complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then - res = sum((x - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_3_cqp_cqp - module function moment_scalar_4_cqp_cqp(x, order, dim, center, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(qp), intent(in) :: center - logical, intent(in), optional :: mask - complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then - res = sum((x - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_4_cqp_cqp - module function moment_scalar_5_cqp_cqp(x, order, dim, center, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(qp), intent(in) :: center - logical, intent(in), optional :: mask - complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then - res = sum((x - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_5_cqp_cqp - module function moment_scalar_6_cqp_cqp(x, order, dim, center, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(qp), intent(in) :: center - logical, intent(in), optional :: mask - complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then - res = sum((x - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_6_cqp_cqp - module function moment_scalar_7_cqp_cqp(x, order, dim, center, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(qp), intent(in) :: center - logical, intent(in), optional :: mask - complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then - res = sum((x - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_7_cqp_cqp - module function moment_scalar_8_cqp_cqp(x, order, dim, center, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(qp), intent(in) :: center - logical, intent(in), optional :: mask - complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then - res = sum((x - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_8_cqp_cqp - module function moment_scalar_9_cqp_cqp(x, order, dim, center, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(qp), intent(in) :: center - logical, intent(in), optional :: mask - complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then - res = sum((x - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_9_cqp_cqp - module function moment_scalar_10_cqp_cqp(x, order, dim, center, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(qp), intent(in) :: center - logical, intent(in), optional :: mask - complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then - res = sum((x - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_10_cqp_cqp - module function moment_scalar_11_cqp_cqp(x, order, dim, center, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(qp), intent(in) :: center - logical, intent(in), optional :: mask - complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then - res = sum((x - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_11_cqp_cqp - module function moment_scalar_12_cqp_cqp(x, order, dim, center, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(qp), intent(in) :: center - logical, intent(in), optional :: mask - complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then - res = sum((x - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_12_cqp_cqp - module function moment_scalar_13_cqp_cqp(x, order, dim, center, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(qp), intent(in) :: center - logical, intent(in), optional :: mask - complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then - res = sum((x - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_13_cqp_cqp - module function moment_scalar_14_cqp_cqp(x, order, dim, center, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(qp), intent(in) :: center - logical, intent(in), optional :: mask - complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then - res = sum((x - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_14_cqp_cqp - module function moment_scalar_15_cqp_cqp(x, order, dim, center, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(qp), intent(in) :: center - logical, intent(in), optional :: mask - complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then - res = sum((x - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_15_cqp_cqp - - module function moment_scalar_2_iint8_dp(x, order, dim, center, mask) result(res) - integer(int8), intent(in) :: x(:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_2_iint8_dp - module function moment_scalar_3_iint8_dp(x, order, dim, center, mask) result(res) - integer(int8), intent(in) :: x(:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_3_iint8_dp - module function moment_scalar_4_iint8_dp(x, order, dim, center, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_4_iint8_dp - module function moment_scalar_5_iint8_dp(x, order, dim, center, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_5_iint8_dp - module function moment_scalar_6_iint8_dp(x, order, dim, center, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_6_iint8_dp - module function moment_scalar_7_iint8_dp(x, order, dim, center, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_7_iint8_dp - module function moment_scalar_8_iint8_dp(x, order, dim, center, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_8_iint8_dp - module function moment_scalar_9_iint8_dp(x, order, dim, center, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_9_iint8_dp - module function moment_scalar_10_iint8_dp(x, order, dim, center, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_10_iint8_dp - module function moment_scalar_11_iint8_dp(x, order, dim, center, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_11_iint8_dp - module function moment_scalar_12_iint8_dp(x, order, dim, center, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_12_iint8_dp - module function moment_scalar_13_iint8_dp(x, order, dim, center, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_13_iint8_dp - module function moment_scalar_14_iint8_dp(x, order, dim, center, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_14_iint8_dp - module function moment_scalar_15_iint8_dp(x, order, dim, center, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_15_iint8_dp - module function moment_scalar_2_iint16_dp(x, order, dim, center, mask) result(res) - integer(int16), intent(in) :: x(:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_2_iint16_dp - module function moment_scalar_3_iint16_dp(x, order, dim, center, mask) result(res) - integer(int16), intent(in) :: x(:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_3_iint16_dp - module function moment_scalar_4_iint16_dp(x, order, dim, center, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_4_iint16_dp - module function moment_scalar_5_iint16_dp(x, order, dim, center, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_5_iint16_dp - module function moment_scalar_6_iint16_dp(x, order, dim, center, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_6_iint16_dp - module function moment_scalar_7_iint16_dp(x, order, dim, center, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_7_iint16_dp - module function moment_scalar_8_iint16_dp(x, order, dim, center, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_8_iint16_dp - module function moment_scalar_9_iint16_dp(x, order, dim, center, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_9_iint16_dp - module function moment_scalar_10_iint16_dp(x, order, dim, center, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_10_iint16_dp - module function moment_scalar_11_iint16_dp(x, order, dim, center, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_11_iint16_dp - module function moment_scalar_12_iint16_dp(x, order, dim, center, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_12_iint16_dp - module function moment_scalar_13_iint16_dp(x, order, dim, center, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_13_iint16_dp - module function moment_scalar_14_iint16_dp(x, order, dim, center, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_14_iint16_dp - module function moment_scalar_15_iint16_dp(x, order, dim, center, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_15_iint16_dp - module function moment_scalar_2_iint32_dp(x, order, dim, center, mask) result(res) - integer(int32), intent(in) :: x(:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_2_iint32_dp - module function moment_scalar_3_iint32_dp(x, order, dim, center, mask) result(res) - integer(int32), intent(in) :: x(:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_3_iint32_dp - module function moment_scalar_4_iint32_dp(x, order, dim, center, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_4_iint32_dp - module function moment_scalar_5_iint32_dp(x, order, dim, center, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_5_iint32_dp - module function moment_scalar_6_iint32_dp(x, order, dim, center, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_6_iint32_dp - module function moment_scalar_7_iint32_dp(x, order, dim, center, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_7_iint32_dp - module function moment_scalar_8_iint32_dp(x, order, dim, center, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_8_iint32_dp - module function moment_scalar_9_iint32_dp(x, order, dim, center, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_9_iint32_dp - module function moment_scalar_10_iint32_dp(x, order, dim, center, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_10_iint32_dp - module function moment_scalar_11_iint32_dp(x, order, dim, center, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_11_iint32_dp - module function moment_scalar_12_iint32_dp(x, order, dim, center, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_12_iint32_dp - module function moment_scalar_13_iint32_dp(x, order, dim, center, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_13_iint32_dp - module function moment_scalar_14_iint32_dp(x, order, dim, center, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_14_iint32_dp - module function moment_scalar_15_iint32_dp(x, order, dim, center, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_15_iint32_dp - module function moment_scalar_2_iint64_dp(x, order, dim, center, mask) result(res) - integer(int64), intent(in) :: x(:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_2_iint64_dp - module function moment_scalar_3_iint64_dp(x, order, dim, center, mask) result(res) - integer(int64), intent(in) :: x(:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_3_iint64_dp - module function moment_scalar_4_iint64_dp(x, order, dim, center, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_4_iint64_dp - module function moment_scalar_5_iint64_dp(x, order, dim, center, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_5_iint64_dp - module function moment_scalar_6_iint64_dp(x, order, dim, center, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_6_iint64_dp - module function moment_scalar_7_iint64_dp(x, order, dim, center, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_7_iint64_dp - module function moment_scalar_8_iint64_dp(x, order, dim, center, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_8_iint64_dp - module function moment_scalar_9_iint64_dp(x, order, dim, center, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_9_iint64_dp - module function moment_scalar_10_iint64_dp(x, order, dim, center, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_10_iint64_dp - module function moment_scalar_11_iint64_dp(x, order, dim, center, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_11_iint64_dp - module function moment_scalar_12_iint64_dp(x, order, dim, center, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_12_iint64_dp - module function moment_scalar_13_iint64_dp(x, order, dim, center, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_13_iint64_dp - module function moment_scalar_14_iint64_dp(x, order, dim, center, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_14_iint64_dp - module function moment_scalar_15_iint64_dp(x, order, dim, center, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp),intent(in) :: center - logical, intent(in), optional :: mask - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then - res = sum( (real(x, dp) - center)**order, dim) / size(x, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_scalar_15_iint64_dp - - - module function moment_mask_scalar_2_rsp_rsp(x, order, dim, center, mask) result(res) - real(sp), intent(in) :: x(:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(sp), intent(in) :: center - logical, intent(in) :: mask(:,:) - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_2_rsp_rsp - module function moment_mask_scalar_3_rsp_rsp(x, order, dim, center, mask) result(res) - real(sp), intent(in) :: x(:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(sp), intent(in) :: center - logical, intent(in) :: mask(:,:,:) - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_3_rsp_rsp - module function moment_mask_scalar_4_rsp_rsp(x, order, dim, center, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(sp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:) - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_4_rsp_rsp - module function moment_mask_scalar_5_rsp_rsp(x, order, dim, center, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(sp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:) - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_5_rsp_rsp - module function moment_mask_scalar_6_rsp_rsp(x, order, dim, center, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(sp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:) - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_6_rsp_rsp - module function moment_mask_scalar_7_rsp_rsp(x, order, dim, center, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(sp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:) - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_7_rsp_rsp - module function moment_mask_scalar_8_rsp_rsp(x, order, dim, center, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(sp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:) - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_8_rsp_rsp - module function moment_mask_scalar_9_rsp_rsp(x, order, dim, center, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(sp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_9_rsp_rsp - module function moment_mask_scalar_10_rsp_rsp(x, order, dim, center, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(sp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_10_rsp_rsp - module function moment_mask_scalar_11_rsp_rsp(x, order, dim, center, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(sp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_11_rsp_rsp - module function moment_mask_scalar_12_rsp_rsp(x, order, dim, center, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(sp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_12_rsp_rsp - module function moment_mask_scalar_13_rsp_rsp(x, order, dim, center, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(sp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_13_rsp_rsp - module function moment_mask_scalar_14_rsp_rsp(x, order, dim, center, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(sp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_14_rsp_rsp - module function moment_mask_scalar_15_rsp_rsp(x, order, dim, center, mask) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(sp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_15_rsp_rsp - module function moment_mask_scalar_2_rdp_rdp(x, order, dim, center, mask) result(res) - real(dp), intent(in) :: x(:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp), intent(in) :: center - logical, intent(in) :: mask(:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_2_rdp_rdp - module function moment_mask_scalar_3_rdp_rdp(x, order, dim, center, mask) result(res) - real(dp), intent(in) :: x(:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_3_rdp_rdp - module function moment_mask_scalar_4_rdp_rdp(x, order, dim, center, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_4_rdp_rdp - module function moment_mask_scalar_5_rdp_rdp(x, order, dim, center, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_5_rdp_rdp - module function moment_mask_scalar_6_rdp_rdp(x, order, dim, center, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_6_rdp_rdp - module function moment_mask_scalar_7_rdp_rdp(x, order, dim, center, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_7_rdp_rdp - module function moment_mask_scalar_8_rdp_rdp(x, order, dim, center, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_8_rdp_rdp - module function moment_mask_scalar_9_rdp_rdp(x, order, dim, center, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_9_rdp_rdp - module function moment_mask_scalar_10_rdp_rdp(x, order, dim, center, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_10_rdp_rdp - module function moment_mask_scalar_11_rdp_rdp(x, order, dim, center, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_11_rdp_rdp - module function moment_mask_scalar_12_rdp_rdp(x, order, dim, center, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_12_rdp_rdp - module function moment_mask_scalar_13_rdp_rdp(x, order, dim, center, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_13_rdp_rdp - module function moment_mask_scalar_14_rdp_rdp(x, order, dim, center, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_14_rdp_rdp - module function moment_mask_scalar_15_rdp_rdp(x, order, dim, center, mask) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_15_rdp_rdp - module function moment_mask_scalar_2_rqp_rqp(x, order, dim, center, mask) result(res) - real(qp), intent(in) :: x(:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(qp), intent(in) :: center - logical, intent(in) :: mask(:,:) - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_2_rqp_rqp - module function moment_mask_scalar_3_rqp_rqp(x, order, dim, center, mask) result(res) - real(qp), intent(in) :: x(:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(qp), intent(in) :: center - logical, intent(in) :: mask(:,:,:) - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_3_rqp_rqp - module function moment_mask_scalar_4_rqp_rqp(x, order, dim, center, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(qp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:) - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_4_rqp_rqp - module function moment_mask_scalar_5_rqp_rqp(x, order, dim, center, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(qp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:) - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_5_rqp_rqp - module function moment_mask_scalar_6_rqp_rqp(x, order, dim, center, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(qp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:) - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_6_rqp_rqp - module function moment_mask_scalar_7_rqp_rqp(x, order, dim, center, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(qp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:) - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_7_rqp_rqp - module function moment_mask_scalar_8_rqp_rqp(x, order, dim, center, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(qp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:) - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_8_rqp_rqp - module function moment_mask_scalar_9_rqp_rqp(x, order, dim, center, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(qp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_9_rqp_rqp - module function moment_mask_scalar_10_rqp_rqp(x, order, dim, center, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(qp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_10_rqp_rqp - module function moment_mask_scalar_11_rqp_rqp(x, order, dim, center, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(qp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_11_rqp_rqp - module function moment_mask_scalar_12_rqp_rqp(x, order, dim, center, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(qp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_12_rqp_rqp - module function moment_mask_scalar_13_rqp_rqp(x, order, dim, center, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(qp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_13_rqp_rqp - module function moment_mask_scalar_14_rqp_rqp(x, order, dim, center, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(qp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_14_rqp_rqp - module function moment_mask_scalar_15_rqp_rqp(x, order, dim, center, mask) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(qp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_15_rqp_rqp - module function moment_mask_scalar_2_csp_csp(x, order, dim, center, mask) result(res) - complex(sp), intent(in) :: x(:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(sp), intent(in) :: center - logical, intent(in) :: mask(:,:) - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_2_csp_csp - module function moment_mask_scalar_3_csp_csp(x, order, dim, center, mask) result(res) - complex(sp), intent(in) :: x(:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(sp), intent(in) :: center - logical, intent(in) :: mask(:,:,:) - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_3_csp_csp - module function moment_mask_scalar_4_csp_csp(x, order, dim, center, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(sp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:) - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_4_csp_csp - module function moment_mask_scalar_5_csp_csp(x, order, dim, center, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(sp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:) - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_5_csp_csp - module function moment_mask_scalar_6_csp_csp(x, order, dim, center, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(sp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:) - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_6_csp_csp - module function moment_mask_scalar_7_csp_csp(x, order, dim, center, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(sp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:) - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_7_csp_csp - module function moment_mask_scalar_8_csp_csp(x, order, dim, center, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(sp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:) - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_8_csp_csp - module function moment_mask_scalar_9_csp_csp(x, order, dim, center, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(sp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_9_csp_csp - module function moment_mask_scalar_10_csp_csp(x, order, dim, center, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(sp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_10_csp_csp - module function moment_mask_scalar_11_csp_csp(x, order, dim, center, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(sp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_11_csp_csp - module function moment_mask_scalar_12_csp_csp(x, order, dim, center, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(sp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_12_csp_csp - module function moment_mask_scalar_13_csp_csp(x, order, dim, center, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(sp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_13_csp_csp - module function moment_mask_scalar_14_csp_csp(x, order, dim, center, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(sp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_14_csp_csp - module function moment_mask_scalar_15_csp_csp(x, order, dim, center, mask) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(sp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - complex(sp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_15_csp_csp - module function moment_mask_scalar_2_cdp_cdp(x, order, dim, center, mask) result(res) - complex(dp), intent(in) :: x(:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(dp), intent(in) :: center - logical, intent(in) :: mask(:,:) - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_2_cdp_cdp - module function moment_mask_scalar_3_cdp_cdp(x, order, dim, center, mask) result(res) - complex(dp), intent(in) :: x(:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:) - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_3_cdp_cdp - module function moment_mask_scalar_4_cdp_cdp(x, order, dim, center, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:) - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_4_cdp_cdp - module function moment_mask_scalar_5_cdp_cdp(x, order, dim, center, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:) - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_5_cdp_cdp - module function moment_mask_scalar_6_cdp_cdp(x, order, dim, center, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:) - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_6_cdp_cdp - module function moment_mask_scalar_7_cdp_cdp(x, order, dim, center, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:) - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_7_cdp_cdp - module function moment_mask_scalar_8_cdp_cdp(x, order, dim, center, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:) - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_8_cdp_cdp - module function moment_mask_scalar_9_cdp_cdp(x, order, dim, center, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_9_cdp_cdp - module function moment_mask_scalar_10_cdp_cdp(x, order, dim, center, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_10_cdp_cdp - module function moment_mask_scalar_11_cdp_cdp(x, order, dim, center, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_11_cdp_cdp - module function moment_mask_scalar_12_cdp_cdp(x, order, dim, center, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then + if (dim >= 1 .and. dim <= 4) then res = sum((x - center)**order, dim, mask) / count(mask, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_12_cdp_cdp - module function moment_mask_scalar_13_cdp_cdp(x, order, dim, center, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + end function moment_mask_scalar_4_rsp_rsp + module function moment_mask_scalar_5_rsp_rsp(x, order, dim, center, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - complex(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then + if (dim >= 1 .and. dim <= 5) then res = sum((x - center)**order, dim, mask) / count(mask, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_13_cdp_cdp - module function moment_mask_scalar_14_cdp_cdp(x, order, dim, center, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function moment_mask_scalar_5_rsp_rsp + module function moment_mask_scalar_6_rsp_rsp(x, order, dim, center, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - complex(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + if (dim >= 1 .and. dim <= 6) then res = sum((x - center)**order, dim, mask) / count(mask, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_14_cdp_cdp - module function moment_mask_scalar_15_cdp_cdp(x, order, dim, center, mask) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function moment_mask_scalar_6_rsp_rsp + module function moment_mask_scalar_7_rsp_rsp(x, order, dim, center, mask) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - complex(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + if (dim >= 1 .and. dim <= 7) then res = sum((x - center)**order, dim, mask) / count(mask, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_15_cdp_cdp - module function moment_mask_scalar_2_cqp_cqp(x, order, dim, center, mask) result(res) - complex(qp), intent(in) :: x(:,:) + end function moment_mask_scalar_7_rsp_rsp + module function moment_mask_scalar_2_rdp_rdp(x, order, dim, center, mask) result(res) + real(dp), intent(in) :: x(:,:) integer, intent(in) :: order integer, intent(in) :: dim - complex(qp), intent(in) :: center + real(dp), intent(in) :: center logical, intent(in) :: mask(:,:) - complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then res = sum((x - center)**order, dim, mask) / count(mask, dim) @@ -4384,14 +1369,14 @@ module function moment_mask_scalar_2_cqp_cqp(x, order, dim, center, mask) result call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_2_cqp_cqp - module function moment_mask_scalar_3_cqp_cqp(x, order, dim, center, mask) result(res) - complex(qp), intent(in) :: x(:,:,:) + end function moment_mask_scalar_2_rdp_rdp + module function moment_mask_scalar_3_rdp_rdp(x, order, dim, center, mask) result(res) + real(dp), intent(in) :: x(:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - complex(qp), intent(in) :: center + real(dp), intent(in) :: center logical, intent(in) :: mask(:,:,:) - complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then res = sum((x - center)**order, dim, mask) / count(mask, dim) @@ -4399,14 +1384,14 @@ module function moment_mask_scalar_3_cqp_cqp(x, order, dim, center, mask) result call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_3_cqp_cqp - module function moment_mask_scalar_4_cqp_cqp(x, order, dim, center, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:) + end function moment_mask_scalar_3_rdp_rdp + module function moment_mask_scalar_4_rdp_rdp(x, order, dim, center, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - complex(qp), intent(in) :: center + real(dp), intent(in) :: center logical, intent(in) :: mask(:,:,:,:) - complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then @@ -4415,14 +1400,14 @@ module function moment_mask_scalar_4_cqp_cqp(x, order, dim, center, mask) result call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_4_cqp_cqp - module function moment_mask_scalar_5_cqp_cqp(x, order, dim, center, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:) + end function moment_mask_scalar_4_rdp_rdp + module function moment_mask_scalar_5_rdp_rdp(x, order, dim, center, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - complex(qp), intent(in) :: center + real(dp), intent(in) :: center logical, intent(in) :: mask(:,:,:,:,:) - complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then @@ -4431,14 +1416,14 @@ module function moment_mask_scalar_5_cqp_cqp(x, order, dim, center, mask) result call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_5_cqp_cqp - module function moment_mask_scalar_6_cqp_cqp(x, order, dim, center, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:) + end function moment_mask_scalar_5_rdp_rdp + module function moment_mask_scalar_6_rdp_rdp(x, order, dim, center, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - complex(qp), intent(in) :: center + real(dp), intent(in) :: center logical, intent(in) :: mask(:,:,:,:,:,:) - complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then @@ -4447,14 +1432,14 @@ module function moment_mask_scalar_6_cqp_cqp(x, order, dim, center, mask) result call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_6_cqp_cqp - module function moment_mask_scalar_7_cqp_cqp(x, order, dim, center, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:) + end function moment_mask_scalar_6_rdp_rdp + module function moment_mask_scalar_7_rdp_rdp(x, order, dim, center, mask) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - complex(qp), intent(in) :: center + real(dp), intent(in) :: center logical, intent(in) :: mask(:,:,:,:,:,:,:) - complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_8_cqp_cqp - module function moment_mask_scalar_9_cqp_cqp(x, order, dim, center, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(qp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) - complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_9_cqp_cqp - module function moment_mask_scalar_10_cqp_cqp(x, order, dim, center, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(qp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) - complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_10_cqp_cqp - module function moment_mask_scalar_11_cqp_cqp(x, order, dim, center, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(qp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) - complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_11_cqp_cqp - module function moment_mask_scalar_12_cqp_cqp(x, order, dim, center, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(qp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) - complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_12_cqp_cqp - module function moment_mask_scalar_13_cqp_cqp(x, order, dim, center, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(qp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) - complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_13_cqp_cqp - module function moment_mask_scalar_14_cqp_cqp(x, order, dim, center, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(qp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_14_cqp_cqp - module function moment_mask_scalar_15_cqp_cqp(x, order, dim, center, mask) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - complex(qp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - complex(qp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then - res = sum((x - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_15_cqp_cqp - - - module function moment_mask_scalar_2_iint8_dp(x, order, dim, center, mask) result(res) - integer(int8), intent(in) :: x(:,:) + end function moment_mask_scalar_7_rdp_rdp + module function moment_mask_scalar_2_rqp_rqp(x, order, dim, center, mask) result(res) + real(qp), intent(in) :: x(:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(dp), intent(in) :: center + real(qp), intent(in) :: center logical, intent(in) :: mask(:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then - res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + res = sum((x - center)**order, dim, mask) / count(mask, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_2_iint8_dp - module function moment_mask_scalar_3_iint8_dp(x, order, dim, center, mask) result(res) - integer(int8), intent(in) :: x(:,:,:) + end function moment_mask_scalar_2_rqp_rqp + module function moment_mask_scalar_3_rqp_rqp(x, order, dim, center, mask) result(res) + real(qp), intent(in) :: x(:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(dp), intent(in) :: center + real(qp), intent(in) :: center logical, intent(in) :: mask(:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then - res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + res = sum((x - center)**order, dim, mask) / count(mask, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_3_iint8_dp - module function moment_mask_scalar_4_iint8_dp(x, order, dim, center, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:) + end function moment_mask_scalar_3_rqp_rqp + module function moment_mask_scalar_4_rqp_rqp(x, order, dim, center, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(dp), intent(in) :: center + real(qp), intent(in) :: center logical, intent(in) :: mask(:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then - res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + res = sum((x - center)**order, dim, mask) / count(mask, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_4_iint8_dp - module function moment_mask_scalar_5_iint8_dp(x, order, dim, center, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:) + end function moment_mask_scalar_4_rqp_rqp + module function moment_mask_scalar_5_rqp_rqp(x, order, dim, center, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(dp), intent(in) :: center + real(qp), intent(in) :: center logical, intent(in) :: mask(:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then - res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + res = sum((x - center)**order, dim, mask) / count(mask, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_5_iint8_dp - module function moment_mask_scalar_6_iint8_dp(x, order, dim, center, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:) + end function moment_mask_scalar_5_rqp_rqp + module function moment_mask_scalar_6_rqp_rqp(x, order, dim, center, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(dp), intent(in) :: center + real(qp), intent(in) :: center logical, intent(in) :: mask(:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then - res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + res = sum((x - center)**order, dim, mask) / count(mask, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_6_iint8_dp - module function moment_mask_scalar_7_iint8_dp(x, order, dim, center, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:) + end function moment_mask_scalar_6_rqp_rqp + module function moment_mask_scalar_7_rqp_rqp(x, order, dim, center, mask) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(dp), intent(in) :: center + real(qp), intent(in) :: center logical, intent(in) :: mask(:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then - res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_7_iint8_dp - module function moment_mask_scalar_8_iint8_dp(x, order, dim, center, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then - res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_8_iint8_dp - module function moment_mask_scalar_9_iint8_dp(x, order, dim, center, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then - res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + res = sum((x - center)**order, dim, mask) / count(mask, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_9_iint8_dp - module function moment_mask_scalar_10_iint8_dp(x, order, dim, center, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + end function moment_mask_scalar_7_rqp_rqp + module function moment_mask_scalar_2_csp_csp(x, order, dim, center, mask) result(res) + complex(sp), intent(in) :: x(:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then - res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + if (dim >= 1 .and. dim <= 2) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_10_iint8_dp - module function moment_mask_scalar_11_iint8_dp(x, order, dim, center, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + end function moment_mask_scalar_2_csp_csp + module function moment_mask_scalar_3_csp_csp(x, order, dim, center, mask) result(res) + complex(sp), intent(in) :: x(:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then - res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + if (dim >= 1 .and. dim <= 3) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_11_iint8_dp - module function moment_mask_scalar_12_iint8_dp(x, order, dim, center, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + end function moment_mask_scalar_3_csp_csp + module function moment_mask_scalar_4_csp_csp(x, order, dim, center, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then - res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + if (dim >= 1 .and. dim <= 4) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_12_iint8_dp - module function moment_mask_scalar_13_iint8_dp(x, order, dim, center, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + end function moment_mask_scalar_4_csp_csp + module function moment_mask_scalar_5_csp_csp(x, order, dim, center, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then - res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + if (dim >= 1 .and. dim <= 5) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_13_iint8_dp - module function moment_mask_scalar_14_iint8_dp(x, order, dim, center, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function moment_mask_scalar_5_csp_csp + module function moment_mask_scalar_6_csp_csp(x, order, dim, center, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then - res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + if (dim >= 1 .and. dim <= 6) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_14_iint8_dp - module function moment_mask_scalar_15_iint8_dp(x, order, dim, center, mask) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function moment_mask_scalar_6_csp_csp + module function moment_mask_scalar_7_csp_csp(x, order, dim, center, mask) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then - res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + if (dim >= 1 .and. dim <= 7) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_15_iint8_dp - module function moment_mask_scalar_2_iint16_dp(x, order, dim, center, mask) result(res) - integer(int16), intent(in) :: x(:,:) + end function moment_mask_scalar_7_csp_csp + module function moment_mask_scalar_2_cdp_cdp(x, order, dim, center, mask) result(res) + complex(dp), intent(in) :: x(:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(dp), intent(in) :: center + complex(dp), intent(in) :: center logical, intent(in) :: mask(:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 2) then - res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + res = sum((x - center)**order, dim, mask) / count(mask, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_2_iint16_dp - module function moment_mask_scalar_3_iint16_dp(x, order, dim, center, mask) result(res) - integer(int16), intent(in) :: x(:,:,:) + end function moment_mask_scalar_2_cdp_cdp + module function moment_mask_scalar_3_cdp_cdp(x, order, dim, center, mask) result(res) + complex(dp), intent(in) :: x(:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(dp), intent(in) :: center + complex(dp), intent(in) :: center logical, intent(in) :: mask(:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 3) then - res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + res = sum((x - center)**order, dim, mask) / count(mask, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_3_iint16_dp - module function moment_mask_scalar_4_iint16_dp(x, order, dim, center, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:) + end function moment_mask_scalar_3_cdp_cdp + module function moment_mask_scalar_4_cdp_cdp(x, order, dim, center, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(dp), intent(in) :: center + complex(dp), intent(in) :: center logical, intent(in) :: mask(:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 4) then - res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + res = sum((x - center)**order, dim, mask) / count(mask, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_4_iint16_dp - module function moment_mask_scalar_5_iint16_dp(x, order, dim, center, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:) + end function moment_mask_scalar_4_cdp_cdp + module function moment_mask_scalar_5_cdp_cdp(x, order, dim, center, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(dp), intent(in) :: center + complex(dp), intent(in) :: center logical, intent(in) :: mask(:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 5) then - res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + res = sum((x - center)**order, dim, mask) / count(mask, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_5_iint16_dp - module function moment_mask_scalar_6_iint16_dp(x, order, dim, center, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:) + end function moment_mask_scalar_5_cdp_cdp + module function moment_mask_scalar_6_cdp_cdp(x, order, dim, center, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(dp), intent(in) :: center + complex(dp), intent(in) :: center logical, intent(in) :: mask(:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 6) then - res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + res = sum((x - center)**order, dim, mask) / count(mask, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_6_iint16_dp - module function moment_mask_scalar_7_iint16_dp(x, order, dim, center, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:) + end function moment_mask_scalar_6_cdp_cdp + module function moment_mask_scalar_7_cdp_cdp(x, order, dim, center, mask) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(dp), intent(in) :: center + complex(dp), intent(in) :: center logical, intent(in) :: mask(:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 7) then - res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_7_iint16_dp - module function moment_mask_scalar_8_iint16_dp(x, order, dim, center, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then - res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_8_iint16_dp - module function moment_mask_scalar_9_iint16_dp(x, order, dim, center, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then - res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + res = sum((x - center)**order, dim, mask) / count(mask, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_9_iint16_dp - module function moment_mask_scalar_10_iint16_dp(x, order, dim, center, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + end function moment_mask_scalar_7_cdp_cdp + module function moment_mask_scalar_2_cqp_cqp(x, order, dim, center, mask) result(res) + complex(qp), intent(in) :: x(:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then - res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + if (dim >= 1 .and. dim <= 2) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_10_iint16_dp - module function moment_mask_scalar_11_iint16_dp(x, order, dim, center, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + end function moment_mask_scalar_2_cqp_cqp + module function moment_mask_scalar_3_cqp_cqp(x, order, dim, center, mask) result(res) + complex(qp), intent(in) :: x(:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then - res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + if (dim >= 1 .and. dim <= 3) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_11_iint16_dp - module function moment_mask_scalar_12_iint16_dp(x, order, dim, center, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + end function moment_mask_scalar_3_cqp_cqp + module function moment_mask_scalar_4_cqp_cqp(x, order, dim, center, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then - res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + if (dim >= 1 .and. dim <= 4) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_12_iint16_dp - module function moment_mask_scalar_13_iint16_dp(x, order, dim, center, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + end function moment_mask_scalar_4_cqp_cqp + module function moment_mask_scalar_5_cqp_cqp(x, order, dim, center, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then - res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + if (dim >= 1 .and. dim <= 5) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_13_iint16_dp - module function moment_mask_scalar_14_iint16_dp(x, order, dim, center, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function moment_mask_scalar_5_cqp_cqp + module function moment_mask_scalar_6_cqp_cqp(x, order, dim, center, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then - res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + if (dim >= 1 .and. dim <= 6) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_14_iint16_dp - module function moment_mask_scalar_15_iint16_dp(x, order, dim, center, mask) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function moment_mask_scalar_6_cqp_cqp + module function moment_mask_scalar_7_cqp_cqp(x, order, dim, center, mask) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim - real(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then - res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) + if (dim >= 1 .and. dim <= 7) then + res = sum((x - center)**order, dim, mask) / count(mask, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_15_iint16_dp - module function moment_mask_scalar_2_iint32_dp(x, order, dim, center, mask) result(res) - integer(int32), intent(in) :: x(:,:) + end function moment_mask_scalar_7_cqp_cqp + + + module function moment_mask_scalar_2_iint8_dp(x, order, dim, center, mask) result(res) + integer(int8), intent(in) :: x(:,:) integer, intent(in) :: order integer, intent(in) :: dim real(dp), intent(in) :: center @@ -5118,9 +1846,9 @@ module function moment_mask_scalar_2_iint32_dp(x, order, dim, center, mask) resu call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_2_iint32_dp - module function moment_mask_scalar_3_iint32_dp(x, order, dim, center, mask) result(res) - integer(int32), intent(in) :: x(:,:,:) + end function moment_mask_scalar_2_iint8_dp + module function moment_mask_scalar_3_iint8_dp(x, order, dim, center, mask) result(res) + integer(int8), intent(in) :: x(:,:,:) integer, intent(in) :: order integer, intent(in) :: dim real(dp), intent(in) :: center @@ -5133,9 +1861,9 @@ module function moment_mask_scalar_3_iint32_dp(x, order, dim, center, mask) resu call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_3_iint32_dp - module function moment_mask_scalar_4_iint32_dp(x, order, dim, center, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:) + end function moment_mask_scalar_3_iint8_dp + module function moment_mask_scalar_4_iint8_dp(x, order, dim, center, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim real(dp), intent(in) :: center @@ -5149,9 +1877,9 @@ module function moment_mask_scalar_4_iint32_dp(x, order, dim, center, mask) resu call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_4_iint32_dp - module function moment_mask_scalar_5_iint32_dp(x, order, dim, center, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:) + end function moment_mask_scalar_4_iint8_dp + module function moment_mask_scalar_5_iint8_dp(x, order, dim, center, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim real(dp), intent(in) :: center @@ -5165,9 +1893,9 @@ module function moment_mask_scalar_5_iint32_dp(x, order, dim, center, mask) resu call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_5_iint32_dp - module function moment_mask_scalar_6_iint32_dp(x, order, dim, center, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:) + end function moment_mask_scalar_5_iint8_dp + module function moment_mask_scalar_6_iint8_dp(x, order, dim, center, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim real(dp), intent(in) :: center @@ -5181,9 +1909,9 @@ module function moment_mask_scalar_6_iint32_dp(x, order, dim, center, mask) resu call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_6_iint32_dp - module function moment_mask_scalar_7_iint32_dp(x, order, dim, center, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:) + end function moment_mask_scalar_6_iint8_dp + module function moment_mask_scalar_7_iint8_dp(x, order, dim, center, mask) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim real(dp), intent(in) :: center @@ -5198,158 +1926,104 @@ module function moment_mask_scalar_7_iint32_dp(x, order, dim, center, mask) resu call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_7_iint32_dp - module function moment_mask_scalar_8_iint32_dp(x, order, dim, center, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then - res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_8_iint32_dp - module function moment_mask_scalar_9_iint32_dp(x, order, dim, center, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then - res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_9_iint32_dp - module function moment_mask_scalar_10_iint32_dp(x, order, dim, center, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + end function moment_mask_scalar_7_iint8_dp + module function moment_mask_scalar_2_iint16_dp(x, order, dim, center, mask) result(res) + integer(int16), intent(in) :: x(:,:) integer, intent(in) :: order integer, intent(in) :: dim real(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then + if (dim >= 1 .and. dim <= 2) then res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_10_iint32_dp - module function moment_mask_scalar_11_iint32_dp(x, order, dim, center, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + end function moment_mask_scalar_2_iint16_dp + module function moment_mask_scalar_3_iint16_dp(x, order, dim, center, mask) result(res) + integer(int16), intent(in) :: x(:,:,:) integer, intent(in) :: order integer, intent(in) :: dim real(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then + if (dim >= 1 .and. dim <= 3) then res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_11_iint32_dp - module function moment_mask_scalar_12_iint32_dp(x, order, dim, center, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + end function moment_mask_scalar_3_iint16_dp + module function moment_mask_scalar_4_iint16_dp(x, order, dim, center, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim real(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:) real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then + if (dim >= 1 .and. dim <= 4) then res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_12_iint32_dp - module function moment_mask_scalar_13_iint32_dp(x, order, dim, center, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + end function moment_mask_scalar_4_iint16_dp + module function moment_mask_scalar_5_iint16_dp(x, order, dim, center, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim real(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:) real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then + if (dim >= 1 .and. dim <= 5) then res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_13_iint32_dp - module function moment_mask_scalar_14_iint32_dp(x, order, dim, center, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function moment_mask_scalar_5_iint16_dp + module function moment_mask_scalar_6_iint16_dp(x, order, dim, center, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim real(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:) real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + if (dim >= 1 .and. dim <= 6) then res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_14_iint32_dp - module function moment_mask_scalar_15_iint32_dp(x, order, dim, center, mask) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function moment_mask_scalar_6_iint16_dp + module function moment_mask_scalar_7_iint16_dp(x, order, dim, center, mask) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim real(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:) real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + if (dim >= 1 .and. dim <= 7) then res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_15_iint32_dp - module function moment_mask_scalar_2_iint64_dp(x, order, dim, center, mask) result(res) - integer(int64), intent(in) :: x(:,:) + end function moment_mask_scalar_7_iint16_dp + module function moment_mask_scalar_2_iint32_dp(x, order, dim, center, mask) result(res) + integer(int32), intent(in) :: x(:,:) integer, intent(in) :: order integer, intent(in) :: dim real(dp), intent(in) :: center @@ -5362,9 +2036,9 @@ module function moment_mask_scalar_2_iint64_dp(x, order, dim, center, mask) resu call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_2_iint64_dp - module function moment_mask_scalar_3_iint64_dp(x, order, dim, center, mask) result(res) - integer(int64), intent(in) :: x(:,:,:) + end function moment_mask_scalar_2_iint32_dp + module function moment_mask_scalar_3_iint32_dp(x, order, dim, center, mask) result(res) + integer(int32), intent(in) :: x(:,:,:) integer, intent(in) :: order integer, intent(in) :: dim real(dp), intent(in) :: center @@ -5377,9 +2051,9 @@ module function moment_mask_scalar_3_iint64_dp(x, order, dim, center, mask) resu call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_3_iint64_dp - module function moment_mask_scalar_4_iint64_dp(x, order, dim, center, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:) + end function moment_mask_scalar_3_iint32_dp + module function moment_mask_scalar_4_iint32_dp(x, order, dim, center, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim real(dp), intent(in) :: center @@ -5393,9 +2067,9 @@ module function moment_mask_scalar_4_iint64_dp(x, order, dim, center, mask) resu call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_4_iint64_dp - module function moment_mask_scalar_5_iint64_dp(x, order, dim, center, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:) + end function moment_mask_scalar_4_iint32_dp + module function moment_mask_scalar_5_iint32_dp(x, order, dim, center, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim real(dp), intent(in) :: center @@ -5409,9 +2083,9 @@ module function moment_mask_scalar_5_iint64_dp(x, order, dim, center, mask) resu call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_5_iint64_dp - module function moment_mask_scalar_6_iint64_dp(x, order, dim, center, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:) + end function moment_mask_scalar_5_iint32_dp + module function moment_mask_scalar_6_iint32_dp(x, order, dim, center, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim real(dp), intent(in) :: center @@ -5425,9 +2099,9 @@ module function moment_mask_scalar_6_iint64_dp(x, order, dim, center, mask) resu call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_6_iint64_dp - module function moment_mask_scalar_7_iint64_dp(x, order, dim, center, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:) + end function moment_mask_scalar_6_iint32_dp + module function moment_mask_scalar_7_iint32_dp(x, order, dim, center, mask) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim real(dp), intent(in) :: center @@ -5442,155 +2116,101 @@ module function moment_mask_scalar_7_iint64_dp(x, order, dim, center, mask) resu call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_7_iint64_dp - module function moment_mask_scalar_8_iint64_dp(x, order, dim, center, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 8) then - res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_8_iint64_dp - module function moment_mask_scalar_9_iint64_dp(x, order, dim, center, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:) - integer, intent(in) :: order - integer, intent(in) :: dim - real(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 9) then - res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) - else - call error_stop("ERROR (moment): wrong dimension") - end if - - end function moment_mask_scalar_9_iint64_dp - module function moment_mask_scalar_10_iint64_dp(x, order, dim, center, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + end function moment_mask_scalar_7_iint32_dp + module function moment_mask_scalar_2_iint64_dp(x, order, dim, center, mask) result(res) + integer(int64), intent(in) :: x(:,:) integer, intent(in) :: order integer, intent(in) :: dim real(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 10) then + if (dim >= 1 .and. dim <= 2) then res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_10_iint64_dp - module function moment_mask_scalar_11_iint64_dp(x, order, dim, center, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + end function moment_mask_scalar_2_iint64_dp + module function moment_mask_scalar_3_iint64_dp(x, order, dim, center, mask) result(res) + integer(int64), intent(in) :: x(:,:,:) integer, intent(in) :: order integer, intent(in) :: dim real(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 11) then + if (dim >= 1 .and. dim <= 3) then res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_11_iint64_dp - module function moment_mask_scalar_12_iint64_dp(x, order, dim, center, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + end function moment_mask_scalar_3_iint64_dp + module function moment_mask_scalar_4_iint64_dp(x, order, dim, center, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim real(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:) real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 12) then + if (dim >= 1 .and. dim <= 4) then res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_12_iint64_dp - module function moment_mask_scalar_13_iint64_dp(x, order, dim, center, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + end function moment_mask_scalar_4_iint64_dp + module function moment_mask_scalar_5_iint64_dp(x, order, dim, center, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim real(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:) real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 13) then + if (dim >= 1 .and. dim <= 5) then res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_13_iint64_dp - module function moment_mask_scalar_14_iint64_dp(x, order, dim, center, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function moment_mask_scalar_5_iint64_dp + module function moment_mask_scalar_6_iint64_dp(x, order, dim, center, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim real(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:) real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 14) then + if (dim >= 1 .and. dim <= 6) then res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_14_iint64_dp - module function moment_mask_scalar_15_iint64_dp(x, order, dim, center, mask) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function moment_mask_scalar_6_iint64_dp + module function moment_mask_scalar_7_iint64_dp(x, order, dim, center, mask) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:) integer, intent(in) :: order integer, intent(in) :: dim real(dp), intent(in) :: center - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:) real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1= 1 .and. dim <= 15) then + if (dim >= 1 .and. dim <= 7) then res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim) else call error_stop("ERROR (moment): wrong dimension") end if - end function moment_mask_scalar_15_iint64_dp + end function moment_mask_scalar_7_iint64_dp end submodule diff --git a/src/fpm/stdlib_stats_var.f90 b/src/fpm/stdlib_stats_var.f90 index 6dffe6b94..81ff0a48c 100644 --- a/src/fpm/stdlib_stats_var.f90 +++ b/src/fpm/stdlib_stats_var.f90 @@ -147,166 +147,6 @@ module function var_all_7_rsp_rsp(x, mask, corrected) result(res) res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) end function var_all_7_rsp_rsp - module function var_all_8_rsp_rsp(x, mask, corrected) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - logical, intent(in), optional :: corrected - real(sp) :: res - - real(sp) :: n - real(sp) :: mean - - if (.not.optval(mask, .true.)) then - res = ieee_value(1._sp, ieee_quiet_nan) - return - end if - - n = real(size(x, kind = int64), sp) - mean = sum(x) / n - - res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) - - end function var_all_8_rsp_rsp - module function var_all_9_rsp_rsp(x, mask, corrected) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - logical, intent(in), optional :: corrected - real(sp) :: res - - real(sp) :: n - real(sp) :: mean - - if (.not.optval(mask, .true.)) then - res = ieee_value(1._sp, ieee_quiet_nan) - return - end if - - n = real(size(x, kind = int64), sp) - mean = sum(x) / n - - res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) - - end function var_all_9_rsp_rsp - module function var_all_10_rsp_rsp(x, mask, corrected) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - logical, intent(in), optional :: corrected - real(sp) :: res - - real(sp) :: n - real(sp) :: mean - - if (.not.optval(mask, .true.)) then - res = ieee_value(1._sp, ieee_quiet_nan) - return - end if - - n = real(size(x, kind = int64), sp) - mean = sum(x) / n - - res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) - - end function var_all_10_rsp_rsp - module function var_all_11_rsp_rsp(x, mask, corrected) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - logical, intent(in), optional :: corrected - real(sp) :: res - - real(sp) :: n - real(sp) :: mean - - if (.not.optval(mask, .true.)) then - res = ieee_value(1._sp, ieee_quiet_nan) - return - end if - - n = real(size(x, kind = int64), sp) - mean = sum(x) / n - - res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) - - end function var_all_11_rsp_rsp - module function var_all_12_rsp_rsp(x, mask, corrected) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - logical, intent(in), optional :: corrected - real(sp) :: res - - real(sp) :: n - real(sp) :: mean - - if (.not.optval(mask, .true.)) then - res = ieee_value(1._sp, ieee_quiet_nan) - return - end if - - n = real(size(x, kind = int64), sp) - mean = sum(x) / n - - res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) - - end function var_all_12_rsp_rsp - module function var_all_13_rsp_rsp(x, mask, corrected) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - logical, intent(in), optional :: corrected - real(sp) :: res - - real(sp) :: n - real(sp) :: mean - - if (.not.optval(mask, .true.)) then - res = ieee_value(1._sp, ieee_quiet_nan) - return - end if - - n = real(size(x, kind = int64), sp) - mean = sum(x) / n - - res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) - - end function var_all_13_rsp_rsp - module function var_all_14_rsp_rsp(x, mask, corrected) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - logical, intent(in), optional :: corrected - real(sp) :: res - - real(sp) :: n - real(sp) :: mean - - if (.not.optval(mask, .true.)) then - res = ieee_value(1._sp, ieee_quiet_nan) - return - end if - - n = real(size(x, kind = int64), sp) - mean = sum(x) / n - - res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) - - end function var_all_14_rsp_rsp - module function var_all_15_rsp_rsp(x, mask, corrected) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: mask - logical, intent(in), optional :: corrected - real(sp) :: res - - real(sp) :: n - real(sp) :: mean - - if (.not.optval(mask, .true.)) then - res = ieee_value(1._sp, ieee_quiet_nan) - return - end if - - n = real(size(x, kind = int64), sp) - mean = sum(x) / n - - res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) - - end function var_all_15_rsp_rsp module function var_all_1_rdp_rdp(x, mask, corrected) result(res) real(dp), intent(in) :: x(:) logical, intent(in), optional :: mask @@ -447,434 +287,434 @@ module function var_all_7_rdp_rdp(x, mask, corrected) result(res) res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) end function var_all_7_rdp_rdp - module function var_all_8_rdp_rdp(x, mask, corrected) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:) + module function var_all_1_rqp_rqp(x, mask, corrected) result(res) + real(qp), intent(in) :: x(:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected - real(dp) :: res + real(qp) :: res - real(dp) :: n - real(dp) :: mean + real(qp) :: n + real(qp) :: mean if (.not.optval(mask, .true.)) then - res = ieee_value(1._dp, ieee_quiet_nan) + res = ieee_value(1._qp, ieee_quiet_nan) return end if - n = real(size(x, kind = int64), dp) + n = real(size(x, kind = int64), qp) mean = sum(x) / n res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) - end function var_all_8_rdp_rdp - module function var_all_9_rdp_rdp(x, mask, corrected) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + end function var_all_1_rqp_rqp + module function var_all_2_rqp_rqp(x, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected - real(dp) :: res + real(qp) :: res - real(dp) :: n - real(dp) :: mean + real(qp) :: n + real(qp) :: mean if (.not.optval(mask, .true.)) then - res = ieee_value(1._dp, ieee_quiet_nan) + res = ieee_value(1._qp, ieee_quiet_nan) return end if - n = real(size(x, kind = int64), dp) + n = real(size(x, kind = int64), qp) mean = sum(x) / n res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) - end function var_all_9_rdp_rdp - module function var_all_10_rdp_rdp(x, mask, corrected) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + end function var_all_2_rqp_rqp + module function var_all_3_rqp_rqp(x, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:,:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected - real(dp) :: res + real(qp) :: res - real(dp) :: n - real(dp) :: mean + real(qp) :: n + real(qp) :: mean if (.not.optval(mask, .true.)) then - res = ieee_value(1._dp, ieee_quiet_nan) + res = ieee_value(1._qp, ieee_quiet_nan) return end if - n = real(size(x, kind = int64), dp) + n = real(size(x, kind = int64), qp) mean = sum(x) / n res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) - end function var_all_10_rdp_rdp - module function var_all_11_rdp_rdp(x, mask, corrected) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + end function var_all_3_rqp_rqp + module function var_all_4_rqp_rqp(x, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:,:,:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected - real(dp) :: res + real(qp) :: res - real(dp) :: n - real(dp) :: mean + real(qp) :: n + real(qp) :: mean if (.not.optval(mask, .true.)) then - res = ieee_value(1._dp, ieee_quiet_nan) + res = ieee_value(1._qp, ieee_quiet_nan) return end if - n = real(size(x, kind = int64), dp) + n = real(size(x, kind = int64), qp) mean = sum(x) / n res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) - end function var_all_11_rdp_rdp - module function var_all_12_rdp_rdp(x, mask, corrected) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + end function var_all_4_rqp_rqp + module function var_all_5_rqp_rqp(x, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:,:,:,:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected - real(dp) :: res + real(qp) :: res - real(dp) :: n - real(dp) :: mean + real(qp) :: n + real(qp) :: mean if (.not.optval(mask, .true.)) then - res = ieee_value(1._dp, ieee_quiet_nan) + res = ieee_value(1._qp, ieee_quiet_nan) return end if - n = real(size(x, kind = int64), dp) + n = real(size(x, kind = int64), qp) mean = sum(x) / n res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) - end function var_all_12_rdp_rdp - module function var_all_13_rdp_rdp(x, mask, corrected) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + end function var_all_5_rqp_rqp + module function var_all_6_rqp_rqp(x, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected - real(dp) :: res + real(qp) :: res - real(dp) :: n - real(dp) :: mean + real(qp) :: n + real(qp) :: mean if (.not.optval(mask, .true.)) then - res = ieee_value(1._dp, ieee_quiet_nan) + res = ieee_value(1._qp, ieee_quiet_nan) return end if - n = real(size(x, kind = int64), dp) + n = real(size(x, kind = int64), qp) mean = sum(x) / n res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) - end function var_all_13_rdp_rdp - module function var_all_14_rdp_rdp(x, mask, corrected) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function var_all_6_rqp_rqp + module function var_all_7_rqp_rqp(x, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected - real(dp) :: res + real(qp) :: res - real(dp) :: n - real(dp) :: mean + real(qp) :: n + real(qp) :: mean if (.not.optval(mask, .true.)) then - res = ieee_value(1._dp, ieee_quiet_nan) + res = ieee_value(1._qp, ieee_quiet_nan) return end if - n = real(size(x, kind = int64), dp) + n = real(size(x, kind = int64), qp) mean = sum(x) / n res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) - end function var_all_14_rdp_rdp - module function var_all_15_rdp_rdp(x, mask, corrected) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function var_all_7_rqp_rqp + module function var_all_1_csp_csp(x, mask, corrected) result(res) + complex(sp), intent(in) :: x(:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected - real(dp) :: res + real(sp) :: res - real(dp) :: n - real(dp) :: mean + real(sp) :: n + complex(sp) :: mean if (.not.optval(mask, .true.)) then - res = ieee_value(1._dp, ieee_quiet_nan) + res = ieee_value(1._sp, ieee_quiet_nan) return end if - n = real(size(x, kind = int64), dp) + n = real(size(x, kind = int64), sp) mean = sum(x) / n - res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_15_rdp_rdp - module function var_all_1_rqp_rqp(x, mask, corrected) result(res) - real(qp), intent(in) :: x(:) + end function var_all_1_csp_csp + module function var_all_2_csp_csp(x, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected - real(qp) :: res + real(sp) :: res - real(qp) :: n - real(qp) :: mean + real(sp) :: n + complex(sp) :: mean if (.not.optval(mask, .true.)) then - res = ieee_value(1._qp, ieee_quiet_nan) + res = ieee_value(1._sp, ieee_quiet_nan) return end if - n = real(size(x, kind = int64), qp) + n = real(size(x, kind = int64), sp) mean = sum(x) / n - res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_1_rqp_rqp - module function var_all_2_rqp_rqp(x, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:) + end function var_all_2_csp_csp + module function var_all_3_csp_csp(x, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected - real(qp) :: res + real(sp) :: res - real(qp) :: n - real(qp) :: mean + real(sp) :: n + complex(sp) :: mean if (.not.optval(mask, .true.)) then - res = ieee_value(1._qp, ieee_quiet_nan) + res = ieee_value(1._sp, ieee_quiet_nan) return end if - n = real(size(x, kind = int64), qp) + n = real(size(x, kind = int64), sp) mean = sum(x) / n - res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_2_rqp_rqp - module function var_all_3_rqp_rqp(x, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:,:) + end function var_all_3_csp_csp + module function var_all_4_csp_csp(x, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:,:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected - real(qp) :: res + real(sp) :: res - real(qp) :: n - real(qp) :: mean + real(sp) :: n + complex(sp) :: mean if (.not.optval(mask, .true.)) then - res = ieee_value(1._qp, ieee_quiet_nan) + res = ieee_value(1._sp, ieee_quiet_nan) return end if - n = real(size(x, kind = int64), qp) + n = real(size(x, kind = int64), sp) mean = sum(x) / n - res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_3_rqp_rqp - module function var_all_4_rqp_rqp(x, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:,:,:) + end function var_all_4_csp_csp + module function var_all_5_csp_csp(x, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected - real(qp) :: res + real(sp) :: res - real(qp) :: n - real(qp) :: mean + real(sp) :: n + complex(sp) :: mean if (.not.optval(mask, .true.)) then - res = ieee_value(1._qp, ieee_quiet_nan) + res = ieee_value(1._sp, ieee_quiet_nan) return end if - n = real(size(x, kind = int64), qp) + n = real(size(x, kind = int64), sp) mean = sum(x) / n - res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_4_rqp_rqp - module function var_all_5_rqp_rqp(x, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:,:,:,:) + end function var_all_5_csp_csp + module function var_all_6_csp_csp(x, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected - real(qp) :: res + real(sp) :: res - real(qp) :: n - real(qp) :: mean + real(sp) :: n + complex(sp) :: mean if (.not.optval(mask, .true.)) then - res = ieee_value(1._qp, ieee_quiet_nan) + res = ieee_value(1._sp, ieee_quiet_nan) return end if - n = real(size(x, kind = int64), qp) + n = real(size(x, kind = int64), sp) mean = sum(x) / n - res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_5_rqp_rqp - module function var_all_6_rqp_rqp(x, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:) + end function var_all_6_csp_csp + module function var_all_7_csp_csp(x, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected - real(qp) :: res + real(sp) :: res - real(qp) :: n - real(qp) :: mean + real(sp) :: n + complex(sp) :: mean if (.not.optval(mask, .true.)) then - res = ieee_value(1._qp, ieee_quiet_nan) + res = ieee_value(1._sp, ieee_quiet_nan) return end if - n = real(size(x, kind = int64), qp) + n = real(size(x, kind = int64), sp) mean = sum(x) / n - res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_6_rqp_rqp - module function var_all_7_rqp_rqp(x, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:) + end function var_all_7_csp_csp + module function var_all_1_cdp_cdp(x, mask, corrected) result(res) + complex(dp), intent(in) :: x(:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected - real(qp) :: res + real(dp) :: res - real(qp) :: n - real(qp) :: mean + real(dp) :: n + complex(dp) :: mean if (.not.optval(mask, .true.)) then - res = ieee_value(1._qp, ieee_quiet_nan) + res = ieee_value(1._dp, ieee_quiet_nan) return end if - n = real(size(x, kind = int64), qp) + n = real(size(x, kind = int64), dp) mean = sum(x) / n - res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_7_rqp_rqp - module function var_all_8_rqp_rqp(x, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:) + end function var_all_1_cdp_cdp + module function var_all_2_cdp_cdp(x, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected - real(qp) :: res + real(dp) :: res - real(qp) :: n - real(qp) :: mean + real(dp) :: n + complex(dp) :: mean if (.not.optval(mask, .true.)) then - res = ieee_value(1._qp, ieee_quiet_nan) + res = ieee_value(1._dp, ieee_quiet_nan) return end if - n = real(size(x, kind = int64), qp) + n = real(size(x, kind = int64), dp) mean = sum(x) / n - res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_8_rqp_rqp - module function var_all_9_rqp_rqp(x, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + end function var_all_2_cdp_cdp + module function var_all_3_cdp_cdp(x, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected - real(qp) :: res + real(dp) :: res - real(qp) :: n - real(qp) :: mean + real(dp) :: n + complex(dp) :: mean if (.not.optval(mask, .true.)) then - res = ieee_value(1._qp, ieee_quiet_nan) + res = ieee_value(1._dp, ieee_quiet_nan) return end if - n = real(size(x, kind = int64), qp) + n = real(size(x, kind = int64), dp) mean = sum(x) / n - res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_9_rqp_rqp - module function var_all_10_rqp_rqp(x, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + end function var_all_3_cdp_cdp + module function var_all_4_cdp_cdp(x, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:,:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected - real(qp) :: res + real(dp) :: res - real(qp) :: n - real(qp) :: mean + real(dp) :: n + complex(dp) :: mean if (.not.optval(mask, .true.)) then - res = ieee_value(1._qp, ieee_quiet_nan) + res = ieee_value(1._dp, ieee_quiet_nan) return end if - n = real(size(x, kind = int64), qp) + n = real(size(x, kind = int64), dp) mean = sum(x) / n - res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_10_rqp_rqp - module function var_all_11_rqp_rqp(x, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + end function var_all_4_cdp_cdp + module function var_all_5_cdp_cdp(x, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected - real(qp) :: res + real(dp) :: res - real(qp) :: n - real(qp) :: mean + real(dp) :: n + complex(dp) :: mean if (.not.optval(mask, .true.)) then - res = ieee_value(1._qp, ieee_quiet_nan) + res = ieee_value(1._dp, ieee_quiet_nan) return end if - n = real(size(x, kind = int64), qp) + n = real(size(x, kind = int64), dp) mean = sum(x) / n - res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_11_rqp_rqp - module function var_all_12_rqp_rqp(x, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + end function var_all_5_cdp_cdp + module function var_all_6_cdp_cdp(x, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected - real(qp) :: res + real(dp) :: res - real(qp) :: n - real(qp) :: mean + real(dp) :: n + complex(dp) :: mean if (.not.optval(mask, .true.)) then - res = ieee_value(1._qp, ieee_quiet_nan) + res = ieee_value(1._dp, ieee_quiet_nan) return end if - n = real(size(x, kind = int64), qp) + n = real(size(x, kind = int64), dp) mean = sum(x) / n - res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_12_rqp_rqp - module function var_all_13_rqp_rqp(x, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + end function var_all_6_cdp_cdp + module function var_all_7_cdp_cdp(x, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected - real(qp) :: res + real(dp) :: res - real(qp) :: n - real(qp) :: mean + real(dp) :: n + complex(dp) :: mean if (.not.optval(mask, .true.)) then - res = ieee_value(1._qp, ieee_quiet_nan) + res = ieee_value(1._dp, ieee_quiet_nan) return end if - n = real(size(x, kind = int64), qp) + n = real(size(x, kind = int64), dp) mean = sum(x) / n - res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_13_rqp_rqp - module function var_all_14_rqp_rqp(x, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function var_all_7_cdp_cdp + module function var_all_1_cqp_cqp(x, mask, corrected) result(res) + complex(qp), intent(in) :: x(:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected real(qp) :: res real(qp) :: n - real(qp) :: mean + complex(qp) :: mean if (.not.optval(mask, .true.)) then res = ieee_value(1._qp, ieee_quiet_nan) @@ -884,17 +724,17 @@ module function var_all_14_rqp_rqp(x, mask, corrected) result(res) n = real(size(x, kind = int64), qp) mean = sum(x) / n - res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_14_rqp_rqp - module function var_all_15_rqp_rqp(x, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function var_all_1_cqp_cqp + module function var_all_2_cqp_cqp(x, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected real(qp) :: res real(qp) :: n - real(qp) :: mean + complex(qp) :: mean if (.not.optval(mask, .true.)) then res = ieee_value(1._qp, ieee_quiet_nan) @@ -904,317 +744,308 @@ module function var_all_15_rqp_rqp(x, mask, corrected) result(res) n = real(size(x, kind = int64), qp) mean = sum(x) / n - res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.))) + res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_15_rqp_rqp - module function var_all_1_csp_csp(x, mask, corrected) result(res) - complex(sp), intent(in) :: x(:) + end function var_all_2_cqp_cqp + module function var_all_3_cqp_cqp(x, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected - real(sp) :: res + real(qp) :: res - real(sp) :: n - complex(sp) :: mean + real(qp) :: n + complex(qp) :: mean if (.not.optval(mask, .true.)) then - res = ieee_value(1._sp, ieee_quiet_nan) + res = ieee_value(1._qp, ieee_quiet_nan) return end if - n = real(size(x, kind = int64), sp) + n = real(size(x, kind = int64), qp) mean = sum(x) / n res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_1_csp_csp - module function var_all_2_csp_csp(x, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:) + end function var_all_3_cqp_cqp + module function var_all_4_cqp_cqp(x, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:,:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected - real(sp) :: res + real(qp) :: res - real(sp) :: n - complex(sp) :: mean + real(qp) :: n + complex(qp) :: mean if (.not.optval(mask, .true.)) then - res = ieee_value(1._sp, ieee_quiet_nan) + res = ieee_value(1._qp, ieee_quiet_nan) return end if - n = real(size(x, kind = int64), sp) + n = real(size(x, kind = int64), qp) mean = sum(x) / n res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_2_csp_csp - module function var_all_3_csp_csp(x, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:) + end function var_all_4_cqp_cqp + module function var_all_5_cqp_cqp(x, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected - real(sp) :: res + real(qp) :: res - real(sp) :: n - complex(sp) :: mean + real(qp) :: n + complex(qp) :: mean if (.not.optval(mask, .true.)) then - res = ieee_value(1._sp, ieee_quiet_nan) + res = ieee_value(1._qp, ieee_quiet_nan) return end if - n = real(size(x, kind = int64), sp) + n = real(size(x, kind = int64), qp) mean = sum(x) / n res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_3_csp_csp - module function var_all_4_csp_csp(x, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:,:) + end function var_all_5_cqp_cqp + module function var_all_6_cqp_cqp(x, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected - real(sp) :: res + real(qp) :: res - real(sp) :: n - complex(sp) :: mean + real(qp) :: n + complex(qp) :: mean if (.not.optval(mask, .true.)) then - res = ieee_value(1._sp, ieee_quiet_nan) + res = ieee_value(1._qp, ieee_quiet_nan) return end if - n = real(size(x, kind = int64), sp) + n = real(size(x, kind = int64), qp) mean = sum(x) / n res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_4_csp_csp - module function var_all_5_csp_csp(x, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:) + end function var_all_6_cqp_cqp + module function var_all_7_cqp_cqp(x, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected - real(sp) :: res + real(qp) :: res - real(sp) :: n - complex(sp) :: mean + real(qp) :: n + complex(qp) :: mean if (.not.optval(mask, .true.)) then - res = ieee_value(1._sp, ieee_quiet_nan) + res = ieee_value(1._qp, ieee_quiet_nan) return end if - n = real(size(x, kind = int64), sp) + n = real(size(x, kind = int64), qp) mean = sum(x) / n res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_5_csp_csp - module function var_all_6_csp_csp(x, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:) + end function var_all_7_cqp_cqp + + + module function var_all_1_iint8_dp(x, mask, corrected) result(res) + integer(int8), intent(in) :: x(:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected - real(sp) :: res + real(dp) :: res - real(sp) :: n - complex(sp) :: mean + real(dp) :: n, mean if (.not.optval(mask, .true.)) then - res = ieee_value(1._sp, ieee_quiet_nan) + res = ieee_value(1._dp, ieee_quiet_nan) return end if - n = real(size(x, kind = int64), sp) - mean = sum(x) / n + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n - res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_6_csp_csp - module function var_all_7_csp_csp(x, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:) + end function var_all_1_iint8_dp + module function var_all_2_iint8_dp(x, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected - real(sp) :: res + real(dp) :: res - real(sp) :: n - complex(sp) :: mean + real(dp) :: n, mean if (.not.optval(mask, .true.)) then - res = ieee_value(1._sp, ieee_quiet_nan) + res = ieee_value(1._dp, ieee_quiet_nan) return end if - n = real(size(x, kind = int64), sp) - mean = sum(x) / n + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n - res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_7_csp_csp - module function var_all_8_csp_csp(x, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:) + end function var_all_2_iint8_dp + module function var_all_3_iint8_dp(x, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected - real(sp) :: res + real(dp) :: res - real(sp) :: n - complex(sp) :: mean + real(dp) :: n, mean if (.not.optval(mask, .true.)) then - res = ieee_value(1._sp, ieee_quiet_nan) + res = ieee_value(1._dp, ieee_quiet_nan) return end if - n = real(size(x, kind = int64), sp) - mean = sum(x) / n + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n - res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_8_csp_csp - module function var_all_9_csp_csp(x, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + end function var_all_3_iint8_dp + module function var_all_4_iint8_dp(x, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:,:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected - real(sp) :: res + real(dp) :: res - real(sp) :: n - complex(sp) :: mean + real(dp) :: n, mean if (.not.optval(mask, .true.)) then - res = ieee_value(1._sp, ieee_quiet_nan) + res = ieee_value(1._dp, ieee_quiet_nan) return end if - n = real(size(x, kind = int64), sp) - mean = sum(x) / n + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n - res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_9_csp_csp - module function var_all_10_csp_csp(x, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + end function var_all_4_iint8_dp + module function var_all_5_iint8_dp(x, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected - real(sp) :: res + real(dp) :: res - real(sp) :: n - complex(sp) :: mean + real(dp) :: n, mean if (.not.optval(mask, .true.)) then - res = ieee_value(1._sp, ieee_quiet_nan) + res = ieee_value(1._dp, ieee_quiet_nan) return end if - n = real(size(x, kind = int64), sp) - mean = sum(x) / n + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n - res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_10_csp_csp - module function var_all_11_csp_csp(x, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + end function var_all_5_iint8_dp + module function var_all_6_iint8_dp(x, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected - real(sp) :: res + real(dp) :: res - real(sp) :: n - complex(sp) :: mean + real(dp) :: n, mean if (.not.optval(mask, .true.)) then - res = ieee_value(1._sp, ieee_quiet_nan) + res = ieee_value(1._dp, ieee_quiet_nan) return end if - n = real(size(x, kind = int64), sp) - mean = sum(x) / n + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n - res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_11_csp_csp - module function var_all_12_csp_csp(x, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + end function var_all_6_iint8_dp + module function var_all_7_iint8_dp(x, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected - real(sp) :: res + real(dp) :: res - real(sp) :: n - complex(sp) :: mean + real(dp) :: n, mean if (.not.optval(mask, .true.)) then - res = ieee_value(1._sp, ieee_quiet_nan) + res = ieee_value(1._dp, ieee_quiet_nan) return end if - n = real(size(x, kind = int64), sp) - mean = sum(x) / n + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n - res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_12_csp_csp - module function var_all_13_csp_csp(x, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + end function var_all_7_iint8_dp + module function var_all_1_iint16_dp(x, mask, corrected) result(res) + integer(int16), intent(in) :: x(:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected - real(sp) :: res + real(dp) :: res - real(sp) :: n - complex(sp) :: mean + real(dp) :: n, mean if (.not.optval(mask, .true.)) then - res = ieee_value(1._sp, ieee_quiet_nan) + res = ieee_value(1._dp, ieee_quiet_nan) return end if - n = real(size(x, kind = int64), sp) - mean = sum(x) / n + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n - res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_13_csp_csp - module function var_all_14_csp_csp(x, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function var_all_1_iint16_dp + module function var_all_2_iint16_dp(x, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected - real(sp) :: res + real(dp) :: res - real(sp) :: n - complex(sp) :: mean + real(dp) :: n, mean if (.not.optval(mask, .true.)) then - res = ieee_value(1._sp, ieee_quiet_nan) + res = ieee_value(1._dp, ieee_quiet_nan) return end if - n = real(size(x, kind = int64), sp) - mean = sum(x) / n + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n - res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_14_csp_csp - module function var_all_15_csp_csp(x, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function var_all_2_iint16_dp + module function var_all_3_iint16_dp(x, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected - real(sp) :: res + real(dp) :: res - real(sp) :: n - complex(sp) :: mean + real(dp) :: n, mean if (.not.optval(mask, .true.)) then - res = ieee_value(1._sp, ieee_quiet_nan) + res = ieee_value(1._dp, ieee_quiet_nan) return end if - n = real(size(x, kind = int64), sp) - mean = sum(x) / n + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n - res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_15_csp_csp - module function var_all_1_cdp_cdp(x, mask, corrected) result(res) - complex(dp), intent(in) :: x(:) + end function var_all_3_iint16_dp + module function var_all_4_iint16_dp(x, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:,:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected real(dp) :: res - real(dp) :: n - complex(dp) :: mean + real(dp) :: n, mean if (.not.optval(mask, .true.)) then res = ieee_value(1._dp, ieee_quiet_nan) @@ -1222,19 +1053,18 @@ module function var_all_1_cdp_cdp(x, mask, corrected) result(res) end if n = real(size(x, kind = int64), dp) - mean = sum(x) / n + mean = sum(real(x, dp)) / n - res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_1_cdp_cdp - module function var_all_2_cdp_cdp(x, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:) + end function var_all_4_iint16_dp + module function var_all_5_iint16_dp(x, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected real(dp) :: res - real(dp) :: n - complex(dp) :: mean + real(dp) :: n, mean if (.not.optval(mask, .true.)) then res = ieee_value(1._dp, ieee_quiet_nan) @@ -1242,19 +1072,18 @@ module function var_all_2_cdp_cdp(x, mask, corrected) result(res) end if n = real(size(x, kind = int64), dp) - mean = sum(x) / n + mean = sum(real(x, dp)) / n - res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_2_cdp_cdp - module function var_all_3_cdp_cdp(x, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:) + end function var_all_5_iint16_dp + module function var_all_6_iint16_dp(x, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected real(dp) :: res - real(dp) :: n - complex(dp) :: mean + real(dp) :: n, mean if (.not.optval(mask, .true.)) then res = ieee_value(1._dp, ieee_quiet_nan) @@ -1262,19 +1091,18 @@ module function var_all_3_cdp_cdp(x, mask, corrected) result(res) end if n = real(size(x, kind = int64), dp) - mean = sum(x) / n + mean = sum(real(x, dp)) / n - res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_3_cdp_cdp - module function var_all_4_cdp_cdp(x, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:,:) + end function var_all_6_iint16_dp + module function var_all_7_iint16_dp(x, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected real(dp) :: res - real(dp) :: n - complex(dp) :: mean + real(dp) :: n, mean if (.not.optval(mask, .true.)) then res = ieee_value(1._dp, ieee_quiet_nan) @@ -1282,19 +1110,18 @@ module function var_all_4_cdp_cdp(x, mask, corrected) result(res) end if n = real(size(x, kind = int64), dp) - mean = sum(x) / n + mean = sum(real(x, dp)) / n - res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_4_cdp_cdp - module function var_all_5_cdp_cdp(x, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:) + end function var_all_7_iint16_dp + module function var_all_1_iint32_dp(x, mask, corrected) result(res) + integer(int32), intent(in) :: x(:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected real(dp) :: res - real(dp) :: n - complex(dp) :: mean + real(dp) :: n, mean if (.not.optval(mask, .true.)) then res = ieee_value(1._dp, ieee_quiet_nan) @@ -1302,19 +1129,18 @@ module function var_all_5_cdp_cdp(x, mask, corrected) result(res) end if n = real(size(x, kind = int64), dp) - mean = sum(x) / n + mean = sum(real(x, dp)) / n - res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_5_cdp_cdp - module function var_all_6_cdp_cdp(x, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:) + end function var_all_1_iint32_dp + module function var_all_2_iint32_dp(x, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected real(dp) :: res - real(dp) :: n - complex(dp) :: mean + real(dp) :: n, mean if (.not.optval(mask, .true.)) then res = ieee_value(1._dp, ieee_quiet_nan) @@ -1322,19 +1148,18 @@ module function var_all_6_cdp_cdp(x, mask, corrected) result(res) end if n = real(size(x, kind = int64), dp) - mean = sum(x) / n + mean = sum(real(x, dp)) / n - res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_6_cdp_cdp - module function var_all_7_cdp_cdp(x, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:) + end function var_all_2_iint32_dp + module function var_all_3_iint32_dp(x, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected real(dp) :: res - real(dp) :: n - complex(dp) :: mean + real(dp) :: n, mean if (.not.optval(mask, .true.)) then res = ieee_value(1._dp, ieee_quiet_nan) @@ -1342,19 +1167,18 @@ module function var_all_7_cdp_cdp(x, mask, corrected) result(res) end if n = real(size(x, kind = int64), dp) - mean = sum(x) / n + mean = sum(real(x, dp)) / n - res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_7_cdp_cdp - module function var_all_8_cdp_cdp(x, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:) + end function var_all_3_iint32_dp + module function var_all_4_iint32_dp(x, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:,:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected real(dp) :: res - real(dp) :: n - complex(dp) :: mean + real(dp) :: n, mean if (.not.optval(mask, .true.)) then res = ieee_value(1._dp, ieee_quiet_nan) @@ -1362,19 +1186,18 @@ module function var_all_8_cdp_cdp(x, mask, corrected) result(res) end if n = real(size(x, kind = int64), dp) - mean = sum(x) / n + mean = sum(real(x, dp)) / n - res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_8_cdp_cdp - module function var_all_9_cdp_cdp(x, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:) + end function var_all_4_iint32_dp + module function var_all_5_iint32_dp(x, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected real(dp) :: res - real(dp) :: n - complex(dp) :: mean + real(dp) :: n, mean if (.not.optval(mask, .true.)) then res = ieee_value(1._dp, ieee_quiet_nan) @@ -1382,19 +1205,18 @@ module function var_all_9_cdp_cdp(x, mask, corrected) result(res) end if n = real(size(x, kind = int64), dp) - mean = sum(x) / n + mean = sum(real(x, dp)) / n - res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_9_cdp_cdp - module function var_all_10_cdp_cdp(x, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + end function var_all_5_iint32_dp + module function var_all_6_iint32_dp(x, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected real(dp) :: res - real(dp) :: n - complex(dp) :: mean + real(dp) :: n, mean if (.not.optval(mask, .true.)) then res = ieee_value(1._dp, ieee_quiet_nan) @@ -1402,19 +1224,18 @@ module function var_all_10_cdp_cdp(x, mask, corrected) result(res) end if n = real(size(x, kind = int64), dp) - mean = sum(x) / n + mean = sum(real(x, dp)) / n - res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_10_cdp_cdp - module function var_all_11_cdp_cdp(x, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + end function var_all_6_iint32_dp + module function var_all_7_iint32_dp(x, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected real(dp) :: res - real(dp) :: n - complex(dp) :: mean + real(dp) :: n, mean if (.not.optval(mask, .true.)) then res = ieee_value(1._dp, ieee_quiet_nan) @@ -1422,19 +1243,18 @@ module function var_all_11_cdp_cdp(x, mask, corrected) result(res) end if n = real(size(x, kind = int64), dp) - mean = sum(x) / n + mean = sum(real(x, dp)) / n - res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_11_cdp_cdp - module function var_all_12_cdp_cdp(x, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + end function var_all_7_iint32_dp + module function var_all_1_iint64_dp(x, mask, corrected) result(res) + integer(int64), intent(in) :: x(:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected real(dp) :: res - real(dp) :: n - complex(dp) :: mean + real(dp) :: n, mean if (.not.optval(mask, .true.)) then res = ieee_value(1._dp, ieee_quiet_nan) @@ -1442,19 +1262,18 @@ module function var_all_12_cdp_cdp(x, mask, corrected) result(res) end if n = real(size(x, kind = int64), dp) - mean = sum(x) / n + mean = sum(real(x, dp)) / n - res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_12_cdp_cdp - module function var_all_13_cdp_cdp(x, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + end function var_all_1_iint64_dp + module function var_all_2_iint64_dp(x, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected real(dp) :: res - real(dp) :: n - complex(dp) :: mean + real(dp) :: n, mean if (.not.optval(mask, .true.)) then res = ieee_value(1._dp, ieee_quiet_nan) @@ -1462,19 +1281,18 @@ module function var_all_13_cdp_cdp(x, mask, corrected) result(res) end if n = real(size(x, kind = int64), dp) - mean = sum(x) / n + mean = sum(real(x, dp)) / n - res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_13_cdp_cdp - module function var_all_14_cdp_cdp(x, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function var_all_2_iint64_dp + module function var_all_3_iint64_dp(x, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected real(dp) :: res - real(dp) :: n - complex(dp) :: mean + real(dp) :: n, mean if (.not.optval(mask, .true.)) then res = ieee_value(1._dp, ieee_quiet_nan) @@ -1482,19 +1300,18 @@ module function var_all_14_cdp_cdp(x, mask, corrected) result(res) end if n = real(size(x, kind = int64), dp) - mean = sum(x) / n + mean = sum(real(x, dp)) / n - res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_14_cdp_cdp - module function var_all_15_cdp_cdp(x, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function var_all_3_iint64_dp + module function var_all_4_iint64_dp(x, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:,:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected real(dp) :: res - real(dp) :: n - complex(dp) :: mean + real(dp) :: n, mean if (.not.optval(mask, .true.)) then res = ieee_value(1._dp, ieee_quiet_nan) @@ -1502,2613 +1319,3306 @@ module function var_all_15_cdp_cdp(x, mask, corrected) result(res) end if n = real(size(x, kind = int64), dp) - mean = sum(x) / n + mean = sum(real(x, dp)) / n - res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_15_cdp_cdp - module function var_all_1_cqp_cqp(x, mask, corrected) result(res) - complex(qp), intent(in) :: x(:) + end function var_all_4_iint64_dp + module function var_all_5_iint64_dp(x, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected - real(qp) :: res + real(dp) :: res - real(qp) :: n - complex(qp) :: mean + real(dp) :: n, mean if (.not.optval(mask, .true.)) then - res = ieee_value(1._qp, ieee_quiet_nan) + res = ieee_value(1._dp, ieee_quiet_nan) return end if - n = real(size(x, kind = int64), qp) - mean = sum(x) / n + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n - res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_1_cqp_cqp - module function var_all_2_cqp_cqp(x, mask, corrected) result(res) - complex(qp), intent(in) :: x(:,:) + end function var_all_5_iint64_dp + module function var_all_6_iint64_dp(x, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected - real(qp) :: res + real(dp) :: res - real(qp) :: n - complex(qp) :: mean + real(dp) :: n, mean if (.not.optval(mask, .true.)) then - res = ieee_value(1._qp, ieee_quiet_nan) + res = ieee_value(1._dp, ieee_quiet_nan) return end if - n = real(size(x, kind = int64), qp) - mean = sum(x) / n + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n - res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_2_cqp_cqp - module function var_all_3_cqp_cqp(x, mask, corrected) result(res) - complex(qp), intent(in) :: x(:,:,:) + end function var_all_6_iint64_dp + module function var_all_7_iint64_dp(x, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:) logical, intent(in), optional :: mask logical, intent(in), optional :: corrected - real(qp) :: res + real(dp) :: res - real(qp) :: n - complex(qp) :: mean + real(dp) :: n, mean if (.not.optval(mask, .true.)) then - res = ieee_value(1._qp, ieee_quiet_nan) + res = ieee_value(1._dp, ieee_quiet_nan) return end if - n = real(size(x, kind = int64), qp) - mean = sum(x) / n - - res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - - end function var_all_3_cqp_cqp - module function var_all_4_cqp_cqp(x, mask, corrected) result(res) - complex(qp), intent(in) :: x(:,:,:,:) - logical, intent(in), optional :: mask - logical, intent(in), optional :: corrected - real(qp) :: res - - real(qp) :: n - complex(qp) :: mean + n = real(size(x, kind = int64), dp) + mean = sum(real(x, dp)) / n - if (.not.optval(mask, .true.)) then - res = ieee_value(1._qp, ieee_quiet_nan) - return - end if + res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - n = real(size(x, kind = int64), qp) - mean = sum(x) / n + end function var_all_7_iint64_dp - res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_4_cqp_cqp - module function var_all_5_cqp_cqp(x, mask, corrected) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:) + module function var_1_rsp_rsp(x, dim, mask, corrected) result(res) + real(sp), intent(in) :: x(:) + integer, intent(in) :: dim logical, intent(in), optional :: mask logical, intent(in), optional :: corrected - real(qp) :: res + real(sp) :: res - real(qp) :: n - complex(qp) :: mean + integer :: i + real(sp) :: n + real(sp) :: mean if (.not.optval(mask, .true.)) then - res = ieee_value(1._qp, ieee_quiet_nan) + res = ieee_value(1._sp, ieee_quiet_nan) return end if - n = real(size(x, kind = int64), qp) - mean = sum(x) / n - - res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.))) + res = 0._sp + select case(dim) + case(1) + n = size(x, dim) + mean = sum(x, dim) / n + do i = 1, size(x, dim) + res = res + (x(i) - mean)**2 + end do + case default + call error_stop("ERROR (var): wrong dimension") + end select + res = res / (n - merge(1, 0, optval(corrected, .true.))) - end function var_all_5_cqp_cqp - module function var_all_6_cqp_cqp(x, mask, corrected) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:) + end function var_1_rsp_rsp + module function var_2_rsp_rsp(x, dim, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:) + integer, intent(in) :: dim logical, intent(in), optional :: mask logical, intent(in), optional :: corrected - real(qp) :: res + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_7_rdp_rdp - module function var_8_rdp_rdp(x, dim, mask, corrected) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + end function var_mask_all_1_rsp_rsp + module function var_mask_all_2_rsp_rsp(x, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:) + logical, intent(in) :: mask(:,:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_8_rdp_rdp - module function var_9_rdp_rdp(x, dim, mask, corrected) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + end function var_mask_all_2_rsp_rsp + module function var_mask_all_3_rsp_rsp(x, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:,:) + logical, intent(in) :: mask(:,:,:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_9_rdp_rdp - module function var_10_rdp_rdp(x, dim, mask, corrected) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + end function var_mask_all_3_rsp_rsp + module function var_mask_all_4_rsp_rsp(x, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:,:,:) + logical, intent(in) :: mask(:,:,:,:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_10_rdp_rdp - module function var_11_rdp_rdp(x, dim, mask, corrected) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + end function var_mask_all_4_rsp_rsp + module function var_mask_all_5_rsp_rsp(x, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_11_rdp_rdp - module function var_12_rdp_rdp(x, dim, mask, corrected) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + end function var_mask_all_5_rsp_rsp + module function var_mask_all_6_rsp_rsp(x, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_all_6_rsp_rsp + module function var_mask_all_7_rsp_rsp(x, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res + + real(sp) :: n + real(sp) :: mean + + n = real(count(mask, kind = int64), sp) + mean = sum(x, mask) / n + + res = sum((x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_7_rsp_rsp + module function var_mask_all_1_rdp_rdp(x, mask, corrected) result(res) + real(dp), intent(in) :: x(:) + logical, intent(in) :: mask(:) + logical, intent(in), optional :: corrected + real(dp) :: res - integer :: i real(dp) :: n - real(dp) :: mean(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_12_rdp_rdp - module function var_13_rdp_rdp(x, dim, mask, corrected) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + end function var_mask_all_1_rdp_rdp + module function var_mask_all_2_rdp_rdp(x, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:) + logical, intent(in) :: mask(:,:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_13_rdp_rdp - module function var_14_rdp_rdp(x, dim, mask, corrected) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + end function var_mask_all_2_rdp_rdp + module function var_mask_all_3_rdp_rdp(x, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:,:) + logical, intent(in) :: mask(:,:,:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_14_rdp_rdp - module function var_15_rdp_rdp(x, dim, mask, corrected) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + end function var_mask_all_3_rdp_rdp + module function var_mask_all_4_rdp_rdp(x, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:,:,:) + logical, intent(in) :: mask(:,:,:,:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_15_rdp_rdp - module function var_1_rqp_rqp(x, dim, mask, corrected) result(res) + end function var_mask_all_4_rdp_rdp + module function var_mask_all_5_rdp_rdp(x, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + real(dp) :: mean + + n = real(count(mask, kind = int64), dp) + mean = sum(x, mask) / n + + res = sum((x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_5_rdp_rdp + module function var_mask_all_6_rdp_rdp(x, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + real(dp) :: mean + + n = real(count(mask, kind = int64), dp) + mean = sum(x, mask) / n + + res = sum((x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_6_rdp_rdp + module function var_mask_all_7_rdp_rdp(x, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n + real(dp) :: mean + + n = real(count(mask, kind = int64), dp) + mean = sum(x, mask) / n + + res = sum((x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_7_rdp_rdp + module function var_mask_all_1_rqp_rqp(x, mask, corrected) result(res) real(qp), intent(in) :: x(:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + logical, intent(in) :: mask(:) logical, intent(in), optional :: corrected real(qp) :: res - integer :: i real(qp) :: n real(qp) :: mean - if (.not.optval(mask, .true.)) then - res = ieee_value(1._qp, ieee_quiet_nan) - return - end if + n = real(count(mask, kind = int64), qp) + mean = sum(x, mask) / n - res = 0._qp - select case(dim) - case(1) - n = size(x, dim) - mean = sum(x, dim) / n - do i = 1, size(x, dim) - res = res + (x(i) - mean)**2 - end do - case default - call error_stop("ERROR (var): wrong dimension") - end select - res = res / (n - merge(1, 0, optval(corrected, .true.))) + res = sum((x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - end function var_1_rqp_rqp - module function var_2_rqp_rqp(x, dim, mask, corrected) result(res) + end function var_mask_all_1_rqp_rqp + module function var_mask_all_2_rqp_rqp(x, mask, corrected) result(res) real(qp), intent(in) :: x(:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + logical, intent(in) :: mask(:,:) logical, intent(in), optional :: corrected - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_2_rqp_rqp - module function var_3_rqp_rqp(x, dim, mask, corrected) result(res) + end function var_mask_all_2_rqp_rqp + module function var_mask_all_3_rqp_rqp(x, mask, corrected) result(res) real(qp), intent(in) :: x(:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + logical, intent(in) :: mask(:,:,:) logical, intent(in), optional :: corrected - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_3_rqp_rqp - module function var_4_rqp_rqp(x, dim, mask, corrected) result(res) + end function var_mask_all_3_rqp_rqp + module function var_mask_all_4_rqp_rqp(x, mask, corrected) result(res) real(qp), intent(in) :: x(:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + logical, intent(in) :: mask(:,:,:,:) logical, intent(in), optional :: corrected - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_4_rqp_rqp - module function var_5_rqp_rqp(x, dim, mask, corrected) result(res) + end function var_mask_all_4_rqp_rqp + module function var_mask_all_5_rqp_rqp(x, mask, corrected) result(res) real(qp), intent(in) :: x(:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + logical, intent(in) :: mask(:,:,:,:,:) logical, intent(in), optional :: corrected - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_5_rqp_rqp - module function var_6_rqp_rqp(x, dim, mask, corrected) result(res) + end function var_mask_all_5_rqp_rqp + module function var_mask_all_6_rqp_rqp(x, mask, corrected) result(res) real(qp), intent(in) :: x(:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + logical, intent(in) :: mask(:,:,:,:,:,:) logical, intent(in), optional :: corrected - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_6_rqp_rqp - module function var_7_rqp_rqp(x, dim, mask, corrected) result(res) + end function var_mask_all_6_rqp_rqp + module function var_mask_all_7_rqp_rqp(x, mask, corrected) result(res) real(qp), intent(in) :: x(:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + logical, intent(in) :: mask(:,:,:,:,:,:,:) logical, intent(in), optional :: corrected - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_7_rqp_rqp - module function var_8_rqp_rqp(x, dim, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + end function var_mask_all_7_rqp_rqp + module function var_mask_all_1_csp_csp(x, mask, corrected) result(res) + complex(sp), intent(in) :: x(:) + logical, intent(in) :: mask(:) logical, intent(in), optional :: corrected - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_8_rqp_rqp - module function var_9_rqp_rqp(x, dim, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + end function var_mask_all_1_csp_csp + module function var_mask_all_2_csp_csp(x, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:) + logical, intent(in) :: mask(:,:) logical, intent(in), optional :: corrected - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_9_rqp_rqp - module function var_10_rqp_rqp(x, dim, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + end function var_mask_all_2_csp_csp + module function var_mask_all_3_csp_csp(x, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:) + logical, intent(in) :: mask(:,:,:) logical, intent(in), optional :: corrected - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_10_rqp_rqp - module function var_11_rqp_rqp(x, dim, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + end function var_mask_all_3_csp_csp + module function var_mask_all_4_csp_csp(x, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:,:) + logical, intent(in) :: mask(:,:,:,:) logical, intent(in), optional :: corrected - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_11_rqp_rqp - module function var_12_rqp_rqp(x, dim, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + end function var_mask_all_4_csp_csp + module function var_mask_all_5_csp_csp(x, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:) logical, intent(in), optional :: corrected - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_12_rqp_rqp - module function var_13_rqp_rqp(x, dim, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + end function var_mask_all_5_csp_csp + module function var_mask_all_6_csp_csp(x, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:) logical, intent(in), optional :: corrected - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_13_rqp_rqp - module function var_14_rqp_rqp(x, dim, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + end function var_mask_all_6_csp_csp + module function var_mask_all_7_csp_csp(x, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:) logical, intent(in), optional :: corrected - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_14_rqp_rqp - module function var_15_rqp_rqp(x, dim, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + end function var_mask_all_7_csp_csp + module function var_mask_all_1_cdp_cdp(x, mask, corrected) result(res) + complex(dp), intent(in) :: x(:) + logical, intent(in) :: mask(:) logical, intent(in), optional :: corrected - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_15_rqp_rqp - module function var_1_csp_csp(x, dim, mask, corrected) result(res) - complex(sp), intent(in) :: x(:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + end function var_mask_all_1_cdp_cdp + module function var_mask_all_2_cdp_cdp(x, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:) + logical, intent(in) :: mask(:,:) logical, intent(in), optional :: corrected - real(sp) :: res + real(dp) :: res - integer :: i - real(sp) :: n - complex(sp) :: mean + real(dp) :: n + complex(dp) :: mean - if (.not.optval(mask, .true.)) then - res = ieee_value(1._sp, ieee_quiet_nan) - return - end if + n = real(count(mask, kind = int64), dp) + mean = sum(x, mask) / n - res = 0._sp - select case(dim) - case(1) - n = size(x, dim) - mean = sum(x, dim) / n - do i = 1, size(x, dim) - res = res + abs(x(i) - mean)**2 - end do - case default - call error_stop("ERROR (var): wrong dimension") - end select - res = res / (n - merge(1, 0, optval(corrected, .true.))) + res = sum(abs(x - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - end function var_1_csp_csp - module function var_2_csp_csp(x, dim, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + end function var_mask_all_2_cdp_cdp + module function var_mask_all_3_cdp_cdp(x, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:) + logical, intent(in) :: mask(:,:,:) logical, intent(in), optional :: corrected - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_2_csp_csp - module function var_3_csp_csp(x, dim, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + end function var_mask_all_3_cdp_cdp + module function var_mask_all_4_cdp_cdp(x, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:,:) + logical, intent(in) :: mask(:,:,:,:) logical, intent(in), optional :: corrected - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_3_csp_csp - module function var_4_csp_csp(x, dim, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + end function var_mask_all_4_cdp_cdp + module function var_mask_all_5_cdp_cdp(x, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:) logical, intent(in), optional :: corrected - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_4_csp_csp - module function var_5_csp_csp(x, dim, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + end function var_mask_all_5_cdp_cdp + module function var_mask_all_6_cdp_cdp(x, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:) logical, intent(in), optional :: corrected - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_5_csp_csp - module function var_6_csp_csp(x, dim, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + end function var_mask_all_6_cdp_cdp + module function var_mask_all_7_cdp_cdp(x, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:) logical, intent(in), optional :: corrected - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_6_csp_csp - module function var_7_csp_csp(x, dim, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + end function var_mask_all_7_cdp_cdp + module function var_mask_all_1_cqp_cqp(x, mask, corrected) result(res) + complex(qp), intent(in) :: x(:) + logical, intent(in) :: mask(:) logical, intent(in), optional :: corrected - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_7_csp_csp - module function var_8_csp_csp(x, dim, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + end function var_mask_all_1_cqp_cqp + module function var_mask_all_2_cqp_cqp(x, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:) + logical, intent(in) :: mask(:,:) logical, intent(in), optional :: corrected - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_8_csp_csp - module function var_9_csp_csp(x, dim, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + end function var_mask_all_2_cqp_cqp + module function var_mask_all_3_cqp_cqp(x, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:) + logical, intent(in) :: mask(:,:,:) logical, intent(in), optional :: corrected - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_9_csp_csp - module function var_10_csp_csp(x, dim, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + end function var_mask_all_3_cqp_cqp + module function var_mask_all_4_cqp_cqp(x, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:,:) + logical, intent(in) :: mask(:,:,:,:) logical, intent(in), optional :: corrected - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_10_csp_csp - module function var_11_csp_csp(x, dim, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + end function var_mask_all_4_cqp_cqp + module function var_mask_all_5_cqp_cqp(x, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:) logical, intent(in), optional :: corrected - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_11_csp_csp - module function var_12_csp_csp(x, dim, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + end function var_mask_all_5_cqp_cqp + module function var_mask_all_6_cqp_cqp(x, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:) logical, intent(in), optional :: corrected - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_12_csp_csp - module function var_13_csp_csp(x, dim, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + end function var_mask_all_6_cqp_cqp + module function var_mask_all_7_cqp_cqp(x, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:) logical, intent(in), optional :: corrected - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_13_csp_csp - module function var_14_csp_csp(x, dim, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + end function var_mask_all_7_cqp_cqp + + + module function var_mask_all_1_iint8_dp(x, mask, corrected) result(res) + integer(int8), intent(in) :: x(:) + logical, intent(in) :: mask(:) logical, intent(in), optional :: corrected - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_14_csp_csp - module function var_15_csp_csp(x, dim, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + end function var_mask_all_1_iint8_dp + module function var_mask_all_2_iint8_dp(x, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:) + logical, intent(in) :: mask(:,:) logical, intent(in), optional :: corrected - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_15_csp_csp - module function var_1_cdp_cdp(x, dim, mask, corrected) result(res) - complex(dp), intent(in) :: x(:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + end function var_mask_all_2_iint8_dp + module function var_mask_all_3_iint8_dp(x, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:) + logical, intent(in) :: mask(:,:,:) logical, intent(in), optional :: corrected real(dp) :: res - integer :: i - real(dp) :: n - complex(dp) :: mean + real(dp) :: n, mean - if (.not.optval(mask, .true.)) then - res = ieee_value(1._dp, ieee_quiet_nan) - return - end if + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n - res = 0._dp - select case(dim) - case(1) - n = size(x, dim) - mean = sum(x, dim) / n - do i = 1, size(x, dim) - res = res + abs(x(i) - mean)**2 - end do - case default - call error_stop("ERROR (var): wrong dimension") - end select - res = res / (n - merge(1, 0, optval(corrected, .true.))) + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - end function var_1_cdp_cdp - module function var_2_cdp_cdp(x, dim, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + end function var_mask_all_3_iint8_dp + module function var_mask_all_4_iint8_dp(x, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:,:) + logical, intent(in) :: mask(:,:,:,:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_2_cdp_cdp - module function var_3_cdp_cdp(x, dim, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + end function var_mask_all_4_iint8_dp + module function var_mask_all_5_iint8_dp(x, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_3_cdp_cdp - module function var_4_cdp_cdp(x, dim, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask - logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_4_cdp_cdp - module function var_5_cdp_cdp(x, dim, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + end function var_mask_all_6_iint8_dp + module function var_mask_all_7_iint8_dp(x, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_5_cdp_cdp - module function var_6_cdp_cdp(x, dim, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + end function var_mask_all_7_iint8_dp + module function var_mask_all_1_iint16_dp(x, mask, corrected) result(res) + integer(int16), intent(in) :: x(:) + logical, intent(in) :: mask(:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_6_cdp_cdp - module function var_7_cdp_cdp(x, dim, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + end function var_mask_all_1_iint16_dp + module function var_mask_all_2_iint16_dp(x, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:) + logical, intent(in) :: mask(:,:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_7_cdp_cdp - module function var_8_cdp_cdp(x, dim, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + end function var_mask_all_2_iint16_dp + module function var_mask_all_3_iint16_dp(x, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:) + logical, intent(in) :: mask(:,:,:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_8_cdp_cdp - module function var_9_cdp_cdp(x, dim, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + end function var_mask_all_3_iint16_dp + module function var_mask_all_4_iint16_dp(x, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:,:) + logical, intent(in) :: mask(:,:,:,:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_9_cdp_cdp - module function var_10_cdp_cdp(x, dim, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + end function var_mask_all_4_iint16_dp + module function var_mask_all_5_iint16_dp(x, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_10_cdp_cdp - module function var_11_cdp_cdp(x, dim, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + end function var_mask_all_5_iint16_dp + module function var_mask_all_6_iint16_dp(x, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_11_cdp_cdp - module function var_12_cdp_cdp(x, dim, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + end function var_mask_all_6_iint16_dp + module function var_mask_all_7_iint16_dp(x, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_12_cdp_cdp - module function var_13_cdp_cdp(x, dim, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + end function var_mask_all_7_iint16_dp + module function var_mask_all_1_iint32_dp(x, mask, corrected) result(res) + integer(int32), intent(in) :: x(:) + logical, intent(in) :: mask(:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_13_cdp_cdp - module function var_14_cdp_cdp(x, dim, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + end function var_mask_all_1_iint32_dp + module function var_mask_all_2_iint32_dp(x, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:) + logical, intent(in) :: mask(:,:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_1_cqp_cqp - module function var_2_cqp_cqp(x, dim, mask, corrected) result(res) - complex(qp), intent(in) :: x(:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + end function var_mask_all_2_iint32_dp + module function var_mask_all_3_iint32_dp(x, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:) + logical, intent(in) :: mask(:,:,:) logical, intent(in), optional :: corrected - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_2_cqp_cqp - module function var_3_cqp_cqp(x, dim, mask, corrected) result(res) - complex(qp), intent(in) :: x(:,:,:) - integer, intent(in) :: dim - logical, intent(in), optional :: mask + end function var_mask_all_3_iint32_dp + module function var_mask_all_4_iint32_dp(x, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:,:) + logical, intent(in) :: mask(:,:,:,:) logical, intent(in), optional :: corrected - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - integer :: i - real(qp) :: n - complex(qp) :: mean(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_all_1_rsp_rsp - module function var_mask_all_2_rsp_rsp(x, mask, corrected) result(res) - real(sp), intent(in) :: x(:,:) - logical, intent(in) :: mask(:,:) - logical, intent(in), optional :: corrected - real(sp) :: res - - real(sp) :: n - real(sp) :: mean - - n = real(count(mask, kind = int64), sp) - mean = sum(x, mask) / n - - res = sum((x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_2_rsp_rsp - module function var_mask_all_3_rsp_rsp(x, mask, corrected) result(res) - real(sp), intent(in) :: x(:,:,:) - logical, intent(in) :: mask(:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res - - real(sp) :: n - real(sp) :: mean - - n = real(count(mask, kind = int64), sp) - mean = sum(x, mask) / n - - res = sum((x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_3_rsp_rsp - module function var_mask_all_4_rsp_rsp(x, mask, corrected) result(res) - real(sp), intent(in) :: x(:,:,:,:) - logical, intent(in) :: mask(:,:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res - - real(sp) :: n - real(sp) :: mean - - n = real(count(mask, kind = int64), sp) - mean = sum(x, mask) / n - - res = sum((x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_4_rsp_rsp - module function var_mask_all_5_rsp_rsp(x, mask, corrected) result(res) - real(sp), intent(in) :: x(:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res - - real(sp) :: n - real(sp) :: mean - - n = real(count(mask, kind = int64), sp) - mean = sum(x, mask) / n - - res = sum((x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_5_rsp_rsp - module function var_mask_all_6_rsp_rsp(x, mask, corrected) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res - - real(sp) :: n - real(sp) :: mean - - n = real(count(mask, kind = int64), sp) - mean = sum(x, mask) / n - - res = sum((x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_6_rsp_rsp - module function var_mask_all_7_rsp_rsp(x, mask, corrected) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res - - real(sp) :: n - real(sp) :: mean - - n = real(count(mask, kind = int64), sp) - mean = sum(x, mask) / n - - res = sum((x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_7_rsp_rsp - module function var_mask_all_8_rsp_rsp(x, mask, corrected) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res - - real(sp) :: n - real(sp) :: mean - - n = real(count(mask, kind = int64), sp) - mean = sum(x, mask) / n - - res = sum((x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_8_rsp_rsp - module function var_mask_all_9_rsp_rsp(x, mask, corrected) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res - - real(sp) :: n - real(sp) :: mean - - n = real(count(mask, kind = int64), sp) - mean = sum(x, mask) / n - - res = sum((x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_9_rsp_rsp - module function var_mask_all_10_rsp_rsp(x, mask, corrected) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res - - real(sp) :: n - real(sp) :: mean - - n = real(count(mask, kind = int64), sp) - mean = sum(x, mask) / n - - res = sum((x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_10_rsp_rsp - module function var_mask_all_11_rsp_rsp(x, mask, corrected) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res - - real(sp) :: n - real(sp) :: mean - - n = real(count(mask, kind = int64), sp) - mean = sum(x, mask) / n - - res = sum((x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_11_rsp_rsp - module function var_mask_all_12_rsp_rsp(x, mask, corrected) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res - - real(sp) :: n - real(sp) :: mean - - n = real(count(mask, kind = int64), sp) - mean = sum(x, mask) / n - - res = sum((x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_12_rsp_rsp - module function var_mask_all_13_rsp_rsp(x, mask, corrected) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res - - real(sp) :: n - real(sp) :: mean - - n = real(count(mask, kind = int64), sp) - mean = sum(x, mask) / n - - res = sum((x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_13_rsp_rsp - module function var_mask_all_14_rsp_rsp(x, mask, corrected) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res - - real(sp) :: n - real(sp) :: mean - - n = real(count(mask, kind = int64), sp) - mean = sum(x, mask) / n - - res = sum((x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_14_rsp_rsp - module function var_mask_all_15_rsp_rsp(x, mask, corrected) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res - - real(sp) :: n - real(sp) :: mean - - n = real(count(mask, kind = int64), sp) - mean = sum(x, mask) / n - - res = sum((x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_15_rsp_rsp - module function var_mask_all_1_rdp_rdp(x, mask, corrected) result(res) - real(dp), intent(in) :: x(:) - logical, intent(in) :: mask(:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n - real(dp) :: mean - - n = real(count(mask, kind = int64), dp) - mean = sum(x, mask) / n - - res = sum((x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_1_rdp_rdp - module function var_mask_all_2_rdp_rdp(x, mask, corrected) result(res) - real(dp), intent(in) :: x(:,:) - logical, intent(in) :: mask(:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n - real(dp) :: mean - - n = real(count(mask, kind = int64), dp) - mean = sum(x, mask) / n - - res = sum((x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_2_rdp_rdp - module function var_mask_all_3_rdp_rdp(x, mask, corrected) result(res) - real(dp), intent(in) :: x(:,:,:) - logical, intent(in) :: mask(:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n - real(dp) :: mean - - n = real(count(mask, kind = int64), dp) - mean = sum(x, mask) / n - - res = sum((x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_3_rdp_rdp - module function var_mask_all_4_rdp_rdp(x, mask, corrected) result(res) - real(dp), intent(in) :: x(:,:,:,:) - logical, intent(in) :: mask(:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n - real(dp) :: mean - - n = real(count(mask, kind = int64), dp) - mean = sum(x, mask) / n - - res = sum((x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_4_rdp_rdp - module function var_mask_all_5_rdp_rdp(x, mask, corrected) result(res) - real(dp), intent(in) :: x(:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n - real(dp) :: mean - - n = real(count(mask, kind = int64), dp) - mean = sum(x, mask) / n - - res = sum((x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_5_rdp_rdp - module function var_mask_all_6_rdp_rdp(x, mask, corrected) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n - real(dp) :: mean - - n = real(count(mask, kind = int64), dp) - mean = sum(x, mask) / n - - res = sum((x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_6_rdp_rdp - module function var_mask_all_7_rdp_rdp(x, mask, corrected) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n - real(dp) :: mean - - n = real(count(mask, kind = int64), dp) - mean = sum(x, mask) / n - - res = sum((x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_7_rdp_rdp - module function var_mask_all_8_rdp_rdp(x, mask, corrected) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n - real(dp) :: mean - - n = real(count(mask, kind = int64), dp) - mean = sum(x, mask) / n - - res = sum((x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_8_rdp_rdp - module function var_mask_all_9_rdp_rdp(x, mask, corrected) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n - real(dp) :: mean - - n = real(count(mask, kind = int64), dp) - mean = sum(x, mask) / n - - res = sum((x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_9_rdp_rdp - module function var_mask_all_10_rdp_rdp(x, mask, corrected) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n - real(dp) :: mean - - n = real(count(mask, kind = int64), dp) - mean = sum(x, mask) / n - - res = sum((x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_10_rdp_rdp - module function var_mask_all_11_rdp_rdp(x, mask, corrected) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n - real(dp) :: mean - - n = real(count(mask, kind = int64), dp) - mean = sum(x, mask) / n - - res = sum((x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_11_rdp_rdp - module function var_mask_all_12_rdp_rdp(x, mask, corrected) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n - real(dp) :: mean - - n = real(count(mask, kind = int64), dp) - mean = sum(x, mask) / n - - res = sum((x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_12_rdp_rdp - module function var_mask_all_13_rdp_rdp(x, mask, corrected) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n - real(dp) :: mean - - n = real(count(mask, kind = int64), dp) - mean = sum(x, mask) / n - - res = sum((x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_13_rdp_rdp - module function var_mask_all_14_rdp_rdp(x, mask, corrected) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n - real(dp) :: mean - - n = real(count(mask, kind = int64), dp) - mean = sum(x, mask) / n - - res = sum((x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_14_rdp_rdp - module function var_mask_all_15_rdp_rdp(x, mask, corrected) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n - real(dp) :: mean - - n = real(count(mask, kind = int64), dp) - mean = sum(x, mask) / n - - res = sum((x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_15_rdp_rdp - module function var_mask_all_1_rqp_rqp(x, mask, corrected) result(res) - real(qp), intent(in) :: x(:) - logical, intent(in) :: mask(:) - logical, intent(in), optional :: corrected - real(qp) :: res - - real(qp) :: n - real(qp) :: mean - - n = real(count(mask, kind = int64), qp) - mean = sum(x, mask) / n - - res = sum((x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_1_rqp_rqp - module function var_mask_all_2_rqp_rqp(x, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:) - logical, intent(in) :: mask(:,:) - logical, intent(in), optional :: corrected - real(qp) :: res - - real(qp) :: n - real(qp) :: mean - - n = real(count(mask, kind = int64), qp) - mean = sum(x, mask) / n - - res = sum((x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_2_rqp_rqp - module function var_mask_all_3_rqp_rqp(x, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:,:) - logical, intent(in) :: mask(:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res - - real(qp) :: n - real(qp) :: mean - - n = real(count(mask, kind = int64), qp) - mean = sum(x, mask) / n - - res = sum((x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_3_rqp_rqp - module function var_mask_all_4_rqp_rqp(x, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:,:,:) - logical, intent(in) :: mask(:,:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res - - real(qp) :: n - real(qp) :: mean - - n = real(count(mask, kind = int64), qp) - mean = sum(x, mask) / n - - res = sum((x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_4_rqp_rqp - module function var_mask_all_5_rqp_rqp(x, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res - - real(qp) :: n - real(qp) :: mean - - n = real(count(mask, kind = int64), qp) - mean = sum(x, mask) / n - - res = sum((x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_5_rqp_rqp - module function var_mask_all_6_rqp_rqp(x, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res - - real(qp) :: n - real(qp) :: mean - - n = real(count(mask, kind = int64), qp) - mean = sum(x, mask) / n - - res = sum((x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_6_rqp_rqp - module function var_mask_all_7_rqp_rqp(x, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res - - real(qp) :: n - real(qp) :: mean - - n = real(count(mask, kind = int64), qp) - mean = sum(x, mask) / n - - res = sum((x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_7_rqp_rqp - module function var_mask_all_8_rqp_rqp(x, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res - - real(qp) :: n - real(qp) :: mean - - n = real(count(mask, kind = int64), qp) - mean = sum(x, mask) / n - - res = sum((x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_8_rqp_rqp - module function var_mask_all_9_rqp_rqp(x, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res - - real(qp) :: n - real(qp) :: mean - - n = real(count(mask, kind = int64), qp) - mean = sum(x, mask) / n - - res = sum((x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_9_rqp_rqp - module function var_mask_all_10_rqp_rqp(x, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res - - real(qp) :: n - real(qp) :: mean - - n = real(count(mask, kind = int64), qp) - mean = sum(x, mask) / n - - res = sum((x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_10_rqp_rqp - module function var_mask_all_11_rqp_rqp(x, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res - - real(qp) :: n - real(qp) :: mean - - n = real(count(mask, kind = int64), qp) - mean = sum(x, mask) / n - - res = sum((x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_11_rqp_rqp - module function var_mask_all_12_rqp_rqp(x, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res - - real(qp) :: n - real(qp) :: mean - - n = real(count(mask, kind = int64), qp) - mean = sum(x, mask) / n - - res = sum((x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_12_rqp_rqp - module function var_mask_all_13_rqp_rqp(x, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res - - real(qp) :: n - real(qp) :: mean - - n = real(count(mask, kind = int64), qp) - mean = sum(x, mask) / n - - res = sum((x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_13_rqp_rqp - module function var_mask_all_14_rqp_rqp(x, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res - - real(qp) :: n - real(qp) :: mean - - n = real(count(mask, kind = int64), qp) - mean = sum(x, mask) / n - - res = sum((x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_14_rqp_rqp - module function var_mask_all_15_rqp_rqp(x, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res - - real(qp) :: n - real(qp) :: mean - - n = real(count(mask, kind = int64), qp) - mean = sum(x, mask) / n - - res = sum((x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_15_rqp_rqp - module function var_mask_all_1_csp_csp(x, mask, corrected) result(res) - complex(sp), intent(in) :: x(:) - logical, intent(in) :: mask(:) - logical, intent(in), optional :: corrected - real(sp) :: res - - real(sp) :: n - complex(sp) :: mean - - n = real(count(mask, kind = int64), sp) - mean = sum(x, mask) / n - - res = sum(abs(x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_1_csp_csp - module function var_mask_all_2_csp_csp(x, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:) - logical, intent(in) :: mask(:,:) - logical, intent(in), optional :: corrected - real(sp) :: res - - real(sp) :: n - complex(sp) :: mean - - n = real(count(mask, kind = int64), sp) - mean = sum(x, mask) / n - - res = sum(abs(x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_2_csp_csp - module function var_mask_all_3_csp_csp(x, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:) - logical, intent(in) :: mask(:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res - - real(sp) :: n - complex(sp) :: mean - - n = real(count(mask, kind = int64), sp) - mean = sum(x, mask) / n - - res = sum(abs(x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_3_csp_csp - module function var_mask_all_4_csp_csp(x, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:,:) - logical, intent(in) :: mask(:,:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res - - real(sp) :: n - complex(sp) :: mean - - n = real(count(mask, kind = int64), sp) - mean = sum(x, mask) / n - - res = sum(abs(x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_4_csp_csp - module function var_mask_all_5_csp_csp(x, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res - - real(sp) :: n - complex(sp) :: mean - - n = real(count(mask, kind = int64), sp) - mean = sum(x, mask) / n - - res = sum(abs(x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_5_csp_csp - module function var_mask_all_6_csp_csp(x, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res - - real(sp) :: n - complex(sp) :: mean - - n = real(count(mask, kind = int64), sp) - mean = sum(x, mask) / n - - res = sum(abs(x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_6_csp_csp - module function var_mask_all_7_csp_csp(x, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res - - real(sp) :: n - complex(sp) :: mean - - n = real(count(mask, kind = int64), sp) - mean = sum(x, mask) / n - - res = sum(abs(x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_7_csp_csp - module function var_mask_all_8_csp_csp(x, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res - - real(sp) :: n - complex(sp) :: mean - - n = real(count(mask, kind = int64), sp) - mean = sum(x, mask) / n - - res = sum(abs(x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_8_csp_csp - module function var_mask_all_9_csp_csp(x, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res - - real(sp) :: n - complex(sp) :: mean - - n = real(count(mask, kind = int64), sp) - mean = sum(x, mask) / n - - res = sum(abs(x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_9_csp_csp - module function var_mask_all_10_csp_csp(x, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res - - real(sp) :: n - complex(sp) :: mean - - n = real(count(mask, kind = int64), sp) - mean = sum(x, mask) / n - - res = sum(abs(x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_10_csp_csp - module function var_mask_all_11_csp_csp(x, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res - - real(sp) :: n - complex(sp) :: mean - - n = real(count(mask, kind = int64), sp) - mean = sum(x, mask) / n - - res = sum(abs(x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_11_csp_csp - module function var_mask_all_12_csp_csp(x, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res - - real(sp) :: n - complex(sp) :: mean - - n = real(count(mask, kind = int64), sp) - mean = sum(x, mask) / n - - res = sum(abs(x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_12_csp_csp - module function var_mask_all_13_csp_csp(x, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res - - real(sp) :: n - complex(sp) :: mean - - n = real(count(mask, kind = int64), sp) - mean = sum(x, mask) / n - - res = sum(abs(x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_13_csp_csp - module function var_mask_all_14_csp_csp(x, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res - - real(sp) :: n - complex(sp) :: mean - - n = real(count(mask, kind = int64), sp) - mean = sum(x, mask) / n - - res = sum(abs(x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_14_csp_csp - module function var_mask_all_15_csp_csp(x, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res - - real(sp) :: n - complex(sp) :: mean - - n = real(count(mask, kind = int64), sp) - mean = sum(x, mask) / n - - res = sum(abs(x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_15_csp_csp - module function var_mask_all_1_cdp_cdp(x, mask, corrected) result(res) - complex(dp), intent(in) :: x(:) - logical, intent(in) :: mask(:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n - complex(dp) :: mean - - n = real(count(mask, kind = int64), dp) - mean = sum(x, mask) / n - - res = sum(abs(x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_1_cdp_cdp - module function var_mask_all_2_cdp_cdp(x, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:) - logical, intent(in) :: mask(:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n - complex(dp) :: mean - - n = real(count(mask, kind = int64), dp) - mean = sum(x, mask) / n - - res = sum(abs(x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_2_cdp_cdp - module function var_mask_all_3_cdp_cdp(x, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:) - logical, intent(in) :: mask(:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n - complex(dp) :: mean - - n = real(count(mask, kind = int64), dp) - mean = sum(x, mask) / n - - res = sum(abs(x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_3_cdp_cdp - module function var_mask_all_4_cdp_cdp(x, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:,:) - logical, intent(in) :: mask(:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n - complex(dp) :: mean - - n = real(count(mask, kind = int64), dp) - mean = sum(x, mask) / n - - res = sum(abs(x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_4_cdp_cdp - module function var_mask_all_5_cdp_cdp(x, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n - complex(dp) :: mean - - n = real(count(mask, kind = int64), dp) - mean = sum(x, mask) / n - - res = sum(abs(x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_5_cdp_cdp - module function var_mask_all_6_cdp_cdp(x, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n - complex(dp) :: mean - - n = real(count(mask, kind = int64), dp) - mean = sum(x, mask) / n - - res = sum(abs(x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_6_cdp_cdp - module function var_mask_all_7_cdp_cdp(x, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n - complex(dp) :: mean - - n = real(count(mask, kind = int64), dp) - mean = sum(x, mask) / n - - res = sum(abs(x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_7_cdp_cdp - module function var_mask_all_8_cdp_cdp(x, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n - complex(dp) :: mean - - n = real(count(mask, kind = int64), dp) - mean = sum(x, mask) / n - - res = sum(abs(x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_8_cdp_cdp - module function var_mask_all_9_cdp_cdp(x, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n - complex(dp) :: mean - - n = real(count(mask, kind = int64), dp) - mean = sum(x, mask) / n - - res = sum(abs(x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_9_cdp_cdp - module function var_mask_all_10_cdp_cdp(x, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n - complex(dp) :: mean - - n = real(count(mask, kind = int64), dp) - mean = sum(x, mask) / n - - res = sum(abs(x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_10_cdp_cdp - module function var_mask_all_11_cdp_cdp(x, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n - complex(dp) :: mean - - n = real(count(mask, kind = int64), dp) - mean = sum(x, mask) / n - - res = sum(abs(x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_11_cdp_cdp - module function var_mask_all_12_cdp_cdp(x, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n - complex(dp) :: mean - - n = real(count(mask, kind = int64), dp) - mean = sum(x, mask) / n - - res = sum(abs(x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_12_cdp_cdp - module function var_mask_all_13_cdp_cdp(x, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n - complex(dp) :: mean - - n = real(count(mask, kind = int64), dp) - mean = sum(x, mask) / n - - res = sum(abs(x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_13_cdp_cdp - module function var_mask_all_14_cdp_cdp(x, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n - complex(dp) :: mean - - n = real(count(mask, kind = int64), dp) - mean = sum(x, mask) / n - - res = sum(abs(x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_14_cdp_cdp - module function var_mask_all_15_cdp_cdp(x, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n - complex(dp) :: mean - - n = real(count(mask, kind = int64), dp) - mean = sum(x, mask) / n - - res = sum(abs(x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_15_cdp_cdp - module function var_mask_all_1_cqp_cqp(x, mask, corrected) result(res) - complex(qp), intent(in) :: x(:) - logical, intent(in) :: mask(:) - logical, intent(in), optional :: corrected - real(qp) :: res - - real(qp) :: n - complex(qp) :: mean - - n = real(count(mask, kind = int64), qp) - mean = sum(x, mask) / n - - res = sum(abs(x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_1_cqp_cqp - module function var_mask_all_2_cqp_cqp(x, mask, corrected) result(res) - complex(qp), intent(in) :: x(:,:) - logical, intent(in) :: mask(:,:) - logical, intent(in), optional :: corrected - real(qp) :: res - - real(qp) :: n - complex(qp) :: mean - - n = real(count(mask, kind = int64), qp) - mean = sum(x, mask) / n - - res = sum(abs(x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_2_cqp_cqp - module function var_mask_all_3_cqp_cqp(x, mask, corrected) result(res) - complex(qp), intent(in) :: x(:,:,:) - logical, intent(in) :: mask(:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res - - real(qp) :: n - complex(qp) :: mean - - n = real(count(mask, kind = int64), qp) - mean = sum(x, mask) / n - - res = sum(abs(x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_3_cqp_cqp - module function var_mask_all_4_cqp_cqp(x, mask, corrected) result(res) - complex(qp), intent(in) :: x(:,:,:,:) - logical, intent(in) :: mask(:,:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res - - real(qp) :: n - complex(qp) :: mean - - n = real(count(mask, kind = int64), qp) - mean = sum(x, mask) / n - - res = sum(abs(x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_4_cqp_cqp - module function var_mask_all_5_cqp_cqp(x, mask, corrected) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res - - real(qp) :: n - complex(qp) :: mean - - n = real(count(mask, kind = int64), qp) - mean = sum(x, mask) / n - - res = sum(abs(x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_5_cqp_cqp - module function var_mask_all_6_cqp_cqp(x, mask, corrected) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res - - real(qp) :: n - complex(qp) :: mean - - n = real(count(mask, kind = int64), qp) - mean = sum(x, mask) / n - - res = sum(abs(x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_6_cqp_cqp - module function var_mask_all_7_cqp_cqp(x, mask, corrected) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res - - real(qp) :: n - complex(qp) :: mean - - n = real(count(mask, kind = int64), qp) - mean = sum(x, mask) / n - - res = sum(abs(x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_7_cqp_cqp - module function var_mask_all_8_cqp_cqp(x, mask, corrected) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res - - real(qp) :: n - complex(qp) :: mean - - n = real(count(mask, kind = int64), qp) - mean = sum(x, mask) / n - - res = sum(abs(x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_8_cqp_cqp - module function var_mask_all_9_cqp_cqp(x, mask, corrected) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res - - real(qp) :: n - complex(qp) :: mean - - n = real(count(mask, kind = int64), qp) - mean = sum(x, mask) / n - - res = sum(abs(x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_9_cqp_cqp - module function var_mask_all_10_cqp_cqp(x, mask, corrected) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res - - real(qp) :: n - complex(qp) :: mean - - n = real(count(mask, kind = int64), qp) - mean = sum(x, mask) / n - - res = sum(abs(x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_10_cqp_cqp - module function var_mask_all_11_cqp_cqp(x, mask, corrected) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res - - real(qp) :: n - complex(qp) :: mean - - n = real(count(mask, kind = int64), qp) - mean = sum(x, mask) / n - - res = sum(abs(x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_11_cqp_cqp - module function var_mask_all_12_cqp_cqp(x, mask, corrected) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res - - real(qp) :: n - complex(qp) :: mean - - n = real(count(mask, kind = int64), qp) - mean = sum(x, mask) / n - - res = sum(abs(x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_12_cqp_cqp - module function var_mask_all_13_cqp_cqp(x, mask, corrected) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res - - real(qp) :: n - complex(qp) :: mean - - n = real(count(mask, kind = int64), qp) - mean = sum(x, mask) / n - - res = sum(abs(x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_13_cqp_cqp - module function var_mask_all_14_cqp_cqp(x, mask, corrected) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res - - real(qp) :: n - complex(qp) :: mean - - n = real(count(mask, kind = int64), qp) - mean = sum(x, mask) / n - - res = sum(abs(x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_14_cqp_cqp - module function var_mask_all_15_cqp_cqp(x, mask, corrected) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res - - real(qp) :: n - complex(qp) :: mean - - n = real(count(mask, kind = int64), qp) - mean = sum(x, mask) / n - - res = sum(abs(x - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_15_cqp_cqp - - - module function var_mask_all_1_iint8_dp(x, mask, corrected) result(res) - integer(int8), intent(in) :: x(:) - logical, intent(in) :: mask(:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_1_iint8_dp - module function var_mask_all_2_iint8_dp(x, mask, corrected) result(res) - integer(int8), intent(in) :: x(:,:) - logical, intent(in) :: mask(:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_2_iint8_dp - module function var_mask_all_3_iint8_dp(x, mask, corrected) result(res) - integer(int8), intent(in) :: x(:,:,:) - logical, intent(in) :: mask(:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_3_iint8_dp - module function var_mask_all_4_iint8_dp(x, mask, corrected) result(res) - integer(int8), intent(in) :: x(:,:,:,:) - logical, intent(in) :: mask(:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_4_iint8_dp - module function var_mask_all_5_iint8_dp(x, mask, corrected) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_5_iint8_dp - module function var_mask_all_6_iint8_dp(x, mask, corrected) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_6_iint8_dp - module function var_mask_all_7_iint8_dp(x, mask, corrected) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_7_iint8_dp - module function var_mask_all_8_iint8_dp(x, mask, corrected) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_8_iint8_dp - module function var_mask_all_9_iint8_dp(x, mask, corrected) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_9_iint8_dp - module function var_mask_all_10_iint8_dp(x, mask, corrected) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_10_iint8_dp - module function var_mask_all_11_iint8_dp(x, mask, corrected) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_11_iint8_dp - module function var_mask_all_12_iint8_dp(x, mask, corrected) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_12_iint8_dp - module function var_mask_all_13_iint8_dp(x, mask, corrected) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_13_iint8_dp - module function var_mask_all_14_iint8_dp(x, mask, corrected) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_14_iint8_dp - module function var_mask_all_15_iint8_dp(x, mask, corrected) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_15_iint8_dp - module function var_mask_all_1_iint16_dp(x, mask, corrected) result(res) - integer(int16), intent(in) :: x(:) - logical, intent(in) :: mask(:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_1_iint16_dp - module function var_mask_all_2_iint16_dp(x, mask, corrected) result(res) - integer(int16), intent(in) :: x(:,:) - logical, intent(in) :: mask(:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_2_iint16_dp - module function var_mask_all_3_iint16_dp(x, mask, corrected) result(res) - integer(int16), intent(in) :: x(:,:,:) - logical, intent(in) :: mask(:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_3_iint16_dp - module function var_mask_all_4_iint16_dp(x, mask, corrected) result(res) - integer(int16), intent(in) :: x(:,:,:,:) - logical, intent(in) :: mask(:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_4_iint16_dp - module function var_mask_all_5_iint16_dp(x, mask, corrected) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_5_iint16_dp - module function var_mask_all_6_iint16_dp(x, mask, corrected) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_6_iint16_dp - module function var_mask_all_7_iint16_dp(x, mask, corrected) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_7_iint16_dp - module function var_mask_all_8_iint16_dp(x, mask, corrected) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_8_iint16_dp - module function var_mask_all_9_iint16_dp(x, mask, corrected) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_9_iint16_dp - module function var_mask_all_10_iint16_dp(x, mask, corrected) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_10_iint16_dp - module function var_mask_all_11_iint16_dp(x, mask, corrected) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_11_iint16_dp - module function var_mask_all_12_iint16_dp(x, mask, corrected) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_12_iint16_dp - module function var_mask_all_13_iint16_dp(x, mask, corrected) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_13_iint16_dp - module function var_mask_all_14_iint16_dp(x, mask, corrected) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_14_iint16_dp - module function var_mask_all_15_iint16_dp(x, mask, corrected) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_15_iint16_dp - module function var_mask_all_1_iint32_dp(x, mask, corrected) result(res) - integer(int32), intent(in) :: x(:) - logical, intent(in) :: mask(:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_1_iint32_dp - module function var_mask_all_2_iint32_dp(x, mask, corrected) result(res) - integer(int32), intent(in) :: x(:,:) - logical, intent(in) :: mask(:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_2_iint32_dp - module function var_mask_all_3_iint32_dp(x, mask, corrected) result(res) - integer(int32), intent(in) :: x(:,:,:) - logical, intent(in) :: mask(:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_3_iint32_dp - module function var_mask_all_4_iint32_dp(x, mask, corrected) result(res) - integer(int32), intent(in) :: x(:,:,:,:) - logical, intent(in) :: mask(:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_4_iint32_dp - module function var_mask_all_5_iint32_dp(x, mask, corrected) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_5_iint32_dp - module function var_mask_all_6_iint32_dp(x, mask, corrected) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_6_iint32_dp - module function var_mask_all_7_iint32_dp(x, mask, corrected) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_7_iint32_dp - module function var_mask_all_8_iint32_dp(x, mask, corrected) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_8_iint32_dp - module function var_mask_all_9_iint32_dp(x, mask, corrected) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_9_iint32_dp - module function var_mask_all_10_iint32_dp(x, mask, corrected) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_10_iint32_dp - module function var_mask_all_11_iint32_dp(x, mask, corrected) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_11_iint32_dp - module function var_mask_all_12_iint32_dp(x, mask, corrected) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_12_iint32_dp - module function var_mask_all_13_iint32_dp(x, mask, corrected) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_13_iint32_dp - module function var_mask_all_14_iint32_dp(x, mask, corrected) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_14_iint32_dp - module function var_mask_all_15_iint32_dp(x, mask, corrected) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_15_iint32_dp - module function var_mask_all_1_iint64_dp(x, mask, corrected) result(res) - integer(int64), intent(in) :: x(:) - logical, intent(in) :: mask(:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_1_iint64_dp - module function var_mask_all_2_iint64_dp(x, mask, corrected) result(res) - integer(int64), intent(in) :: x(:,:) - logical, intent(in) :: mask(:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_2_iint64_dp - module function var_mask_all_3_iint64_dp(x, mask, corrected) result(res) - integer(int64), intent(in) :: x(:,:,:) - logical, intent(in) :: mask(:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_3_iint64_dp - module function var_mask_all_4_iint64_dp(x, mask, corrected) result(res) - integer(int64), intent(in) :: x(:,:,:,:) - logical, intent(in) :: mask(:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_4_iint64_dp - module function var_mask_all_5_iint64_dp(x, mask, corrected) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_5_iint64_dp - module function var_mask_all_6_iint64_dp(x, mask, corrected) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_6_iint64_dp - module function var_mask_all_7_iint64_dp(x, mask, corrected) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_7_iint64_dp - module function var_mask_all_8_iint64_dp(x, mask, corrected) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_8_iint64_dp - module function var_mask_all_9_iint64_dp(x, mask, corrected) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_9_iint64_dp - module function var_mask_all_10_iint64_dp(x, mask, corrected) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_10_iint64_dp - module function var_mask_all_11_iint64_dp(x, mask, corrected) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_11_iint64_dp - module function var_mask_all_12_iint64_dp(x, mask, corrected) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_12_iint64_dp - module function var_mask_all_13_iint64_dp(x, mask, corrected) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_13_iint64_dp - module function var_mask_all_14_iint64_dp(x, mask, corrected) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_14_iint64_dp - module function var_mask_all_15_iint64_dp(x, mask, corrected) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res - - real(dp) :: n, mean - - n = real(count(mask, kind = int64), dp) - mean = sum(real(x, dp), mask) / n - - res = sum((real(x, dp) - mean)**2, mask) / (n -& - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_all_15_iint64_dp - - - module function var_mask_1_rsp_rsp(x, dim, mask, corrected) result(res) - real(sp), intent(in) :: x(:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:) - logical, intent(in), optional :: corrected - real(sp) :: res - - integer :: i - real(sp) :: n - real(sp) :: mean - - res = 0._sp - select case(dim) - case(1) - n = count(mask, dim) - mean = sum(x, dim, mask) / n - do i = 1, size(x, dim) - res = res + merge( (x(i) - mean)**2,& - 0._sp,& - mask(i)) - end do - case default - call error_stop("ERROR (var): wrong dimension") - end select - res = res / (n - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_1_rsp_rsp - module function var_mask_2_rsp_rsp(x, dim, mask, corrected) result(res) - real(sp), intent(in) :: x(:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:) - logical, intent(in), optional :: corrected - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_2_rsp_rsp - module function var_mask_3_rsp_rsp(x, dim, mask, corrected) result(res) - real(sp), intent(in) :: x(:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_3_rsp_rsp - module function var_mask_4_rsp_rsp(x, dim, mask, corrected) result(res) - real(sp), intent(in) :: x(:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_4_rsp_rsp - module function var_mask_5_rsp_rsp(x, dim, mask, corrected) result(res) - real(sp), intent(in) :: x(:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_5_rsp_rsp - module function var_mask_6_rsp_rsp(x, dim, mask, corrected) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_6_rsp_rsp - module function var_mask_7_rsp_rsp(x, dim, mask, corrected) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_7_rsp_rsp - module function var_mask_8_rsp_rsp(x, dim, mask, corrected) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_8_rsp_rsp - module function var_mask_9_rsp_rsp(x, dim, mask, corrected) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_9_rsp_rsp - module function var_mask_10_rsp_rsp(x, dim, mask, corrected) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_10_rsp_rsp - module function var_mask_11_rsp_rsp(x, dim, mask, corrected) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_11_rsp_rsp - module function var_mask_12_rsp_rsp(x, dim, mask, corrected) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_12_rsp_rsp - module function var_mask_13_rsp_rsp(x, dim, mask, corrected) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_13_rsp_rsp - module function var_mask_14_rsp_rsp(x, dim, mask, corrected) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_14_rsp_rsp - module function var_mask_15_rsp_rsp(x, dim, mask, corrected) result(res) - real(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_15_rsp_rsp - module function var_mask_1_rdp_rdp(x, dim, mask, corrected) result(res) - real(dp), intent(in) :: x(:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:) - logical, intent(in), optional :: corrected - real(dp) :: res - - integer :: i - real(dp) :: n - real(dp) :: mean - - res = 0._dp - select case(dim) - case(1) - n = count(mask, dim) - mean = sum(x, dim, mask) / n - do i = 1, size(x, dim) - res = res + merge( (x(i) - mean)**2,& - 0._dp,& - mask(i)) - end do - case default - call error_stop("ERROR (var): wrong dimension") - end select - res = res / (n - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_1_rdp_rdp - module function var_mask_2_rdp_rdp(x, dim, mask, corrected) result(res) - real(dp), intent(in) :: x(:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:) - logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_2_rdp_rdp - module function var_mask_3_rdp_rdp(x, dim, mask, corrected) result(res) - real(dp), intent(in) :: x(:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_3_rdp_rdp - module function var_mask_4_rdp_rdp(x, dim, mask, corrected) result(res) - real(dp), intent(in) :: x(:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_4_rdp_rdp - module function var_mask_5_rdp_rdp(x, dim, mask, corrected) result(res) - real(dp), intent(in) :: x(:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_5_rdp_rdp - module function var_mask_6_rdp_rdp(x, dim, mask, corrected) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_6_rdp_rdp - module function var_mask_7_rdp_rdp(x, dim, mask, corrected) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_7_rdp_rdp - module function var_mask_8_rdp_rdp(x, dim, mask, corrected) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_8_rdp_rdp - module function var_mask_9_rdp_rdp(x, dim, mask, corrected) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_9_rdp_rdp - module function var_mask_10_rdp_rdp(x, dim, mask, corrected) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_10_rdp_rdp - module function var_mask_11_rdp_rdp(x, dim, mask, corrected) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_11_rdp_rdp - module function var_mask_12_rdp_rdp(x, dim, mask, corrected) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_12_rdp_rdp - module function var_mask_13_rdp_rdp(x, dim, mask, corrected) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_13_rdp_rdp - module function var_mask_14_rdp_rdp(x, dim, mask, corrected) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_14_rdp_rdp - module function var_mask_15_rdp_rdp(x, dim, mask, corrected) result(res) - real(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_15_rdp_rdp - module function var_mask_1_rqp_rqp(x, dim, mask, corrected) result(res) - real(qp), intent(in) :: x(:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:) - logical, intent(in), optional :: corrected - real(qp) :: res - - integer :: i - real(qp) :: n - real(qp) :: mean - - res = 0._qp - select case(dim) - case(1) - n = count(mask, dim) - mean = sum(x, dim, mask) / n - do i = 1, size(x, dim) - res = res + merge( (x(i) - mean)**2,& - 0._qp,& - mask(i)) - end do - case default - call error_stop("ERROR (var): wrong dimension") - end select - res = res / (n - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_1_rqp_rqp - module function var_mask_2_rqp_rqp(x, dim, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:) - logical, intent(in), optional :: corrected - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_2_rqp_rqp - module function var_mask_3_rqp_rqp(x, dim, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_3_rqp_rqp - module function var_mask_4_rqp_rqp(x, dim, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_4_rqp_rqp - module function var_mask_5_rqp_rqp(x, dim, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_5_rqp_rqp - module function var_mask_6_rqp_rqp(x, dim, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_6_rqp_rqp - module function var_mask_7_rqp_rqp(x, dim, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_7_rqp_rqp - module function var_mask_8_rqp_rqp(x, dim, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_8_rqp_rqp - module function var_mask_9_rqp_rqp(x, dim, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_9_rqp_rqp - module function var_mask_10_rqp_rqp(x, dim, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_10_rqp_rqp - module function var_mask_11_rqp_rqp(x, dim, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_11_rqp_rqp - module function var_mask_12_rqp_rqp(x, dim, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_12_rqp_rqp - module function var_mask_13_rqp_rqp(x, dim, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_13_rqp_rqp - module function var_mask_14_rqp_rqp(x, dim, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_14_rqp_rqp - module function var_mask_15_rqp_rqp(x, dim, mask, corrected) result(res) - real(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_15_rqp_rqp - module function var_mask_1_csp_csp(x, dim, mask, corrected) result(res) - complex(sp), intent(in) :: x(:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:) - logical, intent(in), optional :: corrected - real(sp) :: res - - integer :: i - real(sp) :: n - complex(sp) :: mean - - res = 0._sp - select case(dim) - case(1) - n = count(mask, dim) - mean = sum(x, dim, mask) / n - do i = 1, size(x, dim) - res = res + merge( abs(x(i) - mean)**2,& - 0._sp,& - mask(i)) - end do - case default - call error_stop("ERROR (var): wrong dimension") - end select - res = res / (n - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_1_csp_csp - module function var_mask_2_csp_csp(x, dim, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:) - logical, intent(in), optional :: corrected - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_2_csp_csp - module function var_mask_3_csp_csp(x, dim, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_3_csp_csp - module function var_mask_4_csp_csp(x, dim, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_4_csp_csp - module function var_mask_5_csp_csp(x, dim, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_5_csp_csp - module function var_mask_6_csp_csp(x, dim, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_6_csp_csp - module function var_mask_7_csp_csp(x, dim, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_7_csp_csp - module function var_mask_8_csp_csp(x, dim, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_8_csp_csp - module function var_mask_9_csp_csp(x, dim, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_9_csp_csp - module function var_mask_10_csp_csp(x, dim, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_10_csp_csp - module function var_mask_11_csp_csp(x, dim, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_11_csp_csp - module function var_mask_12_csp_csp(x, dim, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_12_csp_csp - module function var_mask_13_csp_csp(x, dim, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_13_csp_csp - module function var_mask_14_csp_csp(x, dim, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_14_csp_csp - module function var_mask_15_csp_csp(x, dim, mask, corrected) result(res) - complex(sp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_15_csp_csp - module function var_mask_1_cdp_cdp(x, dim, mask, corrected) result(res) - complex(dp), intent(in) :: x(:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:) - logical, intent(in), optional :: corrected - real(dp) :: res - - integer :: i - real(dp) :: n - complex(dp) :: mean - - res = 0._dp - select case(dim) - case(1) - n = count(mask, dim) - mean = sum(x, dim, mask) / n - do i = 1, size(x, dim) - res = res + merge( abs(x(i) - mean)**2,& - 0._dp,& - mask(i)) - end do - case default - call error_stop("ERROR (var): wrong dimension") - end select - res = res / (n - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_1_cdp_cdp - module function var_mask_2_cdp_cdp(x, dim, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:) - logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_2_cdp_cdp - module function var_mask_3_cdp_cdp(x, dim, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_3_cdp_cdp - module function var_mask_4_cdp_cdp(x, dim, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_4_cdp_cdp - module function var_mask_5_cdp_cdp(x, dim, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_5_cdp_cdp - module function var_mask_6_cdp_cdp(x, dim, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_6_cdp_cdp - module function var_mask_7_cdp_cdp(x, dim, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_7_cdp_cdp - module function var_mask_8_cdp_cdp(x, dim, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_8_cdp_cdp - module function var_mask_9_cdp_cdp(x, dim, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_9_cdp_cdp - module function var_mask_10_cdp_cdp(x, dim, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_10_cdp_cdp - module function var_mask_11_cdp_cdp(x, dim, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_11_cdp_cdp - module function var_mask_12_cdp_cdp(x, dim, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_12_cdp_cdp - module function var_mask_13_cdp_cdp(x, dim, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_13_cdp_cdp - module function var_mask_14_cdp_cdp(x, dim, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_14_cdp_cdp - module function var_mask_15_cdp_cdp(x, dim, mask, corrected) result(res) - complex(dp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_15_cdp_cdp - module function var_mask_1_cqp_cqp(x, dim, mask, corrected) result(res) - complex(qp), intent(in) :: x(:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:) - logical, intent(in), optional :: corrected - real(qp) :: res - - integer :: i - real(qp) :: n - complex(qp) :: mean - - res = 0._qp - select case(dim) - case(1) - n = count(mask, dim) - mean = sum(x, dim, mask) / n - do i = 1, size(x, dim) - res = res + merge( abs(x(i) - mean)**2,& - 0._qp,& - mask(i)) - end do - case default - call error_stop("ERROR (var): wrong dimension") - end select - res = res / (n - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - - end function var_mask_1_cqp_cqp - module function var_mask_2_cqp_cqp(x, dim, mask, corrected) result(res) - complex(qp), intent(in) :: x(:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:) - logical, intent(in), optional :: corrected - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_2_cqp_cqp - module function var_mask_3_cqp_cqp(x, dim, mask, corrected) result(res) - complex(qp), intent(in) :: x(:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_3_cqp_cqp - module function var_mask_4_cqp_cqp(x, dim, mask, corrected) result(res) - complex(qp), intent(in) :: x(:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_4_cqp_cqp - module function var_mask_5_cqp_cqp(x, dim, mask, corrected) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_5_cqp_cqp - module function var_mask_6_cqp_cqp(x, dim, mask, corrected) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_6_cqp_cqp - module function var_mask_7_cqp_cqp(x, dim, mask, corrected) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_7_cqp_cqp - module function var_mask_8_cqp_cqp(x, dim, mask, corrected) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_8_cqp_cqp - module function var_mask_9_cqp_cqp(x, dim, mask, corrected) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_9_cqp_cqp - module function var_mask_10_cqp_cqp(x, dim, mask, corrected) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_10_cqp_cqp - module function var_mask_11_cqp_cqp(x, dim, mask, corrected) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_11_cqp_cqp - module function var_mask_12_cqp_cqp(x, dim, mask, corrected) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_12_cqp_cqp - module function var_mask_13_cqp_cqp(x, dim, mask, corrected) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_13_cqp_cqp - module function var_mask_14_cqp_cqp(x, dim, mask, corrected) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function var_mask_all_4_iint32_dp + module function var_mask_all_5_iint32_dp(x, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:) logical, intent(in), optional :: corrected - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n - end function var_mask_14_cqp_cqp - module function var_mask_15_cqp_cqp(x, dim, mask, corrected) result(res) - complex(qp), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_5_iint32_dp + module function var_mask_all_6_iint32_dp(x, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:) logical, intent(in), optional :: corrected - real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_6_iint32_dp + module function var_mask_all_7_iint32_dp(x, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res + + real(dp) :: n, mean - end function var_mask_15_cqp_cqp + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - module function var_mask_1_iint8_dp(x, dim, mask, corrected) result(res) - integer(int8), intent(in) :: x(:) - integer, intent(in) :: dim + end function var_mask_all_7_iint32_dp + module function var_mask_all_1_iint64_dp(x, mask, corrected) result(res) + integer(int64), intent(in) :: x(:) logical, intent(in) :: mask(:) logical, intent(in), optional :: corrected real(dp) :: res - integer :: i - real(dp) :: n - real(dp) :: mean + real(dp) :: n, mean - res = 0._dp - select case(dim) - case(1) - n = count(mask, dim) - mean = sum(real(x, dp), dim, mask) / n - do i = 1, size(x, dim) - res = res + merge((real(x(i), dp) - mean)**2,& - 0._dp, mask(i)) - end do - case default - call error_stop("ERROR (var): wrong dimension") - end select - res = res / (n - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n - end function var_mask_1_iint8_dp - module function var_mask_2_iint8_dp(x, dim, mask, corrected) result(res) - integer(int8), intent(in) :: x(:,:) - integer, intent(in) :: dim + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_1_iint64_dp + module function var_mask_all_2_iint64_dp(x, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:) logical, intent(in) :: mask(:,:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n - end function var_mask_2_iint8_dp - module function var_mask_3_iint8_dp(x, dim, mask, corrected) result(res) - integer(int8), intent(in) :: x(:,:,:) - integer, intent(in) :: dim + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_2_iint64_dp + module function var_mask_all_3_iint64_dp(x, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:) logical, intent(in) :: mask(:,:,:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n - end function var_mask_3_iint8_dp - module function var_mask_4_iint8_dp(x, dim, mask, corrected) result(res) - integer(int8), intent(in) :: x(:,:,:,:) - integer, intent(in) :: dim + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_3_iint64_dp + module function var_mask_all_4_iint64_dp(x, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:,:) logical, intent(in) :: mask(:,:,:,:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n - end function var_mask_4_iint8_dp - module function var_mask_5_iint8_dp(x, dim, mask, corrected) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:) - integer, intent(in) :: dim + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_4_iint64_dp + module function var_mask_all_5_iint64_dp(x, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:) logical, intent(in) :: mask(:,:,:,:,:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + real(dp) :: n, mean - end function var_mask_5_iint8_dp - module function var_mask_6_iint8_dp(x, dim, mask, corrected) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - res = 0._dp - select case(dim) - case(1) - n = count(mask, dim) - mean = sum(real(x, dp), dim, mask) / n - do i = 1, size(x, dim) - res = res + merge((real(x(i, :, :, :, :, :), dp) - mean)**2,& - 0._dp, mask(i, :, :, :, :, :)) - end do - case(2) - n = count(mask, dim) - mean = sum(real(x, dp), dim, mask) / n - do i = 1, size(x, dim) - res = res + merge((real(x(:, i, :, :, :, :), dp) - mean)**2,& - 0._dp, mask(:, i, :, :, :, :)) - end do - case(3) - n = count(mask, dim) - mean = sum(real(x, dp), dim, mask) / n - do i = 1, size(x, dim) - res = res + merge((real(x(:, :, i, :, :, :), dp) - mean)**2,& - 0._dp, mask(:, :, i, :, :, :)) - end do - case(4) - n = count(mask, dim) - mean = sum(real(x, dp), dim, mask) / n - do i = 1, size(x, dim) - res = res + merge((real(x(:, :, :, i, :, :), dp) - mean)**2,& - 0._dp, mask(:, :, :, i, :, :)) - end do - case(5) - n = count(mask, dim) - mean = sum(real(x, dp), dim, mask) / n - do i = 1, size(x, dim) - res = res + merge((real(x(:, :, :, :, i, :), dp) - mean)**2,& - 0._dp, mask(:, :, :, :, i, :)) - end do - case(6) - n = count(mask, dim) - mean = sum(real(x, dp), dim, mask) / n - do i = 1, size(x, dim) - res = res + merge((real(x(:, :, :, :, :, i), dp) - mean)**2,& - 0._dp, mask(:, :, :, :, :, i)) - end do - case default - call error_stop("ERROR (var): wrong dimension") - end select - res = res / (n - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + end function var_mask_all_5_iint64_dp + module function var_mask_all_6_iint64_dp(x, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res - end function var_mask_6_iint8_dp - module function var_mask_7_iint8_dp(x, dim, mask, corrected) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:) - integer, intent(in) :: dim + real(dp) :: n, mean + + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n + + res = sum((real(x, dp) - mean)**2, mask) / (n -& + merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_all_6_iint64_dp + module function var_mask_all_7_iint64_dp(x, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:) logical, intent(in) :: mask(:,:,:,:,:,:,:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + n = real(count(mask, kind = int64), dp) + mean = sum(real(x, dp), mask) / n - end function var_mask_7_iint8_dp - module function var_mask_8_iint8_dp(x, dim, mask, corrected) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - integer :: i - real(dp) :: n(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_mask_8_iint8_dp - module function var_mask_9_iint8_dp(x, dim, mask, corrected) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:) + module function var_mask_1_rsp_rsp(x, dim, mask, corrected) result(res) + real(sp), intent(in) :: x(:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_mask_9_iint8_dp - module function var_mask_10_iint8_dp(x, dim, mask, corrected) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_mask_10_iint8_dp - module function var_mask_11_iint8_dp(x, dim, mask, corrected) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + end function var_mask_2_rsp_rsp + module function var_mask_3_rsp_rsp(x, dim, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:,:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_mask_11_iint8_dp - module function var_mask_12_iint8_dp(x, dim, mask, corrected) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + end function var_mask_3_rsp_rsp + module function var_mask_4_rsp_rsp(x, dim, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:,:,:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_mask_12_iint8_dp - module function var_mask_13_iint8_dp(x, dim, mask, corrected) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + end function var_mask_4_rsp_rsp + module function var_mask_5_rsp_rsp(x, dim, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:,:,:,:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_mask_13_iint8_dp - module function var_mask_14_iint8_dp(x, dim, mask, corrected) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function var_mask_5_rsp_rsp + module function var_mask_6_rsp_rsp(x, dim, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_mask_14_iint8_dp - module function var_mask_15_iint8_dp(x, dim, mask, corrected) result(res) - integer(int8), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function var_mask_6_rsp_rsp + module function var_mask_7_rsp_rsp(x, dim, mask, corrected) result(res) + real(sp), intent(in) :: x(:,:,:,:,:,:,:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_7_rsp_rsp + module function var_mask_1_rdp_rdp(x, dim, mask, corrected) result(res) + real(dp), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:) + logical, intent(in), optional :: corrected + real(dp) :: res + + integer :: i + real(dp) :: n + real(dp) :: mean + + res = 0._dp + select case(dim) + case(1) n = count(mask, dim) - mean = sum(real(x, dp), dim, mask) / n + mean = sum(x, dim, mask) / n do i = 1, size(x, dim) - res = res + merge((real(x(:, :, :, :, :, :, :, :, :, :, :, :, i, :, :), dp) - mean)**2,& - 0._dp, mask(:, :, :, :, :, :, :, :, :, :, :, :, i, :, :)) + res = res + merge( (x(i) - mean)**2,& + 0._dp,& + mask(i)) end do - case(14) + case default + call error_stop("ERROR (var): wrong dimension") + end select + res = res / (n - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_1_rdp_rdp + module function var_mask_2_rdp_rdp(x, dim, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_mask_15_iint8_dp - module function var_mask_1_iint16_dp(x, dim, mask, corrected) result(res) - integer(int16), intent(in) :: x(:) + end function var_mask_2_rdp_rdp + module function var_mask_3_rdp_rdp(x, dim, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:,:) integer, intent(in) :: dim - logical, intent(in) :: mask(:) + logical, intent(in) :: mask(:,:,:) logical, intent(in), optional :: corrected - real(dp) :: res + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_mask_1_iint16_dp - module function var_mask_2_iint16_dp(x, dim, mask, corrected) result(res) - integer(int16), intent(in) :: x(:,:) + end function var_mask_3_rdp_rdp + module function var_mask_4_rdp_rdp(x, dim, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:,:,:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:) + logical, intent(in) :: mask(:,:,:,:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_mask_2_iint16_dp - module function var_mask_3_iint16_dp(x, dim, mask, corrected) result(res) - integer(int16), intent(in) :: x(:,:,:) + end function var_mask_4_rdp_rdp + module function var_mask_5_rdp_rdp(x, dim, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:,:,:,:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:) + logical, intent(in) :: mask(:,:,:,:,:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_mask_3_iint16_dp - module function var_mask_4_iint16_dp(x, dim, mask, corrected) result(res) - integer(int16), intent(in) :: x(:,:,:,:) + end function var_mask_5_rdp_rdp + module function var_mask_6_rdp_rdp(x, dim, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:) logical, intent(in), optional :: corrected real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_mask_4_iint16_dp - module function var_mask_5_iint16_dp(x, dim, mask, corrected) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:) + end function var_mask_6_rdp_rdp + module function var_mask_7_rdp_rdp(x, dim, mask, corrected) result(res) + real(dp), intent(in) :: x(:,:,:,:,:,:,:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:) logical, intent(in), optional :: corrected real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_7_rdp_rdp + module function var_mask_1_rqp_rqp(x, dim, mask, corrected) result(res) + real(qp), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:) + logical, intent(in), optional :: corrected + real(qp) :: res + + integer :: i + real(qp) :: n + real(qp) :: mean + + res = 0._qp + select case(dim) + case(1) + n = count(mask, dim) + mean = sum(x, dim, mask) / n + do i = 1, size(x, dim) + res = res + merge( (x(i) - mean)**2,& + 0._qp,& + mask(i)) + end do + case default + call error_stop("ERROR (var): wrong dimension") + end select + res = res / (n - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_1_rqp_rqp + module function var_mask_2_rqp_rqp(x, dim, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:) + logical, intent(in), optional :: corrected + real(qp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_mask_5_iint16_dp - module function var_mask_6_iint16_dp(x, dim, mask, corrected) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:) + end function var_mask_2_rqp_rqp + module function var_mask_3_rqp_rqp(x, dim, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:,:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_mask_6_iint16_dp - module function var_mask_7_iint16_dp(x, dim, mask, corrected) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:) + end function var_mask_3_rqp_rqp + module function var_mask_4_rqp_rqp(x, dim, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:,:,:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_mask_7_iint16_dp - module function var_mask_8_iint16_dp(x, dim, mask, corrected) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:) + end function var_mask_4_rqp_rqp + module function var_mask_5_rqp_rqp(x, dim, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:,:,:,:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_mask_8_iint16_dp - module function var_mask_9_iint16_dp(x, dim, mask, corrected) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:) + end function var_mask_5_rqp_rqp + module function var_mask_6_rqp_rqp(x, dim, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_mask_9_iint16_dp - module function var_mask_10_iint16_dp(x, dim, mask, corrected) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + end function var_mask_6_rqp_rqp + module function var_mask_7_rqp_rqp(x, dim, mask, corrected) result(res) + real(qp), intent(in) :: x(:,:,:,:,:,:,:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_7_rqp_rqp + module function var_mask_1_csp_csp(x, dim, mask, corrected) result(res) + complex(sp), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:) + logical, intent(in), optional :: corrected + real(sp) :: res + + integer :: i + real(sp) :: n + complex(sp) :: mean + + res = 0._sp + select case(dim) + case(1) n = count(mask, dim) - mean = sum(real(x, dp), dim, mask) / n + mean = sum(x, dim, mask) / n do i = 1, size(x, dim) - res = res + merge((real(x(:, :, :, :, :, :, :, i, :, :), dp) - mean)**2,& - 0._dp, mask(:, :, :, :, :, :, :, i, :, :)) + res = res + merge( abs(x(i) - mean)**2,& + 0._sp,& + mask(i)) end do - case(9) + case default + call error_stop("ERROR (var): wrong dimension") + end select + res = res / (n - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_1_csp_csp + module function var_mask_2_csp_csp(x, dim, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:) + logical, intent(in), optional :: corrected + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_mask_10_iint16_dp - module function var_mask_11_iint16_dp(x, dim, mask, corrected) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + end function var_mask_2_csp_csp + module function var_mask_3_csp_csp(x, dim, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_3_csp_csp + module function var_mask_4_csp_csp(x, dim, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_4_csp_csp + module function var_mask_5_csp_csp(x, dim, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:) + logical, intent(in), optional :: corrected + real(sp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_mask_11_iint16_dp - module function var_mask_12_iint16_dp(x, dim, mask, corrected) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + end function var_mask_5_csp_csp + module function var_mask_6_csp_csp(x, dim, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_mask_12_iint16_dp - module function var_mask_13_iint16_dp(x, dim, mask, corrected) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + end function var_mask_6_csp_csp + module function var_mask_7_csp_csp(x, dim, mask, corrected) result(res) + complex(sp), intent(in) :: x(:,:,:,:,:,:,:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_7_csp_csp + module function var_mask_1_cdp_cdp(x, dim, mask, corrected) result(res) + complex(dp), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:) + logical, intent(in), optional :: corrected + real(dp) :: res + + integer :: i + real(dp) :: n + complex(dp) :: mean + + res = 0._dp + select case(dim) + case(1) n = count(mask, dim) - mean = sum(real(x, dp), dim, mask) / n + mean = sum(x, dim, mask) / n do i = 1, size(x, dim) - res = res + merge((real(x(:, :, :, :, :, :, :, :, :, :, i, :, :), dp) - mean)**2,& - 0._dp, mask(:, :, :, :, :, :, :, :, :, :, i, :, :)) + res = res + merge( abs(x(i) - mean)**2,& + 0._dp,& + mask(i)) end do - case(12) + case default + call error_stop("ERROR (var): wrong dimension") + end select + res = res / (n - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_1_cdp_cdp + module function var_mask_2_cdp_cdp(x, dim, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_mask_13_iint16_dp - module function var_mask_14_iint16_dp(x, dim, mask, corrected) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function var_mask_2_cdp_cdp + module function var_mask_3_cdp_cdp(x, dim, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_3_cdp_cdp + module function var_mask_4_cdp_cdp(x, dim, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_mask_14_iint16_dp - module function var_mask_15_iint16_dp(x, dim, mask, corrected) result(res) - integer(int16), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function var_mask_4_cdp_cdp + module function var_mask_5_cdp_cdp(x, dim, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:) logical, intent(in), optional :: corrected real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_5_cdp_cdp + module function var_mask_6_cdp_cdp(x, dim, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_mask_15_iint16_dp - module function var_mask_1_iint32_dp(x, dim, mask, corrected) result(res) - integer(int32), intent(in) :: x(:) + end function var_mask_6_cdp_cdp + module function var_mask_7_cdp_cdp(x, dim, mask, corrected) result(res) + complex(dp), intent(in) :: x(:,:,:,:,:,:,:) integer, intent(in) :: dim - logical, intent(in) :: mask(:) + logical, intent(in) :: mask(:,:,:,:,:,:,:) logical, intent(in), optional :: corrected - real(dp) :: res + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_1_iint32_dp - module function var_mask_2_iint32_dp(x, dim, mask, corrected) result(res) - integer(int32), intent(in) :: x(:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:) - logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - - end function var_mask_2_iint32_dp - module function var_mask_3_iint32_dp(x, dim, mask, corrected) result(res) - integer(int32), intent(in) :: x(:,:,:) - integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:) - logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_mask_3_iint32_dp - module function var_mask_4_iint32_dp(x, dim, mask, corrected) result(res) - integer(int32), intent(in) :: x(:,:,:,:) + end function var_mask_7_cdp_cdp + module function var_mask_1_cqp_cqp(x, dim, mask, corrected) result(res) + complex(qp), intent(in) :: x(:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:) + logical, intent(in) :: mask(:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_mask_4_iint32_dp - module function var_mask_5_iint32_dp(x, dim, mask, corrected) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:) + end function var_mask_1_cqp_cqp + module function var_mask_2_cqp_cqp(x, dim, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:) + logical, intent(in) :: mask(:,:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_mask_5_iint32_dp - module function var_mask_6_iint32_dp(x, dim, mask, corrected) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:) + end function var_mask_2_cqp_cqp + module function var_mask_3_cqp_cqp(x, dim, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_mask_6_iint32_dp - module function var_mask_7_iint32_dp(x, dim, mask, corrected) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:) + end function var_mask_3_cqp_cqp + module function var_mask_4_cqp_cqp(x, dim, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:,:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_mask_7_iint32_dp - module function var_mask_8_iint32_dp(x, dim, mask, corrected) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:) + end function var_mask_4_cqp_cqp + module function var_mask_5_cqp_cqp(x, dim, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_mask_8_iint32_dp - module function var_mask_9_iint32_dp(x, dim, mask, corrected) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:) + end function var_mask_5_cqp_cqp + module function var_mask_6_cqp_cqp(x, dim, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_mask_9_iint32_dp - module function var_mask_10_iint32_dp(x, dim, mask, corrected) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + end function var_mask_6_cqp_cqp + module function var_mask_7_cqp_cqp(x, dim, mask, corrected) result(res) + complex(qp), intent(in) :: x(:,:,:,:,:,:,:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_7_cqp_cqp + + + module function var_mask_1_iint8_dp(x, dim, mask, corrected) result(res) + integer(int8), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:) + logical, intent(in), optional :: corrected + real(dp) :: res + + integer :: i + real(dp) :: n + real(dp) :: mean + + res = 0._dp + select case(dim) + case(1) n = count(mask, dim) mean = sum(real(x, dp), dim, mask) / n do i = 1, size(x, dim) - res = res + merge((real(x(:, :, :, :, :, :, :, :, :, i), dp) - mean)**2,& - 0._dp, mask(:, :, :, :, :, :, :, :, :, i)) + res = res + merge((real(x(i), dp) - mean)**2,& + 0._dp, mask(i)) end do case default call error_stop("ERROR (var): wrong dimension") end select res = res / (n - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - end function var_mask_10_iint32_dp - module function var_mask_11_iint32_dp(x, dim, mask, corrected) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + end function var_mask_1_iint8_dp + module function var_mask_2_iint8_dp(x, dim, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_2_iint8_dp + module function var_mask_3_iint8_dp(x, dim, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_mask_11_iint32_dp - module function var_mask_12_iint32_dp(x, dim, mask, corrected) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + end function var_mask_3_iint8_dp + module function var_mask_4_iint8_dp(x, dim, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:,:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:) logical, intent(in), optional :: corrected real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_mask_12_iint32_dp - module function var_mask_13_iint32_dp(x, dim, mask, corrected) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + end function var_mask_4_iint8_dp + module function var_mask_5_iint8_dp(x, dim, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:) logical, intent(in), optional :: corrected real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_mask_13_iint32_dp - module function var_mask_14_iint32_dp(x, dim, mask, corrected) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function var_mask_5_iint8_dp + module function var_mask_6_iint8_dp(x, dim, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:) logical, intent(in), optional :: corrected real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_mask_14_iint32_dp - module function var_mask_15_iint32_dp(x, dim, mask, corrected) result(res) - integer(int32), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function var_mask_6_iint8_dp + module function var_mask_7_iint8_dp(x, dim, mask, corrected) result(res) + integer(int8), intent(in) :: x(:,:,:,:,:,:,:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:) logical, intent(in), optional :: corrected real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_mask_15_iint32_dp - module function var_mask_1_iint64_dp(x, dim, mask, corrected) result(res) - integer(int64), intent(in) :: x(:) + end function var_mask_7_iint8_dp + module function var_mask_1_iint16_dp(x, dim, mask, corrected) result(res) + integer(int16), intent(in) :: x(:) integer, intent(in) :: dim logical, intent(in) :: mask(:) logical, intent(in), optional :: corrected @@ -28569,9 +8546,9 @@ module function var_mask_1_iint64_dp(x, dim, mask, corrected) result(res) end select res = res / (n - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - end function var_mask_1_iint64_dp - module function var_mask_2_iint64_dp(x, dim, mask, corrected) result(res) - integer(int64), intent(in) :: x(:,:) + end function var_mask_1_iint16_dp + module function var_mask_2_iint16_dp(x, dim, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:) integer, intent(in) :: dim logical, intent(in) :: mask(:,:) logical, intent(in), optional :: corrected @@ -28602,9 +8579,9 @@ module function var_mask_2_iint64_dp(x, dim, mask, corrected) result(res) end select res = res / (n - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - end function var_mask_2_iint64_dp - module function var_mask_3_iint64_dp(x, dim, mask, corrected) result(res) - integer(int64), intent(in) :: x(:,:,:) + end function var_mask_2_iint16_dp + module function var_mask_3_iint16_dp(x, dim, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:) integer, intent(in) :: dim logical, intent(in) :: mask(:,:,:) logical, intent(in), optional :: corrected @@ -28642,9 +8619,9 @@ module function var_mask_3_iint64_dp(x, dim, mask, corrected) result(res) end select res = res / (n - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - end function var_mask_3_iint64_dp - module function var_mask_4_iint64_dp(x, dim, mask, corrected) result(res) - integer(int64), intent(in) :: x(:,:,:,:) + end function var_mask_3_iint16_dp + module function var_mask_4_iint16_dp(x, dim, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:,:) integer, intent(in) :: dim logical, intent(in) :: mask(:,:,:,:) logical, intent(in), optional :: corrected @@ -28692,9 +8669,9 @@ module function var_mask_4_iint64_dp(x, dim, mask, corrected) result(res) end select res = res / (n - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - end function var_mask_4_iint64_dp - module function var_mask_5_iint64_dp(x, dim, mask, corrected) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:) + end function var_mask_4_iint16_dp + module function var_mask_5_iint16_dp(x, dim, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:) integer, intent(in) :: dim logical, intent(in) :: mask(:,:,:,:,:) logical, intent(in), optional :: corrected @@ -28749,9 +8726,9 @@ module function var_mask_5_iint64_dp(x, dim, mask, corrected) result(res) end select res = res / (n - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - end function var_mask_5_iint64_dp - module function var_mask_6_iint64_dp(x, dim, mask, corrected) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:) + end function var_mask_5_iint16_dp + module function var_mask_6_iint16_dp(x, dim, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:) integer, intent(in) :: dim logical, intent(in) :: mask(:,:,:,:,:,:) logical, intent(in), optional :: corrected @@ -28813,9 +8790,9 @@ module function var_mask_6_iint64_dp(x, dim, mask, corrected) result(res) end select res = res / (n - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - end function var_mask_6_iint64_dp - module function var_mask_7_iint64_dp(x, dim, mask, corrected) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:) + end function var_mask_6_iint16_dp + module function var_mask_7_iint16_dp(x, dim, mask, corrected) result(res) + integer(int16), intent(in) :: x(:,:,:,:,:,:,:) integer, intent(in) :: dim logical, intent(in) :: mask(:,:,:,:,:,:,:) logical, intent(in), optional :: corrected @@ -28887,23 +8864,17 @@ module function var_mask_7_iint64_dp(x, dim, mask, corrected) result(res) end select res = res / (n - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) - end function var_mask_7_iint64_dp - module function var_mask_8_iint64_dp(x, dim, mask, corrected) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:) + end function var_mask_7_iint16_dp + module function var_mask_1_iint32_dp(x, dim, mask, corrected) result(res) + integer(int32), intent(in) :: x(:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_1_iint32_dp + module function var_mask_2_iint32_dp(x, dim, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_mask_8_iint64_dp - module function var_mask_9_iint64_dp(x, dim, mask, corrected) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:) + end function var_mask_2_iint32_dp + module function var_mask_3_iint32_dp(x, dim, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:) logical, intent(in), optional :: corrected - real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_mask_9_iint64_dp - module function var_mask_10_iint64_dp(x, dim, mask, corrected) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:) + end function var_mask_3_iint32_dp + module function var_mask_4_iint32_dp(x, dim, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:,:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:) logical, intent(in), optional :: corrected real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_mask_10_iint64_dp - module function var_mask_11_iint64_dp(x, dim, mask, corrected) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:) + end function var_mask_4_iint32_dp + module function var_mask_5_iint32_dp(x, dim, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:) logical, intent(in), optional :: corrected real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_mask_11_iint64_dp - module function var_mask_12_iint64_dp(x, dim, mask, corrected) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:) + end function var_mask_5_iint32_dp + module function var_mask_6_iint32_dp(x, dim, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:) logical, intent(in), optional :: corrected real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_mask_12_iint64_dp - module function var_mask_13_iint64_dp(x, dim, mask, corrected) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:) + end function var_mask_6_iint32_dp + module function var_mask_7_iint32_dp(x, dim, mask, corrected) result(res) + integer(int32), intent(in) :: x(:,:,:,:,:,:,:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:,:) logical, intent(in), optional :: corrected real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_7_iint32_dp + module function var_mask_1_iint64_dp(x, dim, mask, corrected) result(res) + integer(int64), intent(in) :: x(:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:) + logical, intent(in), optional :: corrected + real(dp) :: res + + integer :: i + real(dp) :: n + real(dp) :: mean + + res = 0._dp + select case(dim) + case(1) n = count(mask, dim) mean = sum(real(x, dp), dim, mask) / n do i = 1, size(x, dim) - res = res + merge((real(x(:, :, :, :, :, :, :, i, :, :, :, :, :), dp) - mean)**2,& - 0._dp, mask(:, :, :, :, :, :, :, i, :, :, :, :, :)) + res = res + merge((real(x(i), dp) - mean)**2,& + 0._dp, mask(i)) end do - case(9) + case default + call error_stop("ERROR (var): wrong dimension") + end select + res = res / (n - merge(1, 0, (optval(corrected, .true.) .and. n > 0))) + + end function var_mask_1_iint64_dp + module function var_mask_2_iint64_dp(x, dim, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_2_iint64_dp + module function var_mask_3_iint64_dp(x, dim, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_mask_13_iint64_dp - module function var_mask_14_iint64_dp(x, dim, mask, corrected) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function var_mask_3_iint64_dp + module function var_mask_4_iint64_dp(x, dim, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:,:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:) logical, intent(in), optional :: corrected real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_4_iint64_dp + module function var_mask_5_iint64_dp(x, dim, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_mask_14_iint64_dp - module function var_mask_15_iint64_dp(x, dim, mask, corrected) result(res) - integer(int64), intent(in) :: x(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + end function var_mask_5_iint64_dp + module function var_mask_6_iint64_dp(x, dim, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:) integer, intent(in) :: dim - logical, intent(in) :: mask(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) + logical, intent(in) :: mask(:,:,:,:,:,:) logical, intent(in), optional :: corrected real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) + + end function var_mask_6_iint64_dp + module function var_mask_7_iint64_dp(x, dim, mask, corrected) result(res) + integer(int64), intent(in) :: x(:,:,:,:,:,:,:) + integer, intent(in) :: dim + logical, intent(in) :: mask(:,:,:,:,:,:,:) + logical, intent(in), optional :: corrected + real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1 0))) - end function var_mask_15_iint64_dp + end function var_mask_7_iint64_dp end submodule