Index: trunk/LMDZ.TITAN/libf/muphytitan/argparse.F90 =================================================================== --- trunk/LMDZ.TITAN/libf/muphytitan/argparse.F90 (revision 1793) +++ trunk/LMDZ.TITAN/libf/muphytitan/argparse.F90 (revision 1793) @@ -0,0 +1,2847 @@ +! Copyright Jérémie Burgalat (2010-2015) +! +! burgalat.jeremie@gmail.com +! +! This software is a computer program whose purpose is to provide configuration +! file and command line arguments parsing features to Fortran programs. +! +! This software is governed by the CeCILL-B license under French law and +! abiding by the rules of distribution of free software. You can use, +! modify and/ or redistribute the software under the terms of the CeCILL-B +! license as circulated by CEA, CNRS and INRIA at the following URL +! "http://www.cecill.info". +! +! As a counterpart to the access to the source code and rights to copy, +! modify and redistribute granted by the license, users are provided only +! with a limited warranty and the software's author, the holder of the +! economic rights, and the successive licensors have only limited +! liability. +! +! In this respect, the user's attention is drawn to the risks associated +! with loading, using, modifying and/or developing or reproducing the +! software by the user in light of its specific status of free software, +! that may mean that it is complicated to manipulate, and that also +! therefore means that it is reserved for developers and experienced +! professionals having in-depth computer knowledge. Users are therefore +! encouraged to load and test the software's suitability as regards their +! requirements in conditions enabling the security of their systems and/or +! data to be ensured and, more generally, to use and operate it in the +! same conditions as regards security. +! +! The fact that you are presently reading this means that you have had +! knowledge of the CeCILL-B license and that you accept its terms. + +!! file: argparse.F90 +!! summary: Command-line parser source file +!! author: burgalat +!! date: 2013-2015 + +#include "defined.h" + +MODULE ARGPARSE + !> Command-line parsing module + !! + !! Here are described all the public members of argparse module. + !! For your own sanity, private methods that call Ancient Gods powers through + !! evil black magic rituals are not described here. + !! + !! If you only wish to have an overview of argparse usage, you'd better go + !! [p_argparse](here). + USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY : stdout=>OUTPUT_UNIT, stderr=>ERROR_UNIT + USE ERRORS + USE FSYSTEM, ONLY : fs_termsize + USE STRINGS, getpar => format_paragraph, & + splitstr => format_string, & + ap_string => st_string, & !! String value type ID + ap_complex => st_complex, & !! Complex value type ID + ap_logical => st_logical, & !! Logical value type ID + ap_integer => st_integer, & !! Integer value type ID + ap_real => st_real !! Floating point value type ID + IMPLICIT NONE + + PRIVATE + + ! Public members and imported features + ! from errors: export everything (operator are exported latter) + PUBLIC :: noerror,error, error_to_string,aborting + ! from strings +#if ! HAVE_FTNDTSTR + PUBLIC :: st_slen, st_llen +#endif + PUBLIC :: ap_string, ap_complex, ap_logical, ap_integer, ap_real + PUBLIC :: stderr, stdout + ! argparse module + PUBLIC :: new_argparser, & + argparser_clear, & + argparser_add_option, & + argparser_add_positionals, & + argparser_throw_error, & + argparser_parse, & + argparser_help, & + argparser_get_positional, & + argparser_get_value, & + argparser_reset_values, & + argparser_found, & + argparser_get_num_values, & + argparser_found_positional, & + argparser_get_num_positional + + PUBLIC :: OPERATOR(==), OPERATOR(/=), ASSIGNMENT(=) + + ! =========================== + ! PARAMETERS (INTRISIC TYPES) + ! =========================== + + INTEGER, PARAMETER, PUBLIC :: ap_store = 1 + !! store action ID : Each time the option is seen, values are replaced. + INTEGER, PARAMETER, PUBLIC :: ap_append = 2 + !! append action ID : Each time the option is seen, values are appended. + INTEGER, PARAMETER, PUBLIC :: ap_count = 3 + !! count action ID : increase a counter each time the option is seen. + INTEGER, PARAMETER, PUBLIC :: ap_help = 4 + !! help action ID : help is requested ! + + !> List of all available actions + INTEGER, DIMENSION(4), PARAMETER, PRIVATE :: ap_actions = (/ap_store, & + ap_append, & + ap_count, & + ap_help/) + !> List of all recognized types by the parser + INTEGER, DIMENSION(5), PARAMETER, PRIVATE :: ap_types = (/ap_string, & + ap_logical, & + ap_complex, & + ap_integer, & + ap_real/) + !> The unknown flag + !! + !! This flag is only intended to initialize flags. It is set by default during initialization + !! and quielty replaced by default flags, if user does not provide the relevant feature. + INTEGER, PARAMETER :: ap_undef = -1 + + !> Add an option to the parser + INTERFACE argparser_add_option + MODULE PROCEDURE ap_add_option_1, ap_add_option_2 + END INTERFACE + + !> Get positional argument value(s) + INTERFACE argparser_get_positional + MODULE PROCEDURE ap_get_positional_sc, ap_get_positional_ve + END INTERFACE + + !> Get optional argument value(s) + !! + !! This is the generic method that can be used to retrieve any kind of argument value(s) from the parser. + !! All the methods have the same dummy arguments only `output` dummy argument differs in type and shape. + !! + !! @note + !! For string vector, `output` is expected to be an allocatable vector of **assumed length** + !! strings (thus string length is left to user responsability). + !! A good compromise for strings length is to use the [[strings(module):st_slen(variable)]] + !! parameter. + INTERFACE argparser_get_value + MODULE PROCEDURE ap_get_dv_sc, ap_get_rv_sc, ap_get_iv_sc, ap_get_lv_sc, & + ap_get_cv_sc, ap_get_sv_sc, ap_get_dv_ve, ap_get_rv_ve, & + ap_get_iv_ve, ap_get_lv_ve, ap_get_cv_ve, ap_get_sv_ve + END INTERFACE + + !> Interface to [[argparse(module):argc(type)]] getters + !! + !! All the functions have the same prototype, only kind and type of arguments changed + !! from a function to the other. + INTERFACE argc_get_value + MODULE PROCEDURE ac_get_dv_sc, ac_get_rv_sc, ac_get_iv_sc, ac_get_lv_sc, & + ac_get_cv_sc, ac_get_sv_sc, ac_get_dv_ve, ac_get_rv_ve, & + ac_get_iv_ve, ac_get_lv_ve, ac_get_cv_ve, ac_get_sv_ve + END INTERFACE + + !> argc equality operator + INTERFACE OPERATOR(==) + MODULE PROCEDURE ac_equals_arg + END INTERFACE + + !> argc inequality operator + INTERFACE OPERATOR(/=) + MODULE PROCEDURE ac_differs_arg + END INTERFACE + + !> argc assignment statement + INTERFACE ASSIGNMENT(=) + MODULE PROCEDURE ac_affect_arg + MODULE PROCEDURE ap_affect_parser + END INTERFACE + + !> argc *destructors* interface + INTERFACE clear_argc + MODULE PROCEDURE ac_clear_arg_sc, ac_clear_arg_ve + END INTERFACE + + + TYPE, PRIVATE :: argc + !! Defines a command-line argument. + !! + !! An [[argparse(module):argc(type)]] object stores all information about a command-line + !! argument, that is: + !! + !! - its name + !! - its optional flags + !! - its type + !! - its action + !! - and finally its values + PRIVATE + INTEGER :: ptype = ap_logical + !! Type flag (an integer from enum argparse::ap_types) + INTEGER :: paction = ap_store + !! Action flag (an integer from enum argparse::ap_actions) + INTEGER :: nrec = 0 + !! Number of values + LOGICAL :: fnd = .false. + !! A boolean flag set to `.true.` if argument has been found in the command-line. + TYPE(words) :: values + !! Values of the argument + CHARACTER(len=2) :: sflag = " " + !! Short flag option + TYPE(words) :: meta + !! Meta variable name(s) of the argument +#if HAVE_FTNDTSTR + CHARACTER(len=:), ALLOCATABLE :: default + !! Default flag + CHARACTER(len=:), ALLOCATABLE :: name + !! Name of the argument (needed to check and retrieve its value(s)) + CHARACTER(len=:), ALLOCATABLE :: lflag + !! Long flag option (st_short_len max chars !) + CHARACTER(len=:), ALLOCATABLE :: help + !! Help about the argument +#else + CHARACTER(len=st_slen) :: default = "" + !! Default flag + CHARACTER(len=st_slen) :: name + !! Name of the argument (needed to check and retrieve its value(s)) + CHARACTER(len=st_slen) :: lflag = "" + !! Long flag option (st_short_len max chars !) + CHARACTER(len = 200) :: help = "" + !! Help about the argument +#endif + END TYPE argc + + + TYPE, PUBLIC :: argparser + !! Command-line parser + !! + !! This is the main object of the module. It stores definitions of CLI arguments and + !! their value(s) once the command-line have been parsed. + TYPE(argc), PRIVATE, ALLOCATABLE, DIMENSION(:) :: args + !! List of defined arguments + INTEGER, PRIVATE :: nargs = 0 + !! Size of args + INTEGER, PRIVATE :: parsed = -1 + !! Parsing control flag + !! + !! The parsing flag determines if the command line have been parsed : + !! + !! - -1 : not parsed yet + !! - 0 : unsuccessfully parsed + !! - 1 : successfully parsed + TYPE(argc), PRIVATE :: posals + !! Positionals arguments (defined as a single argc object) + LOGICAL, PRIVATE :: have_posal = .false. + !! Positional control flag +#if HAVE_FTNDTSTR + CHARACTER(len=:), PRIVATE, ALLOCATABLE :: usg + !! Program command usage + CHARACTER(len=:), PRIVATE, ALLOCATABLE :: descr + !! Program help description + CHARACTER(len=:), PRIVATE, ALLOCATABLE :: eplg + !! Program help epilog +#else + CHARACTER(len=st_llen), PRIVATE :: usg + !! Program command usage + CHARACTER(len=st_llen), PRIVATE :: descr + !! Program help description + CHARACTER(len=st_llen), PRIVATE :: eplg + !! Program help epilog +#endif + INTEGER, PRIVATE :: mxhlpos = 20 + !! Position of the short help for options + INTEGER, PRIVATE :: width = 0 + !! Maximum width of the help + LOGICAL, PRIVATE :: init = .false. + !! Initialization control flag +#if HAVE_FTNPROC + + CONTAINS + PROCEDURE, PRIVATE :: ap_add_option_1 + PROCEDURE, PRIVATE :: ap_add_option_2 + PROCEDURE, PRIVATE :: ap_get_positional_sc + PROCEDURE, PRIVATE :: ap_get_positional_ve + PROCEDURE, PRIVATE :: ap_get_dv_sc + PROCEDURE, PRIVATE :: ap_get_rv_sc + PROCEDURE, PRIVATE :: ap_get_iv_sc + PROCEDURE, PRIVATE :: ap_get_lv_sc + PROCEDURE, PRIVATE :: ap_get_cv_sc + PROCEDURE, PRIVATE :: ap_get_sv_sc + PROCEDURE, PRIVATE :: ap_get_dv_ve + PROCEDURE, PRIVATE :: ap_get_rv_ve + PROCEDURE, PRIVATE :: ap_get_iv_ve + PROCEDURE, PRIVATE :: ap_get_lv_ve + PROCEDURE, PRIVATE :: ap_get_cv_ve + PROCEDURE, PRIVATE :: ap_get_sv_ve + PROCEDURE, PRIVATE :: ap_check_state + !PROCEDURE, PUBLIC :: reset_values => argparser_reset_values + ! !! Resets values stored in the parser + PROCEDURE, PUBLIC :: throw_error => argparser_throw_error + !! Throw an error and exit the program + PROCEDURE, PUBLIC :: parse => argparser_parse + !! Parse the command-line (or the given input string). + PROCEDURE, PUBLIC :: help => argparser_help + !! Compute and print help + PROCEDURE, PUBLIC :: found => argparser_found + !! Check if an optional argument has been found on the command-line + PROCEDURE, PUBLIC :: get_num_values => argparser_get_num_values + !! Get the actual number of values stored in an argument. + PROCEDURE, PUBLIC :: found_positional => argparser_found_positional + !! Check if positional argument(s) has been found on the command-line + PROCEDURE, PUBLIC :: get_num_positional => argparser_get_num_positional + !! Get the actual number of values stored as positionals. + PROCEDURE, PUBLIC :: add_positionals => argparser_add_positionals + !! Add positionals definitions in the parser. + !> Add optional argument definition in the parser. + GENERIC, PUBLIC :: add_option => ap_add_option_1, & + ap_add_option_2 + !> Get the values of the positionals stored in the parser. + GENERIC, PUBLIC :: get_positional => ap_get_positional_sc, & + ap_get_positional_ve + !> Get the value(s) of the given argument stored in the parser. + GENERIC, PUBLIC :: get_value => ap_get_dv_sc, & + ap_get_rv_sc, & + ap_get_iv_sc, & + ap_get_lv_sc, & + ap_get_cv_sc, & + ap_get_sv_sc, & + ap_get_dv_ve, & + ap_get_rv_ve, & + ap_get_iv_ve, & + ap_get_lv_ve, & + ap_get_cv_ve, & + ap_get_sv_ve +#endif + END TYPE argparser + + CONTAINS + + ! argparser main methods (public) + ! ------------------------------- + + FUNCTION new_argparser(usg, dsc, epg, add_help, width, max_help_pos) RESULT(this) + !! Initialize an argparser object. + !! + !! The method initializes (properly) an [[argparse(module):argparser(type)]] object. + !! Even if all the arguments are optional, it is mandatory to **call** the method + !! before using an argparser object. + CHARACTER(len=*), INTENT(in), OPTIONAL :: usg + !! An optional string with the command line usage of the program. If it is not given + !! command-line usage is automatically built from informations set in the parser. + CHARACTER(len=*), INTENT(in), OPTIONAL :: dsc + !! An optional string with the short description of the program. + CHARACTER(len=*), INTENT(in), OPTIONAL :: epg + !! An optional string with the epilog of the program's help + LOGICAL, INTENT(in), OPTIONAL :: add_help + !! An optional boolean flag with `.true.` to automatically set an option for program's help. + !! Note that, the option flags `-h` and `--help` are no more available in that case. + INTEGER, INTENT(in), OPTIONAL :: width + !! An optional integer with the maximum width the help text. + INTEGER, INTENT(in), OPTIONAL :: max_help_pos + !! An optional integer with the maximum position of the help string for each option of + !! the program when help is requested. Note that this value is just an indicator. The + !! helper computes the minimum position between this value and the maximum length of the + !! options flags. + TYPE(argparser) :: this + !! An initialized argparse object. + INTEGER :: zh + TYPE(error) :: err + ! We always clear the parser + CALL argparser_clear(this) + ! Set keywords + IF (PRESENT(usg)) THEN ; this%usg=usg ; ELSE ; this%usg='' ; ENDIF + IF (PRESENT(dsc)) THEN ; this%descr=dsc ; ELSE ; this%descr='' ; ENDIF + IF (PRESENT(epg)) THEN ; this%eplg=epg ; ELSE ; this%eplg='' ; ENDIF + CALL fs_termsize(zh,this%width) + IF (PRESENT(width)) this%width = MAX(width,50) + IF(PRESENT(max_help_pos)) this%mxhlpos = MAX(5,max_help_pos) + this%init = .true. ! before adding option !!! + IF (PRESENT(add_help)) THEN + IF (add_help) & + err = argparser_add_option(this,'help',sflag='-h',lflag='--help', & + action=ap_help, help="Print this help and quit") + ENDIF + RETURN + END FUNCTION new_argparser + + SUBROUTINE argparser_clear(this) + !! Clear the parser + !! The subroutine is used as finalization subroutine of argparser type. + !! Once the method is called, the object is no more usable until it is + !! (re)initialized by calling argparse::new_argparser. + !! @note If **fccp** has not been built with support for finalization subroutine, + !! it should be called whenever the argparser object is no more used. + TYPE(argparser), INTENT(inout) :: this + !! An argparser object + IF (ALLOCATED(this%args)) THEN + CALL clear_argc(this%args) + DEALLOCATE(this%args) + ENDIF + ! maybe we should should set this%posals as allocatable + CALL clear_argc(this%posals) + this%nargs = 0 + this%parsed = -1 + this%have_posal = .false. + this%usg = '' + this%descr = '' + this%eplg = '' + this%mxhlpos = 20 + this%width = 0 + this%init = .false. + END SUBROUTINE argparser_clear + + SUBROUTINE argparser_reset_values(this) + !! Reset all arguments values in the parser + !! The method only deletes arguments value(s) currently stored in the parser. + OBJECT(argparser), INTENT(inout) :: this + !! An argparser object reference + ! Check if list is empty + IF (this%nargs == 0) RETURN + CALL words_clear(this%args(:)%values) + CALL words_clear(this%posals%values) + END SUBROUTINE argparser_reset_values + + FUNCTION argparser_add_positionals(this,nargs,meta,help) RESULT(err) + !! Add positional arguments definition to the parser + !! The method initializes the entry for positional arguments in the parser. + !! Positional arguments are always seen by the parser as strings and the + !! default associated action is 'store'. + + OBJECT(argparser), INTENT(inout) :: this + !! An argparser object reference + CHARACTER(len=*), INTENT(in) :: nargs + !! A string with the expected number of specified values for the option + CHARACTER(len=*), INTENT(in), DIMENSION(:), OPTIONAL :: meta + !! A vector of strings with the the displayed value name(s) of the positionals in the help command + CHARACTER(len=*), INTENT(in), OPTIONAL :: help + !! An optional string with a short description of the positional argument(s) + TYPE(error) :: err + !! Error object with the first error encountered in the process. + INTEGER :: ty,ac + CHARACTER(len=:), ALLOCATABLE :: sf,lf,de + err = noerror + IF (.NOT.this%init) THEN + err = error("argparse: parser not initialized yet",-1) + RETURN + ENDIF + IF (this%have_posal) THEN + err = error('argparse: positionals arguments already defined',-8) + RETURN + ELSE + this%posals%name = 'positional' + sf = ' ' ; lf = '' ; ty = ap_string ; ac = ap_store ; de = '' + IF (PRESENT(help)) THEN + this%posals%help = TRIM(help) + ELSE + this%posals%help = '' + ENDIF + IF (PRESENT(meta)) THEN + err = ac_check_and_set(this%posals,sf,lf,ty,ac,de,nargs,meta,.false.) + ELSE + err = ac_check_and_set(this%posals,sf,lf,ty,ac,de,nargs,check_flag=.false.) + ENDIF + IF (err /= noerror) THEN + RETURN + ENDIF + this%have_posal = this%posals%nrec /= 0 + ENDIF + RETURN + END FUNCTION argparser_add_positionals + + FUNCTION argparser_parse(this,cmd_line,auto) RESULT(err) + !! Parse the command line + !! The method parses either the command-line or the string `cmd_line` + !! given as optional argument and fills the parser's arguments. + !! @note + !! If `cmd_line` is provided it should not contains the name of the program or + !! the parsing process will certainly failed: program name will be seen as the + !! first positional argument and all tokens of the string will then be seen as + !! positional. + OBJECT(argparser), INTENT(inout) :: this + !! An argparser object reference + CHARACTER(len=*), INTENT(in), OPTIONAL :: cmd_line + !! An optional string to parse that substitute for the actual command-line. + LOGICAL, INTENT(in), OPTIONAL :: auto + !! An optional boolean flag with `.true.` to instruct the parser wether to perform + !! automatic actions or not when error occur during parsing. If `auto` is enabled, + !! then the parser dumps program's usage and stops the program on error. + TYPE(error) :: err + !! Error object with the first error encountered in the process. + CHARACTER(len=:), ALLOCATABLE :: cline,z + LOGICAL :: zauto + LOGICAL :: rhelp + INTEGER :: l + TYPE(words) :: cmd_tokens + err = noerror + IF (.NOT.this%init) THEN + err = error("parser not initialized yet",-1) ; RETURN + ENDIF + rhelp = .false. + zauto = .false. ; IF (PRESENT(auto)) zauto = auto + IF (PRESENT(cmd_line)) THEN + ALLOCATE(cline,source=cmd_line) + ELSE + CALL GET_COMMAND(length=l) + ALLOCATE(CHARACTER(len=l) :: z) ; CALL GET_COMMAND(z) + CALL GET_COMMAND_ARGUMENT(0,length=l) + IF (l >= LEN_TRIM(z)) THEN ; cline='' ; ELSE ; cline=z(l+1:LEN(z)) ; ENDIF + DEALLOCATE(z) + ENDIF + ! reset parsing status + this%parsed = -1 + CALL argparser_reset_values(this) + DO + ! Do we have to launch the turbine ? + IF (LEN_TRIM(cline) == 0) THEN + IF (this%have_posal) err=error("Wrong number of arguments",-16) + EXIT ! ... No :) + ELSE + err = ap_split_cmd(this,cline,cmd_tokens,rhelp) + ! we only stops processing if : + ! - the internal error (string length) is raised + ! - help flag found AND auto has been set + IF (err /= noerror .OR. (rhelp.AND.zauto)) EXIT + ENDIF + CALL words_reset(cmd_tokens) ! not mandatory... at least theoretically + ! Parses the options + err = ap_parse_options(this,cmd_tokens,rhelp) + IF (err /= noerror) EXIT + ! exit loop if help is requested. Parser is not completely filled but we + ! expect someone to use the help action.. + IF (rhelp) EXIT + ! Parses positionals + err = ap_parse_positionals(this,cmd_tokens) + EXIT ! A one iterated loop :) + ENDDO + IF (err /= 0) THEN + CALL argparser_reset_values(this) + ELSE + this%parsed = 1 + ENDIF + IF (zauto) THEN + IF (rhelp) CALL argparser_help(this) + IF (err /= 0.AND. err /= 255) CALL argparser_throw_error(this,err,2) + ENDIF + RETURN + END FUNCTION argparser_parse + + SUBROUTINE argparser_help(this) + !! Print help and exit program + OBJECT(argparser), INTENT(inout) :: this + !! An argparser object reference + CHARACTER(len=:), ALLOCATABLE :: helpme + !!!! WARNING we set no indication here !!! + IF (.NOT.this%init) RETURN + helpme = ap_gen_help(this) + + WRITE(stdout,'(a)') helpme + + CALL argparser_clear(this) + ! Finally we exit the program + CALL EXIT(0) + END SUBROUTINE argparser_help + + SUBROUTINE argparser_throw_error(this,err,exit_id) + !! Dump error on standard error and exit + !! + !! The method performs the following actions: + !! + !! - Print the usage command of the program + !! - Dump the provided @p error message + !! - Call parser's clean-up subroutine (if a *cleaner* callback has been given during the + !! parser's initialization, see [[argparse(module):new_argparser(function)]] documentation + !! - Stop the program + !! + !! The error message is always printed in standard error output. + !! @note + !! If errors::error::id is 0 the method does nothing. + OBJECT(argparser), INTENT(inout) :: this + !! An argparser object reference + TYPE(error), INTENT(in) :: err + !! An error object with the error to print + INTEGER, INTENT(in), OPTIONAL :: exit_id + !! An optional integer with the exit code (default to 2) + CHARACTER(len=:), ALLOCATABLE :: pgn + TYPE(error) :: zerr + IF (err == 0) RETURN + zerr = error(err%msg,2) + IF (PRESENT(exit_id)) zerr%id=exit_id + CALL ap_format_usage(this) + WRITE(stderr,'(a)') TRIM(this%usg)//NEW_LINE('A') + ! clean the parser + CALL argparser_clear(this) + pgn = get_progname() + WRITE(stderr,'(a)') pgn//": error: "//TRIM(err%msg) + CALL EXIT(err%id) + END SUBROUTINE argparser_throw_error + + FUNCTION argparser_found(this,argname) RESULT(found) + !! Check wether an argument has been found in the command-line. + !! @note + !! Keep in mind that arguments in the parser always have a default + !! value. This method is not intended to check if an argument has a value but + !! only if it has been seen on the command-line ! + OBJECT(argparser), INTENT(in) :: this + !! An argparser object reference + CHARACTER(len=*), INTENT(in) :: argname + !! Name of the argument to check + LOGICAL :: found + !! `.true.` if the option has been parsed, `.false.` otherwise + INTEGER :: idx + idx = ap_get_arg_index(this,argname) + IF (idx == -1) THEN + found = .false. + ELSE + found = ac_found(this%args(idx)) + ENDIF + END FUNCTION argparser_found + + FUNCTION argparser_get_num_values(this,argname) RESULT(num) + !! Get the actual number of values stored in an argument. + OBJECT(argparser), INTENT(in) :: this + !! An argparser object reference + CHARACTER(len=*), INTENT(in) :: argname + !! Name of the argument to check. + INTEGER :: num + !! The number of actual values stored in the argument + INTEGER :: idx + idx = ap_get_arg_index(this,argname) + IF (idx == -1) THEN + num = 0 + ELSE + num = words_length(this%args(idx)%values) + ENDIF + END FUNCTION argparser_get_num_values + + FUNCTION argparser_found_positional(this) RESULT(ret) + !! Check if positional(s) has been found in the command line. + OBJECT(argparser), INTENT(in) :: this + !! An argparser object reference + LOGICAL :: ret + !! `.true.` if found, `.false.` otherwise + TYPE(error) :: err + ret = .false. + IF (this%have_posal) THEN + ret = this%posals%fnd + ENDIF + END FUNCTION argparser_found_positional + + FUNCTION argparser_get_num_positional(this) RESULT(ret) + !! Get the actual number of positional argument values stored in the parser . + OBJECT(argparser), INTENT(in) :: this + !! An argparser object reference + INTEGER :: ret + !! The number of actual positionals arguments + ret = 0 + IF (this%have_posal) THEN + ret = words_length(this%posals%values) + ENDIF + END FUNCTION argparser_get_num_positional + + ! argparser private methods + ! ------------------------- + + FUNCTION ap_check_state(this) RESULT(err) + !! Check current parser state + !! The method returns an error based on the current parser's state: + !! - Parser is ready (0) + !! - parsing not done yet (-19) + !! - parsing (already) failed (-20) + !! - parser is **NOT** initialized (-1) + OBJECT(argparser), INTENT(in) :: this + !! An argparser object reference + TYPE(error) :: err + !! Error object with the *status* of the parser + err = noerror + IF (this%parsed == -1) THEN + err = error("argparse: Command-line not parsed (yet)",-19) + ELSE IF (this%parsed == 0) THEN + err = error("argparse: command-line parsing failed",-20) + ELSE IF (.NOT.this%init) THEN + err = error("argparse: parser not initialized yet",-1) + ENDIF + RETURN + END FUNCTION ap_check_state + + SUBROUTINE ap_append_arg(this,arg) + !! Append an argument to the list of arguments. + TYPE(argparser), INTENT(inout) :: this + !! An argparser object reference + TYPE(argc), INTENT(in) :: arg + !! An [[argparse(module):argc(type)]] object with the argument to add + INTEGER :: i + TYPE(argc), ALLOCATABLE, DIMENSION(:) :: tmp + TYPE(error) :: err + IF (.NOT.this%init) THEN + err = error("parser not initialized yet",-1) ; RETURN + ENDIF + ! Empty list : we create it + IF (this%nargs == 0) THEN + ALLOCATE(this%args(1)) + this%args(1) = arg + this%nargs = 1 + RETURN + ENDIF + ! Adds a new argument to the vector of arguments + ! we will make a test with move_alloc but i'm not sure it does everything + ! the way we want (keep in mind that there is some pointer in argc members + ! !!!) + ALLOCATE(tmp(this%nargs)) + DO i=1,this%nargs ; tmp(i) = this%args(i) ; ENDDO + CALL clear_argc(this%args) + DEALLOCATE(this%args) + this%nargs = this%nargs+1 ; ALLOCATE(this%args(this%nargs)) + DO i=1,this%nargs-1 ; this%args(i) = tmp(i) ; ENDDO + CALL clear_argc(tmp) + DEALLOCATE(tmp) + this%args(i) = arg + RETURN + END SUBROUTINE ap_append_arg + + FUNCTION ap_get_arg_index(this, name, sflag, lflag) RESULT(idx) + !! Get an argument by name or option flag in the parser. + TYPE(argparser), INTENT(in), TARGET :: this + !! An argparser object reference + CHARACTER(len=*), INTENT(in), OPTIONAL :: name + !! An optional string with the name of the argument + CHARACTER(len=*), INTENT(in), OPTIONAL :: lflag + !! An optional string with the long option flag of the argument + CHARACTER(len=2), INTENT(in), OPTIONAL :: sflag + !! An optional string with the short option flag of the argument + INTEGER :: idx + !! Index of the argument in the internal vector of argument or -1 if no argument is found. + INTEGER :: i,nn,nl,ns + CHARACTER(LEN=:), ALLOCATABLE :: lna, llf + CHARACTER(LEN=2) :: lsf + idx = -1 + IF (.NOT.this%init) RETURN + lna="" ; IF(PRESENT(name)) lna = name ; nn = LEN_TRIM(lna) + lsf="" ; IF(PRESENT(sflag)) lsf = sflag ; ns = LEN_TRIM(lsf) + llf="" ; IF(PRESENT(lflag)) llf = lflag ; nl = LEN_TRIM(llf) + IF (nn == 0 .AND. ns == 0 .AND. nl == 0) RETURN + ! empty parser + IF (this%nargs == 0) RETURN + DO i=1, this%nargs + IF ((nn /= 0 .AND. TRIM(this%args(i)%name) == TRIM(lna)) .OR. & + (ns /= 0 .AND. TRIM(this%args(i)%sflag) == TRIM(lsf)) .OR. & + (nl /= 0 .AND. TRIM(this%args(i)%lflag) == TRIM(llf))) THEN + idx = i ; RETURN + ENDIF + ENDDO + RETURN + END FUNCTION ap_get_arg_index + + + FUNCTION ap_add_option_1(this,dest,sflag,lflag,type,action,default,nrec,help,meta) RESULT(err) + !! Add an argument to the parser (interface #1) + !! + !! The function defines a new argument based on input parameters, checks it and finally sets it + !! in the parser. Both **short and long options flags** are mandatory input arguments of the function. + !! + !! `type` value should be one of the following module constants (which are aliases from [[strings(module)]]): + !! - ap_string ([[strings(module):st_string(variable)]]) + !! - ap_complex ([[strings(module):st_complex(variable)]]) + !! - ap_logical ([[strings(module):st_logical(variable)]]) + !! - ap_integer ([[strings(module):st_integer(variable)]]) + !! - ap_real ([[strings(module):st_real(variable)]]) + !! + !! `action` value should be one of the following module constants: + !! - [[argparse(module):ap_store(variable)]] + !! - [[argparse(module):ap_append(variable)]] + !! - [[argparse(module):ap_count(variable)]] + !! - [[argparse(module):ap_help(variable)]] + !! + !! `nrec` string can take the following forms: + !! tag | description + !! :-: | : ------------- + !! ? | zero or one argument's value + !! * | any number of arguments + !! + | one or more argument's value(s) + !! X | Exactly X values. Where X is the string representation of an integer (0 is accepted). + !! + !! See also [[argparse(module):ap_add_option_2(function)]] documentation. + OBJECT(argparser), INTENT(inout) :: this + !! An argparser object reference + CHARACTER(len=*), INTENT(in) :: dest + !! A string with the name of the argument + CHARACTER(len=2), INTENT(in) :: sflag + !! A two characters string with the short option flag of the argument + CHARACTER(len=*), INTENT(in) :: lflag + !! A string (3 characters minimum) with the long option flag of the argument + INTEGER, INTENT(in), OPTIONAL :: type + !! An integer with the type of the argument + INTEGER, INTENT(in), OPTIONAL :: action + !! An integer with the action of the argument + CHARACTER(len=*), INTENT(in), OPTIONAL :: default + !! A string with the default value of the argument if not provided in the CLI + CHARACTER(len=*), INTENT(in), OPTIONAL :: nrec + !! A string with the expected number of specified values for the argument in the CLI. + CHARACTER(len=*), INTENT(in), OPTIONAL :: help + !! A string with a short description of the argument + CHARACTER(len=*), DIMENSION(:), INTENT(in), OPTIONAL :: meta + !! A vector of strings with the displayed value's name(s) of the argument in the help command + TYPE(error) :: err + !! Error object with the first error encountered in the process. + CHARACTER(len=:), ALLOCATABLE :: de,na,he + INTEGER :: ty,ac + TYPE(argc) :: arg + err = noerror + he = "" ; IF (PRESENT(help)) he = TRIM(help) + na = "" ; IF (PRESENT(nrec)) na = TRIM(nrec) + ty = ap_undef ; IF (PRESENT(type)) ty = type + ac = ap_undef ; IF (PRESENT(action)) ac = action + de ='' ; IF (PRESENT(default)) de = TRIM(default) + IF (.NOT.this%init) THEN + err = error("argparse: parser not initialized yet",-1) + RETURN + ENDIF + IF (LEN_TRIM(dest) == 0) THEN + err = error("argparse: Invalid argument (empty dest)",-2) + RETURN + ENDIF + arg%name = TRIM(dest) ; arg%help = TRIM(he) + IF (PRESENT(meta)) THEN + err = ac_check_and_set(arg,sflag,lflag,ty,ac,de,na,meta) + ELSE + err = ac_check_and_set(arg,sflag,lflag,ty,ac,de,na) + ENDIF + IF (err /= noerror) RETURN + err = ap_check_in_parser(this,arg) + IF (err /= noerror) RETURN + CALL ap_append_arg(this,arg) + CALL clear_argc(arg) + END FUNCTION ap_add_option_1 + + FUNCTION ap_add_option_2(this,dest,flag,type,action,default,nrec,help,meta) RESULT(err) + !! Add an argument to the parser (interface #2) + !! + !! The function is a wrapper to [[argparse(module):ap_add_option_1(function)]]. In this version, + !! only one option flag is required. The method only checks for the (trimmed) length of **flag** in + !! order to choose wether it is a **short** or **long** option flag. Then the function simply calls + !! [[argparse(module):ap_add_option_1(function)]] to set the argument. + !! + !! Other dummy arguments have the same meaning as in [[argparse(module):ap_add_option_1(function)]]. + OBJECT(argparser), INTENT(inout) :: this + !! An argparser object reference + CHARACTER(len=*), INTENT(in) :: dest + !! A string with the name of the argument + CHARACTER(len=*), INTENT(in) :: flag + !! A string with either the short or long option flag + INTEGER, INTENT(in), OPTIONAL :: type + !! A string with the type of the argument + INTEGER, INTENT(in), OPTIONAL :: action + !! A string with the action of the argument + CHARACTER(len=*), INTENT(in), OPTIONAL :: default + !! A string with the default value of the argument if not provided in the CLI + CHARACTER(len=*), INTENT(in), OPTIONAL :: nrec + !! A string with the expected number of specified values for the argument in the CLI. + CHARACTER(len=*), INTENT(in), OPTIONAL :: help + !! A string with a short description of the argument + CHARACTER(len=*), DIMENSION(:), INTENT(in), OPTIONAL :: meta + !! A vector of strings with the displayed value's name(s) of the argument in the help command + TYPE(error) :: err + !! Error object with the first error encountered in the process. + CHARACTER(len=:), ALLOCATABLE :: sf,lf,de,na,he + INTEGER :: ty,ac + err = noerror + sf = ' ' ; lf = '' + IF (LEN_TRIM(flag) == 2) THEN + sf = TRIM(flag) + ELSE + lf = TRIM(flag) + ENDIF + he = "" ; IF (PRESENT(help)) he = TRIM(help) + na = "" ; IF (PRESENT(nrec)) na = TRIM(nrec) + ty = ap_undef ; IF (PRESENT(type)) ty = type + ac = ap_undef ; IF (PRESENT(action)) ac = action + de = '' ; IF (PRESENT(default)) de = TRIM(default) + ! Calling "true" function + IF (PRESENT(meta)) THEN + err = ap_add_option_1(this,dest,sf,lf,ty,ac,de,na,he,meta) + ELSE + err = ap_add_option_1(this,dest,sf,lf,ty,ac,de,na,he) + ENDIF + RETURN + END FUNCTION ap_add_option_2 + + FUNCTION ap_check_in_parser(this,arg) RESULT(err) + !! Check if an argument is already set in the parser + !! An argument is assumed to be already set in the parser if either its name, + !! short or long option flag is already defined (in the parser). + OBJECT(argparser), INTENT(in) :: this + !! An argparser object reference + TYPE(argc), INTENT(in) :: arg + !! An argc object to check + TYPE(error) :: err + !! Error object with -15 id if object is already set, no error otherwise. + INTEGER :: i + err = noerror + IF (this%nargs == 0 ) RETURN + DO i=1,this%nargs + ! note : we could have use the == operator but we want to get an specific + ! error message) + IF (TRIM(this%args(i)%name) == TRIM(arg%name)) THEN + err = error("argparse: argument '"//TRIM(arg%name)//"' already defined",-8) ; RETURN + ENDIF + IF (LEN_TRIM(this%args(i)%sflag) > 0 .AND. & + TRIM(this%args(i)%sflag) == TRIM(arg%sflag)) THEN + err = error("argparse: flag '"//TRIM(arg%sflag)//"' already defined",-8) ; RETURN + ENDIF + IF (LEN_TRIM(this%args(i)%lflag) > 0 .AND. & + TRIM(this%args(i)%lflag) == TRIM(arg%lflag)) THEN + err = error("argparse: flag '"//TRIM(arg%lflag)//"' already defined",-8) ; RETURN + ENDIF + ENDDO + RETURN + END FUNCTION ap_check_in_parser + + FUNCTION ap_parse_options(this,cmd,help_req) RESULT(err) + !! Parse options of the internal command line + !! This (internal) function manages the parsing of the command line options. + OBJECT(argparser), INTENT(inout), TARGET :: this + !! An argparser object reference + TYPE(words), INTENT(inout) :: cmd + !! A [[strings(module):words(type)]] object with the command-line to parse + LOGICAL, INTENT(out) :: help_req + !! An output logical flag with `.true.` if help option has been found, `.false.` otherwise + TYPE(error) :: err + !! Error object with the first error encountered in the process + CHARACTER(len=1), PARAMETER :: sq = CHAR(39) + CHARACTER(len=:), ALLOCATABLE :: elt + INTEGER :: arg_idx + INTEGER :: i,nv,ic + err = noerror ; arg_idx = -1 + help_req = .false. + DO WHILE(words_valid(cmd)) + ! get current element + elt = words_current(cmd) + ! check element kind: is it an option flag (-1/0)or a value (1)? + ic = ap_check_string(this,elt,arg_idx) + IF (ic <= 0) THEN + IF (arg_idx /= -1) THEN + err = ap_fill_argument(this,cmd,this%args(arg_idx)) + IF (err == 0 .AND. this%args(arg_idx)%paction == ap_help) THEN + this%parsed = 1 + err = argparser_get_value(this,'help',help_req) + EXIT + ENDIF + IF (err /= 0) EXIT + ELSE + err = error("Unknown argument ('"//elt//"')",-9) + EXIT + ENDIF + ELSE + ! We are in the positionals !!! + IF (TRIM(elt) == '--') CALL words_next(cmd) + EXIT + ENDIF + ! iterates to next value + CALL words_next(cmd) + ENDDO + + ! Do we need to check for error here ? + IF (err /= 0) THEN + this%parsed = 0 + arg_idx = -1 + RETURN + ELSE IF (help_req) THEN + arg_idx = -1 + RETURN + ENDIF + + ! Must check here for argument with append action if they have the correct + ! number of argument + DO i=1,this%nargs + nv = words_length(this%args(i)%values) + IF (this%args(i)%fnd .AND. & + this%args(i)%paction == ap_append .AND. & + this%args(i)%nrec > 0 .AND. & + nv /= this%args(i)%nrec) THEN + IF (this%args(i)%nrec < nv) THEN + err = ac_fmt_val_err(this%args(i),-18) ! extra values + ELSE + err = ac_fmt_val_err(this%args(i),-17) ! missing values + ENDIF + ENDIF + ENDDO + IF (err /= 0) this%parsed = 0 + RETURN + END FUNCTION ap_parse_options + + FUNCTION ap_parse_positionals(this,cmd) RESULT(err) + !! Parse positional arguments of the internal command line + !! This (internal) function manages the parsing of the command line positional arguments. + OBJECT(argparser), INTENT(inout) :: this + !! An argparser object reference + TYPE(words), INTENT(inout) :: cmd + !! A [[strings(module):words(type)]] object with the command-line to parse + TYPE(error) :: err + !! Error object with the first error encountered in the process + INTEGER :: na + CHARACTER(len=:), ALLOCATABLE :: elt + err = noerror + ! cmd iterator is located at the first positional argument + + ! no positional required but current word is valid + ! Either : no positional required but valid element is present + ! Or : positional required but no valid element is present + IF ((this%have_posal.AND..NOT.words_valid(cmd)) .OR. & + (.NOT.this%have_posal.AND.words_valid(cmd))) THEN + err = error("Wrong number of arguments",-16) ; RETURN + ENDIF + ! ugly patch : we must clear this%posals%values because of the automatic + ! setting of default value + CALL words_clear(this%posals%values) + this%posals%fnd = .true. + DO + na = words_length(this%posals%values) + IF (words_valid(cmd)) THEN + ! Gets the element value + elt = words_current(cmd) + ! and add it + CALL words_append(this%posals%values,elt) + ELSE + ! no more elements: check against the number of expected records + ! 1 or + elements expected but nothing has been saved + IF (this%posals%nrec == -3 .AND. na > 1) THEN + err = error("Extra value(s) found (positionals arguments)",-18) + ELSE IF (this%posals%nrec == -2 .AND. na == 0) THEN + err = error("Missing values (positionals arguments)",-17) + ELSE IF (this%posals%nrec > 0 .AND. na /= this%posals%nrec) THEN + IF (na > this%posals%nrec) THEN + err = error("Extra value(s) found (positionals arguments)",-18) + ELSE + err = error("Missing values (positionals arguments)",-17) + ENDIF + ENDIF + EXIT + ENDIF + ! get to the next element + CALL words_next(cmd) + ENDDO + IF (err /= noerror) THEN + this%posals%fnd = .false. + this%parsed = 0 + ENDIF + RETURN + END FUNCTION ap_parse_positionals + + FUNCTION ap_fill_argument(this,cmd,arg) RESULT(err) + !! Fill an argument with values + !! + !! The function parses remaining parts of the command line from the position of + !! the given argument and attempts to retrieve its value(s) (if any). + !! Several tests are performed and may raise errors. The function always stops + !! at the first error encountered which can be one of the following : + !! - Invalid value type (conversion check failed) + !! - Missing values (can not get as much values as defined in the argument) + !! - Extra values found (more values can be retrieved from the command line + !! than defined in the argument) + OBJECT(argparser), INTENT(inout) :: this + !! An argparser object reference + TYPE(words), INTENT(inout) :: cmd + !! The command line + TYPE(argc), INTENT(inout), TARGET :: arg + !! An argc object reference with the argument currently processed. + TYPE(error) :: err + !! Error object with the first error encountered in the process + INTEGER :: ca, isopt, itmp + LOGICAL :: ltmp + CHARACTER(len=:), ALLOCATABLE :: elt + err = noerror + ! We always reset arguments value if we are in store mode. + ! If one wants to set an option several times and keeps track of the + ! previous values, she must use 'append' + IF (arg%paction == ap_store) CALL words_clear(arg%values) + ! Gets values as a function of the expected number of records + IF (arg%nrec == 0) THEN + ! parse_args (main parsing method) reset all values: for 0 nrec + ! we should have at least one value saved which is the default. + ! if it is not the case we set default as values of the argument + IF (words_length(arg%values) == 0) CALL words_append(arg%values,arg%default) + ! NOW HANDLING 0 records case: + ! we do not have to consume any argument but : + ! - trigger a boolean (set it to .not.default) + ! - increase a counter (if action == 'count') + IF (arg%paction == ap_count) THEN + elt = words_pop(arg%values) + READ(elt,*) itmp ; itmp = itmp + 1 + CALL words_append(arg%values,TO_STRING(itmp)) + ELSE IF (arg%ptype == ap_logical) THEN + elt = words_pop(arg%values) + READ(elt,*) ltmp + CALL words_append(arg%values,TO_STRING(.NOT.ltmp)) + ENDIF + ELSE + ! For any other case, the algorithm is quite simple : + ! We consume tokens of the command-line until either the end or + ! the next option (or '--' separator) + ! When the exit condition is met we perform some tests based on the + ! expected argument and sets the returned error object... + ca = 0 ; IF(arg%paction == ap_append) ca = words_length(arg%values) + DO + CALL words_next(cmd) ; elt = words_current(cmd) ; isopt = ap_check_string(this,elt) + ! We have a "valid" value + IF (((.NOT.words_valid(cmd)).EQV.(isopt<=0)).AND.TRIM(elt) /= '--') THEN + ! we have a value that we should check for conversion ! + err = ac_check_value(arg,elt) + IF (err /= 0) THEN + err = ac_fmt_val_err(arg,-2) + ELSE + CALL words_append(arg%values,elt) ; ca = ca + 1 + ENDIF + ELSE + ! 3 cases are possible : + ! 1) we have consumed all argument of command line + ! 2) current argument is not a value ! + ! 3) current argument the separator '--' + IF (isopt <= 0 .OR. TRIM(elt)=='--') CALL words_previous(cmd) + IF (arg%nrec == -2 .AND. words_length(arg%values) == 0) & + err = ac_fmt_val_err(arg,-17) + IF (arg%paction /= ap_append .AND. arg%nrec > 0 .AND. ca /= arg%nrec) & + THEN + IF (ca > arg%nrec) THEN + err = ac_fmt_val_err(arg,-18) + ELSE + err = ac_fmt_val_err(arg,-17) + ENDIF + ENDIF + EXIT + ENDIF + IF (err /= noerror) EXIT + IF (arg%nrec == -3) EXIT + IF (ca == arg%nrec) EXIT + ENDDO + ENDIF + arg%fnd = (err == noerror) + RETURN + END FUNCTION ap_fill_argument + + FUNCTION ap_split_cmd(this,string,new_cmd,rhelp) RESULT(err) + !! Preprocess the command line + !! The function reads and splits the given string so merged options/values + !! are splitted and saves the resulting string elements in a list of words. + !! @warning + !! For compilers that does not support allocatable strings in derived types, + !! computation are highly dependent of [[strings(module):st_slen(variable): + !! tokens length are limited by this parameter. + IMPLICIT NONE + OBJECT(argparser), INTENT(in) :: this + !! An argparser object reference + CHARACTER(len=*), INTENT(in) :: string + !! A string to process + TYPE(words), INTENT(out) :: new_cmd + !! An output [[strings(module):words(type)]] object with the processed command line + LOGICAL, INTENT(out) :: rhelp + !! An output boolean flag with `.true.` if help is requested, `.false.` otherwise + TYPE(error) :: err + !! Error object with the first error encountered in the process + INTEGER :: isopt,j,tl,res + CHARACTER(len=:), ALLOCATABLE :: elt + TYPE(words) :: splitted + INTEGER :: arg_idx + err = noerror ; rhelp = .false. + IF (LEN_TRIM(string) == 0) THEN + err = error('internal error (empty string)',-2) + RETURN + ENDIF + ! split input command line in words ! + splitted = new_words(string," ",.true.) ! tokens may be truncated :( + ! reset iterator + CALL words_reset(splitted) + DO WHILE(words_valid(splitted)) + elt = words_current(splitted) ; tl = LEN_TRIM(elt) + isopt = ap_check_string(this,TRIM(elt),arg_idx) + ! we have a short option : maybe we need to split it + IF (isopt == -1 ) THEN + DO j=2,tl + res = ap_check_string(this,"-"//elt(j:j),arg_idx) + ! great we have another short option flag + IF (res == -1 .AND. arg_idx /= -1) THEN ! another short option ! + rhelp = (this%args(arg_idx)%paction == ap_help.OR.rhelp) + ! we must not set some argument's values here for help argument + ! if auto is not set the parse method will disable the option + ! during next! parsing process + CALL words_append(new_cmd,"-"//elt(j:j)) + ELSE + IF (j == 2) THEN ! no more option flag ! + CALL words_append(new_cmd,TRIM(elt(j-1:))) + ELSE + CALL words_append(new_cmd,TRIM(elt(j:))) + ENDIF + EXIT ! WE MUST EXIT !!!!!!! + ENDIF + ENDDO + ELSE + IF (isopt == 0.AND.arg_idx /= -1) & + rhelp = (this%args(arg_idx)%paction == ap_help.OR.rhelp) + ! we must not set some argument's values here for help argument + ! if auto is not set the parse method will disable the option during + ! next parsing process + CALL words_append(new_cmd,TRIM(elt)) + ENDIF + ! Iterates to next word + CALL words_next(splitted) + ENDDO + CALL words_clear(splitted) + RETURN + END FUNCTION ap_split_cmd + + FUNCTION ap_check_string(this,string,idx) RESULT(ret) + !! Check if a string is an option flag + !! The function checks if the given string is either a short, long option flag or a value. + !! @warning + !! An empty string is considered as a value ! + OBJECT(argparser), INTENT(in) :: this + !! An argparser object reference + CHARACTER(len=*), INTENT(in) :: string + !! A string to check + INTEGER, INTENT(out), OPTIONAL :: idx + !! An optional output intger with the index of the afferent argument in the parser (-1 if not found) + INTEGER :: ret + !! Return code with the following possible values: + !! - -1 if the string is a SHORT option flag + !! - 0 if the string is a LONG option flag + !! - 1 if it considered as a value + CHARACTER(len=52), PARAMETER :: alpha = "abcdefghijklmnopqrstuvwxyz& + &ABCDEFGHIJKLMNOPQRSTUVWXYZ" + ! return code can be either : + ! -1 : it's a short option flag + ! 0 : it's a long option flag + ! 1 : it's a value + ! The combination of the (optional) output index and the return code + ! allows to check if an option is known or not + ret = 1 + ! '--' is special : it is a separator that is seen as a value. + IF (TRIM(string) == '--') RETURN + IF (PRESENT(idx)) idx = -1 + ! First we will check the two first characters of the string + IF (LEN_TRIM(string) >= 2) THEN + IF (string(1:1) == ACHAR(45)) THEN + ! It's a long option flag ! + IF (string(2:2) == ACHAR(45)) THEN + ret = 0 + IF (PRESENT(idx)) idx = ap_get_arg_index(this,lflag=TRIM(string)) + ELSE + ! It's a short option flag ! + IF (INDEX(alpha, string(2:2)) /= 0) THEN + ret = -1 + IF (PRESENT(idx)) idx = ap_get_arg_index(this,sflag=string(1:2)) + ENDIF + ENDIF + ENDIF + ENDIF + RETURN + END FUNCTION ap_check_string + + FUNCTION ap_gen_help(this) RESULT(hlp) + !! Generate the help string + OBJECT(argparser), INTENT(inout) :: this + !! An argparser object reference + CHARACTER(len=:), ALLOCATABLE :: hlp + !! The formatted help message + CHARACTER(len=:), ALLOCATABLE :: copt,spc,opts,text + INTEGER :: i,j,ia,optmw,i1,io,n,zw,zh + IF (this%width == 0) CALL fs_termsize(zh,this%width) + zw = this%width + ! Sets usage + CALL ap_format_usage(this,optmw) + ! computes the help position + optmw = optmw +2 + 2 ! +2 for indentation + 2 for spaces after option + optmw = MIN(MAX(5,this%mxhlpos-1),optmw) + hlp = TRIM(this%usg)//NEW_LINE('A')//NEW_LINE('A') + ! Sets description + IF (LEN_TRIM(this%descr) /= 0) & + hlp=hlp//getpar(this%descr,zw,2)//NEW_LINE('A')//NEW_LINE('A') + ! Sets positionals + IF (this%have_posal) THEN + IF (LEN_TRIM(this%posals%help) /= 0) THEN + hlp=hlp//'positionals:'//NEW_LINE('A') + copt = ac_get_opt_str(this%posals) ; n = LEN_TRIM(copt) + hlp=hlp//getpar(copt,zw,idt1=2) + ! we must put help on a new line : no need to extends opt with spaces + IF (n > optmw-2) THEN + hlp=hlp//NEW_LINE('A')//REPEAT(CHAR(32),optmw) + ELSE + hlp=hlp//REPEAT(CHAR(32),optmw-n-2) + ENDIF + spc = REPEAT(CHAR(32),optmw) + text = getpar(this%posals%help,zw-optmw,0,0) + j=1 + DO WHILE(j <= LEN(text)) + i = INDEX(text(j:),NEW_LINE('A')) + IF (i /= 0) THEN + hlp=hlp//text(j:j+i-1)//spc + j=j+i + ELSE + hlp=hlp//text(j:) ; EXIT + ENDIF + ENDDO + hlp=hlp//NEW_LINE('A')//NEW_LINE('A') + ENDIF + ENDIF + ! Sets options + IF (this%nargs > 0) THEN + opts='' + DO ia=1, this%nargs + IF (LEN_TRIM(this%args(ia)%help) /= 0) THEN + copt = ac_get_opt_str(this%args(ia)) ; n = LEN_TRIM(copt) + opts=opts//getpar(copt,zw,idt1=2) + ! we must put help on a new line : no need to extends opt with spaces + IF (n > optmw-2) THEN + opts=opts//NEW_LINE('A')//REPEAT(CHAR(32),optmw) + ELSE + opts=opts//REPEAT(CHAR(32),optmw-n-2) + ENDIF + spc = REPEAT(CHAR(32),optmw) + text = getpar(this%args(ia)%help,zw-optmw,0,0) + j=1 + DO WHILE(j <= LEN(text)) + i = INDEX(text(j:),NEW_LINE('A')) + IF (i /= 0) THEN + opts=opts//text(j:j+i-1)//spc + j=j+i + ELSE + opts=opts//text(j:) ; EXIT + ENDIF + ENDDO + opts=opts//NEW_LINE('A') + ENDIF + ENDDO + IF (LEN_TRIM(opts) > 0) hlp=hlp//'options:'//NEW_LINE('A')//opts + ENDIF + IF (LEN_TRIM(this%eplg) /= 0) THEN + hlp=hlp//NEW_LINE('A')//getpar(this%eplg,zw,2)//NEW_LINE('A') + ENDIF + RETURN + END FUNCTION ap_gen_help + + SUBROUTINE ap_format_usage(this,optmw) + !! Format command line usage + !! The subroutine creates and formats the command line usage of the + !! given argparser object. If [[argparser(type):usg(variable)]] is already set (i.e. not empty) + !! then the method only computes the maximum width of the option part of the usage command + !! (see `optmw` argument description) if needed. In the other case, the method builds the usage + !! line based on the arguments stored in the parser. + OBJECT(argparser), INTENT(inout) :: this + !! An argparser object reference + INTEGER, INTENT(out), OPTIONAL :: optmw + !! An optional integer with the maximum length of the option part of the usage command. + !! This variable is intended to set a fancy indentation while printing option in the helper. + CHARACTER(len=:), ALLOCATABLE :: usage, idts, copt,pgn + INTEGER :: i,omw,idt,cl,wopt + ! Get/Checks/Sets maximum width + ! get program name + pgn = get_progname() + omw = 0 + IF (LEN_TRIM(this%usg) == 0) THEN + idt = 8 + LEN_TRIM(pgn) + ALLOCATE(CHARACTER(LEN=idt+1) :: idts) + idts(1:1) = NEW_LINE('A') ; idts(2:idt+1) = CHAR(32) + ! Builds the usage string + usage = "usage: "//TRIM(pgn)//CHAR(32) + ! Looping over arguments + cl = idt + DO i=1,this%nargs + ! gets max length for help options + copt = ac_get_opt_str(this%args(i)) ; wopt=LEN_TRIM(copt) + IF (LEN_TRIM(this%args(i)%help) /= 0.AND. wopt > omw) omw = wopt + !IF (LEN_TRIM(copt) > omw) omw = LEN_TRIM(copt) ; copt="" + ! Retrieve current argument usage string + copt = ac_get_usg_opt_str(this%args(i)) + ! Set a new line if it does not hold width + IF (cl+LEN_TRIM(copt) > this%width) THEN + cl = idt ; usage = usage(:)//idts(:) + ENDIF + ! Write the argument usage + a blank space ! + usage = usage(:)//TRIM(copt)//CHAR(32) + cl = cl + LEN_TRIM(copt)+1 + ENDDO + IF (PRESENT(optmw)) optmw = omw + ! handling positional + IF (this%have_posal) THEN + copt = ac_get_usg_opt_str(this%posals) + IF (LEN_TRIM(copt) > 0) THEN + ! print newline if it cannot fit + IF (cl+LEN_TRIM(copt) > this%width) usage = usage(:)//idts(:) + usage = usage(:)//TRIM(copt) + ENDIF + ENDIF + this%usg = usage + ELSE + IF (PRESENT(optmw)) THEN + DO i=1,this%nargs + copt = ac_get_opt_str(this%args(i)) ; wopt=LEN_TRIM(copt) + IF (LEN_TRIM(this%args(i)%help) /= 0.AND.wopt > omw) omw = wopt + copt = "" + ENDDO + optmw = omw + ENDIF + ENDIF + END SUBROUTINE ap_format_usage + + SUBROUTINE ap_affect_parser(this,other) + !! Argparser assignment operator subroutine + !! The subroutine assigns `other` to `this` + TYPE(argparser), INTENT(out) :: this + !! An argparser object to be assigned + TYPE(argparser), INTENT(in) :: other + !! An argparser object to assign + INTEGER :: i + IF (other%nargs > 0) THEN + this%nargs = other%nargs + ALLOCATE(this%args(this%nargs)) + DO i=1,this%nargs ; this%args(i) = other%args(i) ; ENDDO + ENDIF + this%have_posal = other%have_posal + this%posals = other%posals + this%parsed = other%parsed +#if HAVE_FTNDTSTR + IF (ALLOCATED(other%usg)) this%usg = other%usg + IF (ALLOCATED(other%descr)) this%descr = other%descr + IF (ALLOCATED(other%eplg)) this%eplg = other%eplg +#else + this%usg = other%usg + this%descr = other%descr + this%eplg = other%eplg +#endif + this%mxhlpos = other%mxhlpos + this%width = other%width + this%init = other%init + END SUBROUTINE ap_affect_parser + + ! argc methods + ! ------------ + + SUBROUTINE ac_affect_arg(this,other) + !! Argc object assignment operator subroutine + !! The subroutine assigns `other` to `this` + TYPE(argc), INTENT(out) :: this + !! An argc object to be assigned + TYPE(argc), INTENT(in) :: other + !! An argc object to assign + this%nrec = other%nrec + this%paction = other%paction + this%ptype = other%ptype + this%fnd = other%fnd + this%sflag = other%sflag +#if HAVE_FTNDTSTR + IF (ALLOCATED(other%name)) this%name = other%name + IF (ALLOCATED(other%lflag)) this%lflag = other%lflag + IF (ALLOCATED(other%help)) this%help = other%help + IF (ALLOCATED(other%default)) this%default = other%default +#else + this%name = other%name + this%lflag = other%lflag + this%default = other%default + this%help = other%help +#endif + CALL words_clear(this%values) + CALL words_clear(this%meta) + this%values = other%values + this%meta = other%meta + RETURN + END SUBROUTINE ac_affect_arg + + FUNCTION ac_equals_arg(this,other) RESULT(ret) + !! Check if two arguments are identical + !! The method checks if two arguments are equal based on their name, short option flag and long + !! option flag.Two arguments are considered equals if at least one of these three members is equal + !! and not empty. + TYPE(argc), INTENT(in) :: this + !! First argc object to compare + TYPE(argc), INTENT(in) :: other + !! Second argc object to compare + LOGICAL :: ret + !! `.true.` if the two objects are equal, `.false.` otherwise. + CHARACTER(len=:), ALLOCATABLE :: tna,ona,tsf,osf,tlf,olf + INTEGER :: tn,ts,tl,on,os,ol + ret = .false. + tsf = TRIM(this%sflag) ; osf = TRIM(this%sflag) +#if HAVE_FTNDTSTR + tna="" ; IF (ALLOCATED(this%name)) tna=TRIM(this%name) + ona="" ; IF (ALLOCATED(other%name)) ona=TRIM(other%name) + tlf="" ; IF (ALLOCATED(this%lflag)) tlf=TRIM(this%lflag) + olf="" ; IF (ALLOCATED(other%lflag)) olf=TRIM(other%lflag) +#else + tna=TRIM(this%name) ; ona=TRIM(other%name) + tlf=TRIM(this%lflag) ; olf=TRIM(other%lflag) +#endif + tn=LEN_TRIM(tna) ; on=LEN_TRIM(ona) + tl=LEN_TRIM(tlf) ; ol=LEN_TRIM(olf) + ts=LEN_TRIM(tsf) ; os=LEN_TRIM(osf) + ! check on name : + ! Returns True if at least of name, sflag and lflag is set to non-empty + ! string and is indentical for the two argument ! + ret = ((tn/=0 .AND. on==tn) .AND. tna == ona) .OR. & + ((tl/=0 .AND. ol==tl) .AND. tlf == olf) .OR. & + ((ts/=0 .AND. os==ol) .AND. tsf == osf) + DEALLOCATE(tna,ona,tsf,osf,tlf,olf) + END FUNCTION ac_equals_arg + + FUNCTION ac_differs_arg(this,other) RESULT(ret) + !! Check if two arguments are different + !! The method checks if two arguments are different based on their names, short option flag + !! and long option flag. + !! @note + !! This function is the extact contrary of [[argparse(module):ac_equals_arg(function)]] ! + TYPE(argc), INTENT(in) :: this + !! First argc object to compare + TYPE(argc), INTENT(in) :: other + !! Second argc object to compare + LOGICAL :: ret + !! `.true.` if the two objects are different, `.false.` otherwise. + ret = .NOT. ac_equals_arg(this,other) + END FUNCTION ac_differs_arg + + SUBROUTINE ac_clear_arg_sc(arg) + !! argc destructor (scalar) + !! The subroutine frees all memory used by an argc object and resets its member to + !! default values. + TYPE(argc), INTENT(inout) :: arg + !! An argc object to free + CALL words_clear(arg%values) + CALL words_clear(arg%meta) + arg%ptype = ap_logical + arg%paction = ap_store + arg%nrec = 0 + arg%fnd = .false. + arg%sflag = " " +#if HAVE_FTNDTSTR + IF (ALLOCATED(arg%default)) DEALLOCATE(arg%default) + IF (ALLOCATED(arg%name)) DEALLOCATE(arg%name) + IF (ALLOCATED(arg%lflag)) DEALLOCATE(arg%lflag) + IF (ALLOCATED(arg%help)) DEALLOCATE(arg%help) +#else + arg%default = "" + arg%name = "" + arg%help = "" + arg%lflag = "" +#endif + END SUBROUTINE ac_clear_arg_sc + + SUBROUTINE ac_clear_arg_ve(args) + !! argc destructor (vector) + TYPE(argc), INTENT(inout), DIMENSION(:), TARGET :: args + !! A vector of argc objects to free + INTEGER :: i + CALL words_clear(args%values) + CALL words_clear(args%meta) + DO i=1, SIZE(args) + args(i)%ptype = ap_logical + args(i)%paction = ap_store + args(i)%nrec = 0 + args(i)%fnd = .false. + args(i)%sflag = " " +#if HAVE_FTNDTSTR + IF (ALLOCATED(args(i)%default)) DEALLOCATE(args(i)%default) + IF (ALLOCATED(args(i)%name)) DEALLOCATE(args(i)%name) + IF (ALLOCATED(args(i)%lflag)) DEALLOCATE(args(i)%lflag) + IF (ALLOCATED(args(i)%help)) DEALLOCATE(args(i)%help) +#else + args(i)%default = "" + args(i)%name = "" + args(i)%help = "" + args(i)%lflag = "" +#endif + ENDDO + END SUBROUTINE ac_clear_arg_ve + + FUNCTION ac_found(this) RESULT(yes) + !! Check if argument has been found in the command line + TYPE(argc), INTENT(in) :: this + !! An argc object + LOGICAL :: yes + !! `.true.` if the option has been parsed, `.false.` otherwise + yes = this%fnd + END FUNCTION ac_found + + FUNCTION ac_get_num_values(this) RESULT(num) + !! Get the actual number of values stored in the argument + TYPE(argc), INTENT(in) :: this + !! An argc object + INTEGER :: num + !! The number of values stored in the argument + num = words_length(this%values) + END FUNCTION ac_get_num_values + + FUNCTION ac_get_usg_opt_str(arg) RESULT(line) + !! Build and format the option string for the usage part of the help message + !! The function is private part of the help builder. It creates the + !! option string part of a given argument. + TYPE(argc), INTENT(in), TARGET :: arg + !! An argc object + CHARACTER(len=:), ALLOCATABLE :: line,meta + !! Allocated string with the option flags string + line="" + IF (LEN_TRIM(arg%sflag) > 0) THEN + line="["//TRIM(arg%sflag) + ELSE IF (LEN_TRIM(arg%lflag) > 0) THEN + line="["//TRIM(arg%lflag) + ENDIF + meta = TRIM(words_get(arg%meta,1)) + SELECT CASE (arg%nrec) + CASE (-3) + line=line(:)//" ["//meta//"]" + CASE (-2) + line=line(:)//CHAR(32)//meta//" [...]" + CASE (-1) + line=line(:)//" ["//meta//" [...]]" + CASE (0) + ! DO NOTHING BUT MUST BE EXPLICITELY SET + CASE DEFAULT + meta = words_to_string(arg%meta," ") + line = line(:)//CHAR(32)//meta + END SELECT + IF (line(1:1) == "[") line=line(:)//"]" + RETURN + END FUNCTION ac_get_usg_opt_str + + FUNCTION ac_get_opt_str(arg) RESULT(line) + !! Build and format the option flag string for the option part of the help message + !! The function is private part of the help builder. It creates the + !! option string part of a given argument for the options part of the help. + TYPE(argc), INTENT(in), TARGET :: arg + !! An argc object + CHARACTER(len=:), ALLOCATABLE :: line + !! Allocated string with the option flags string + CHARACTER(len=:), ALLOCATABLE :: values,m + ! creates values string + m = TRIM(words_get(arg%meta,1)) + SELECT CASE (arg%nrec) + CASE(-3) + values="["//m//"]" + CASE(-2) + values=m//" [...]" + CASE(-1) + values="["//m//" [...]]" + CASE (0) + values="" + CASE DEFAULT + values = words_to_string(arg%meta," ") + END SELECT + ! build the final string + ! -s values, --long values + line="" + IF (LEN_TRIM(arg%sflag) > 0) THEN + line=TRIM(arg%sflag)//CHAR(32)//TRIM(values) + IF (LEN_TRIM(arg%lflag) > 0) line = line(:)//", " + ENDIF + IF (LEN_TRIM(arg%lflag) > 0) THEN + line = line(:)//TRIM(arg%lflag)//CHAR(32)//TRIM(values) + ENDIF + ! this line handles positionals :) + IF (arg%name == 'positional') line = TRIM(values) + RETURN + END FUNCTION ac_get_opt_str + + FUNCTION ac_fmt_val_err(arg,id) RESULT(ret) + !! Format specific error for argc values + !! The function formats argparse specific errors when extra (missing) values + !! are (not) set or when given values are not consistent with argument's type. + !! For each of these errors, the basic error is updated with a more precise + !! message. + TYPE(argc), INTENT(in) :: arg + !! An argc object + INTEGER, INTENT(in) :: id + !! Integer with the error id (-3, -15 or -16 in fact) + TYPE(error) :: ret + !! Error object with the updated error message. + CHARACTER(len=:), ALLOCATABLE :: msg,nv + IF (LEN_TRIM(arg%sflag) /= 0) THEN + msg=' ('//arg%sflag + ELSE ! note that normally if no sflag are present lflag should be set + msg=' ('//TRIM(arg%lflag) + ENDIF + nv = to_string(arg%nrec) ; IF (arg%nrec < 0) nv='1' + ! we only handle ids : -2 (invalid arg), -17 (missing values), -18 (extra values) + SELECT CASE(id) + CASE (-2) ! invalid value: cannot cast -> + msg = msg//" option expects '"//apt2str(arg%ptype)//"' values)" + CASE (-17) ! missing values -> -17 + IF (arg%nrec == -2) THEN + msg = msg//' takes at least '//nv//' value(s))' + ELSE + msg = msg//' takes exactly '//nv//' value(s))' + ENDIF + CASE (-18) ! extra values -> -18 + IF (arg%nrec == -3) THEN + msg = msg//' takes at most '//nv//' value(s))' + ELSE + msg = msg//' takes exactly '//nv//' value(s))' + ENDIF + CASE DEFAULT + msg='' + END SELECT + ret = error(msg,id) + END FUNCTION ac_fmt_val_err + + FUNCTION ac_check_and_set(this,sf,lf,ty,ac,de,na,meta,check_flag) RESULT(ret) + !! Interface to all argc's member tests + !! The function calls all the tests to perform on argc members. Some of these tests can + !! alter argc's member values to fit argparser's requirements. + !! @note + !! Normally, program should be stopped if returned error is not 0 ! + TYPE(argc), INTENT(inout) :: this + !! An argc object + CHARACTER(len=2), INTENT(in) :: sf + !! A string (2 chars wide) with the short option flag + CHARACTER(len=*), INTENT(in) :: lf + !! A string with the long option flag + INTEGER, INTENT(in) :: ty + !! An integer with the type of the argument + INTEGER, INTENT(in) :: ac + !! An integer with the action of the argument + CHARACTER(len=*), INTENT(in) :: de + !! A string with the default value of the argument + CHARACTER(len=*), INTENT(in) :: na + !! A string pattern with the expected number of values for the argument + CHARACTER(len=*), INTENT(in), DIMENSION(:), OPTIONAL :: meta + !! An optional vector of strings with the Meta-name of the values + LOGICAL, INTENT(in), OPTIONAL :: check_flag + !! An optional boolean flag hat instructs the method wether to check for option flag + !! or not. By default this test is enabled but it should be disabled if one wants to + !! check for POSITIONAL arguments as they do not have option flags. + TYPE(error) :: ret + !! Error object with the first error encountered in the process + LOGICAL :: zflag + zflag = .true. ; IF (PRESENT(check_flag)) zflag = check_flag + ! 1) CHECKING FLAG SYNTAX + IF (zflag) THEN + ret = ac_check_flags(this,sf,lf) ; IF (ret /= 0) RETURN + ELSE + this%sflag = sf ; this%lflag = lf + ENDIF + ! 2) CHECKING AND SETTING action, type, default value and number of record + ret = ac_check_ac_ty_de_na(this,ac,ty,de,na) ; IF (ret /= 0) RETURN + ! 3) Sets/updates meta name + IF (PRESENT(meta)) THEN + CALL ac_set_meta(this,meta) + ELSE + CALL ac_set_meta(this) + ENDIF + RETURN + END FUNCTION ac_check_and_set + + FUNCTION ac_check_ac_ty_de_na(this,ac,ty,de,na) RESULT(ret) + !! Check and set argc's action, type and default value + !! The method checks if input argument's options are valid and update the argc object + !! consequently. + TYPE(argc), INTENT(inout) :: this + !! An argc object to update + INTEGER, INTENT(in) :: ac + !! An integer with the action to set and check + INTEGER, INTENT(in) :: ty + !! An integer with the type to set and check + CHARACTER(len=*), INTENT(in) :: de + !! A string with the default value to set and check + CHARACTER(len=*), INTENT(in) :: na + !! A string with the expected number of value to set and check + TYPE(error) :: ret + !! Error object with the first error encountered in the process + CHARACTER(len=:), ALLOCATABLE :: eprf,zna + TYPE(error) :: uty,ina + ret = noerror + eprf = 'argparse: '//"Invalid argument `"//TRIM(this%name)//"'" + uty = error(eprf//" (type)",-2) + ina = error(eprf//" (inconsistent nargs)",-2) + zna = TRIM(na) + ! Checks action + IF(ANY(ap_actions == ac).OR.ac == ap_undef) THEN + this%paction = ac + ELSE + ret = error(eprf//" (action)",-2) ; RETURN + ENDIF + ! Checks and sets type and default as a function of the action + SELECT CASE(this%paction) + ! HELP: fixed in any case: + CASE(ap_help) + this%default = 'F' + this%ptype = ap_logical + this%nrec = 0 + ! COUNT: + ! we always use "hard-coded" stuff and do not warn if dev has made + ! mistakes... + CASE(ap_count) + ! default settings of the count action + this%ptype = ap_integer ; this%default = '0' ; this%nrec = 0 + ! check and set default value + ret = set_def_val() + ! STORE, APPEND actions + CASE (ap_store, ap_append) + ! set type + IF (ty == ap_undef) THEN + this%ptype= ap_integer + ELSEIF (ANY(ap_types == ty)) THEN + this%ptype = ty + ELSE + ret = uty ; RETURN + ENDIF + ! check and set default value + ret = set_def_val() ; IF (ret /= 0) RETURN + ! check for nargs (if na is empty then we set "*") + ret = set_nrec("*") + ! UNDEFINED: + ! -> 1) set to action to store + ! -> + ! try to define a logical trigger and modifies it with user-defined + ! characteristics + CASE (ap_undef) + ! 1) always define store action + this%paction = ap_store + ! 2) set type and nrec: + ! 2.1) If type is undef: + ! - to default value type if default is given + ! - ap_logical otherwiset type + ! 2.2) set nrec + ! - if final type is ap_logical set nrec to 0 + ! - otherwise to * + If (ty == ap_undef) THEN + ! no explicit type : define logical trigger first + this%ptype = ap_logical ; this%nrec = 0 + ! icheck the default value given + IF (LEN_TRIM(de) > 0) THEN + this%ptype = ap_types(string_is(de)+1) + ELSE + this%ptype = ap_logical + ENDIF + IF (this%ptype == ap_logical) THEN + ret = set_nrec("0") + ELSE + ret = set_nrec("1") + ENDIF + ret = set_def_val() + IF (ret /= 0) RETURN + ! type is given + ELSE IF (ANY(ty == ap_types)) THEN + ! known type given : + ! check default value and nrec: -> if na not given set "*" + this%ptype = ty + ret = set_def_val() ; IF (ret /= 0) RETURN + IF (this%ptype == ap_logical) THEN + ret = set_nrec("0") + ELSE + ret = set_nrec("1") + ENDIF + ELSE + ! unknown type => bad end ! + ret = uty ; RETURN + ENDIF + END SELECT + ! set default value as first value if ret is noerror .... + IF (ret == 0) CALL words_append(this%values,this%default) + RETURN + + CONTAINS + + FUNCTION set_nrec(base) RESULT(terr) + !! Check and set argument's expected number of records + !! The method compares `na` value with the expected and known flags and decides + !! wether to raise an error or defines nrec member of the argument object. If `na` + !! is empty then `base` is used. + CHARACTER(len=1),INTENT(in) :: base + !! Base value of nrec + TYPE(error) :: terr + !! Error object with the return status of the function + terr = noerror + ! check for nargs: + IF (LEN(zna) == 0) zna=base + SELECT CASE(zna) + CASE("*") ; this%nrec = -1 + CASE("+") ; this%nrec = -2 + CASE("?") ; this%nrec = -3 + IF (this%paction == ap_append) terr = ina + CASE DEFAULT ; this%nrec = 0 + ! check numeric characters + IF (VERIFY(zna,"0123456789")==0) READ(zna,*) this%nrec + IF (this%nrec == 0) terr = ina + END SELECT + END FUNCTION set_nrec + + FUNCTION set_def_val() RESULT(terr) + !! Check and set argument's default value + !! The method compares `de` value with the type already stored in the argument and + !! decides wether to raise an error or to save `de` as argument's default value. + !! If `de` is empty then it sets a default value according to argument's type. + TYPE(error) :: terr + !! Error object with the return status of the function + INTEGER :: t + terr = noerror + IF (LEN_TRIM(de) /= 0) THEN + this%default = de ; t = string_is(de) + IF (t /= this%ptype) THEN + terr = error(eprf//" (inconsistent default value: expected '"// & + TRIM(st_type_names(this%ptype))//"', found '"// & + TRIM(st_type_names(t))//"')",-2) + RETURN + ENDIF + ELSE + SELECT CASE (this%ptype) + CASE(ap_string) ; this%default = '' + CASE(ap_logical) ; this%default = 'F' + CASE(ap_complex) ; this%default = '(0d0,0d0)' + CASE(ap_integer) ; this%default = '0' + CASE(ap_real) ; this%default = '0d0' + END SELECT + ENDIF + RETURN + END FUNCTION set_def_val + END FUNCTION ac_check_ac_ty_de_na + + FUNCTION ac_check_flags(this,sflag,lflag) RESULT(ret) + !! Set and check if argument's option flags are valid + !! The method first sets the given flags in the argc object and then checks if + !! its option flags are valid : + !! - A valid short option flag (`sflag`) starts with `-' followed by the + !! regex pattern : @p [a-zA-Z] + !! - A valid long option flag (`lflag`) starts with `--' followed by the + !! regex pattern : @p [-a-zA-Z_0-9]+ + !! @note + !! Although the two arguments are mandatory one can be an empty string + TYPE(argc), INTENT(inout) :: this + !! An argc object + CHARACTER(len=2), INTENT(in) :: sflag + !! A 2-characters wide string with the short option flag + CHARACTER(len=*), INTENT(in) :: lflag + !! A string (at least 3 characters wide) with the long option flag + TYPE(error) :: ret + !! Error object with the first error encountered in the process + INTEGER :: ic + ret = noerror + this%sflag = sflag ; this%lflag = lflag + ! 1) Check null strings ! + IF (LEN_TRIM(this%sflag) == 0 .AND. LEN_TRIM(this%lflag) == 0) THEN + ret = error("argparse: Invalid argument (empty option flags)",-2) ; RETURN + ENDIF + ! 2) Check short option flag: + IF (LEN_TRIM(this%sflag) > 0) THEN + IF (this%sflag(1:1) /= achar(45)) THEN + ret = error("argparse: Invalid argument (short option)",-2) ; RETURN + ELSE + SELECT CASE(iachar(this%sflag(2:2))) + CASE(97:122,65:90) ; ret = noerror + CASE DEFAULT + ret = error("argparse: Invalid argument (short option)",-2) ; RETURN + END SELECT + ENDIF + ENDIF + ! 3) Check long option flag + IF (LEN_TRIM(this%lflag) > 0) THEN + ! We must have at least 3 chars ! + IF (LEN_TRIM(this%lflag) < 3) THEN + ret = error("argparse: Invalid argument (long option)",-2) ; RETURN + ELSE IF (this%lflag(1:2) /= achar(45)//achar(45)) THEN + ret = error("argparse: Invalid argument (long option)",-2) ; RETURN + ELSE + DO ic=3,LEN_TRIM(this%lflag) + SELECT CASE(iachar(this%lflag(ic:ic))) + ! corresponds to [-a-zA-Z0-9_] + CASE(45,48:57,65:90,95,97:122) ; ret = noerror + CASE DEFAULT + ret = error("argparse: Invalid argument (long option)",-2) ; RETURN + EXIT + END SELECT + ENDDO + ENDIF + ENDIF + RETURN + END FUNCTION ac_check_flags + + SUBROUTINE ac_set_meta(this, meta) + !! Set meta-variable of the given argc object + !! The method set meta-variable in the argc object. If no `meta` are given, the method + !! uses argument's name to set the values. + !! @warning + !! To be effective, this subroutine must be called after argparse::chk_opt_nargs + TYPE(argc), INTENT(inout) :: this + !! An argc object reference + CHARACTER(len=*), INTENT(in), DIMENSION(:), OPTIONAL :: meta + !! An optional vector of strings with the meta-variable(s) to set + INTEGER :: i,j,ms,blk + CHARACTER(len=:), ALLOCATABLE :: zmeta + ! clear meta values (not needed normally) + CALL words_clear(this%meta) + IF (PRESENT(meta)) THEN + SELECT CASE(this%nrec) + CASE(-3,-2,-1) + zmeta = str_to_upper(meta(1)) + blk = INDEX(TRIM(zmeta),CHAR(32)) - 1 + IF (blk <= 0) blk=LEN_TRIM(zmeta) + CALL words_append(this%meta,zmeta(1:blk)) + CASE(0) + CALL words_append(this%meta,"") + CASE DEFAULT + ms = SIZE(meta) ; j = 0 + DO i=1,this%nrec + j=j+1 ; IF (j>ms) j=1 + zmeta = str_to_upper(meta(j)) + blk=INDEX(TRIM(zmeta),CHAR(32))-1 + IF (blk <= 0) blk=LEN_TRIM(zmeta) + CALL words_append(this%meta,zmeta(1:blk)) + ENDDO + END SELECT + ELSE + zmeta = str_to_upper(TRIM(this%name)) + SELECT CASE(this%nrec) + CASE(-3,-2,-1) + CALL words_append(this%meta,zmeta) + CASE DEFAULT + DO i=1,this%nrec + CALL words_append(this%meta,zmeta) + ENDDO + END SELECT + ENDIF + RETURN + END SUBROUTINE ac_set_meta + + FUNCTION ac_check_value(this,str) RESULT(err) + !! Check if given string is a valid value for the argument + TYPE(argc), INTENT(in) :: this + !! An argc object reference + CHARACTER(len=*), INTENT(in) :: str + !! A string with the value to check + TYPE(error) :: err + !! Error object with the first error encountered in the process + INTEGER :: ty + err = noerror + ! Special conditions for strings: any kind of value is ok if we asked for + ! strings + IF (this%ptype == ap_string) RETURN + ty = string_is(str) + ! special handling for integer: they can be seen as real + IF (this%ptype == ap_real) THEN + IF (ty < 3) err = error("Cannot cast value",-10) + ELSE + IF (ty /= this%ptype) err = error("Cannot cast value",-10) + ENDIF + RETURN + END FUNCTION ac_check_value + + !=========== + ! GETTERS + !=========== + + ! argparser getters + ! ----------------- + + FUNCTION ap_get_positional_sc(this,idx,value) RESULT(ret) + !! Get positional arguments value at given index + !! @warning + !! On error, the status of `value` is undefined. + OBJECT(argparser), INTENT(in) :: this + !! An argparser object reference + INTEGER, INTENT(in) :: idx + !! Subscript of the positional argument value to get + CHARACTER(len=:), INTENT(out), ALLOCATABLE :: value + !! Output raw value of the positional. If `idx` is out of range, `value` is set to an + !! empty string. + TYPE(error) :: ret + !! Error object with the first error encountered in the process + IF (.NOT.this%have_posal) THEN + ret = error("argparse: No positional argument(s) defined",-7) + ELSE IF (idx <= 0 .OR. idx > words_length(this%posals%values)) THEN + ret = error("argparse: index out of range", -3) + ELSE + value = words_get(this%posals%values,idx) + ret = noerror + ENDIF + RETURN + END FUNCTION ap_get_positional_sc + + FUNCTION ap_get_positional_ve(this,values) RESULT(ret) + !! Get all positional arguments value + !! @warning + !! On error, the status of `values` is undefined. + OBJECT(argparser), INTENT(in) :: this + !! An argparser object reference + CHARACTER(len=*), INTENT(out), ALLOCATABLE, DIMENSION(:) :: values + !! An allocatable vector of **assumed length** strings with the value(s) of all + !! positionals arguments found. + TYPE(error) :: ret + !! Error object with the first error encountered in the process + LOGICAL :: ok + ret = noerror + IF (.NOT.this%have_posal) THEN + ret = error("argparse: No positional argument(s) defined",-7) + ELSE IF (words_length(this%posals%values) == 0) THEN + ret = error("argparse: No positional argument(s) values found",-6) + ELSE + ok = words_to_vector(this%posals%values,values) + ENDIF + RETURN + END FUNCTION ap_get_positional_ve + + FUNCTION ap_get_dv_sc(this, name, output) RESULT(ret) + !! Get a scalar `REAL(kind=8)` value from given argument + !! The error returned by the method can be either: + !! - 0 : No error + !! - -1 : parser has not been initialized + !! - -7 : argument not found (i.e. does not set in the parser) + !! - -19 : parsing not done yet + !! - -20 : (previous) parsing failed + !! - -21 : inconsistent destination type + !! @note + !! If no error occured, the function always set a value which is the default value + !! if the argument has not been parsed. Otherwise, `output` value is undefined. + OBJECT(argparser), INTENT(in) :: this + !! An argparser object reference + CHARACTER(len=*), INTENT(in) :: name + !! Name of the argument + REAL(kind=8), INTENT(out) :: output + !! A scalar with the first value of the argument + TYPE(error) :: ret + !! Error object with the first error encountered in the process + INTEGER :: idx + ret = ap_check_state(this) + IF (ret == 0) THEN + idx = ap_get_arg_index(this,name) + IF (idx == -1) THEN + ret = error("argparse: Argument not found ("//TRIM(name)//")",-7) + ELSE + ret = argc_get_value(this%args(idx),output) + ENDIF + ENDIF + RETURN + END FUNCTION ap_get_dv_sc + + FUNCTION ap_get_rv_sc(this, name, output) RESULT(ret) + !! Get a scalar `REAL(kind=4)` value from given argument + !! The error returned by the method can be either: + !! - 0 : No error + !! - -1 : parser has not been initialized + !! - -7 : argument not found (i.e. does not set in the parser) + !! - -19 : parsing not done yet + !! - -20 : (previous) parsing failed + !! - -21 : inconsistent destination type + !! @note + !! If no error occured, the function always set a value which is the default value + !! if the argument has not been parsed. Otherwise, `output` value is undefined. + OBJECT(argparser), INTENT(in) :: this + !! An argparser object reference + CHARACTER(len=*), INTENT(in) :: name + !! Name of the argument + REAL(kind=4), INTENT(out) :: output + !! A scalar with the first value of the argument + TYPE(error) :: ret + !! Error object with the first error encountered in the process + INTEGER :: idx + ret = ap_check_state(this) + IF (ret == 0) THEN + idx = ap_get_arg_index(this,name) + IF (idx == -1) THEN + ret = error("argparse: Argument not found ("//TRIM(name)//")",-7) + ELSE + ret = argc_get_value(this%args(idx),output) + ENDIF + ENDIF + RETURN + END FUNCTION ap_get_rv_sc + + FUNCTION ap_get_iv_sc(this, name, output) RESULT(ret) + !! Get a scalar `INTEGER` value from given argument + !! The error returned by the method can be either: + !! - 0 : No error + !! - -1 : parser has not been initialized + !! - -7 : argument not found (i.e. does not set in the parser) + !! - -19 : parsing not done yet + !! - -20 : (previous) parsing failed + !! - -21 : inconsistent destination type + !! @note + !! If no error occured, the function always set a value which is the default value + !! if the argument has not been parsed. Otherwise, `output` value is undefined. + OBJECT(argparser), INTENT(in) :: this + !! An argparser object reference + CHARACTER(len=*), INTENT(in) :: name + !! Name of the argument + INTEGER, INTENT(out) :: output + !! A scalar with the first value of the argument + TYPE(error) :: ret + !! Error object with the first error encountered in the process + INTEGER :: idx + ret = ap_check_state(this) + IF (ret == 0) THEN + idx = ap_get_arg_index(this,name) + IF (idx == -1) THEN + ret = error("argparse: Argument not found ("//TRIM(name)//")",-7) + ELSE + ret = argc_get_value(this%args(idx),output) + ENDIF + ENDIF + RETURN + END FUNCTION ap_get_iv_sc + + FUNCTION ap_get_lv_sc(this, name, output) RESULT(ret) + !! Get a scalar `LOGICAL` value from given argument + !! The error returned by the method can be either: + !! - 0 : No error + !! - -1 : parser has not been initialized + !! - -7 : argument not found (i.e. does not set in the parser) + !! - -19 : parsing not done yet + !! - -20 : (previous) parsing failed + !! - -21 : inconsistent destination type + !! @note + !! If no error occured, the function always set a value which is the default value + !! if the argument has not been parsed. Otherwise, `output` value is undefined. + OBJECT(argparser), INTENT(in) :: this + !! An argparser object reference + CHARACTER(len=*), INTENT(in) :: name + !! Name of the argument + LOGICAL, INTENT(out) :: output + !! A scalar with the first value of the argument + TYPE(error) :: ret + !! Error object with the first error encountered in the process + INTEGER :: idx + ret = ap_check_state(this) + IF (ret == 0) THEN + idx = ap_get_arg_index(this,name) + IF (idx == -1) THEN + ret = error("argparse: Argument not found ("//TRIM(name)//")",-7) + ELSE + ret = argc_get_value(this%args(idx),output) + ENDIF + ENDIF + RETURN + END FUNCTION ap_get_lv_sc + + FUNCTION ap_get_cv_sc(this, name, output) RESULT(ret) + !! Get a scalar `COMPLEX` value from given argument + !! The error returned by the method can be either: + !! - 0 : No error + !! - -1 : parser has not been initialized + !! - -7 : argument not found (i.e. does not set in the parser) + !! - -19 : parsing not done yet + !! - -20 : (previous) parsing failed + !! - -21 : inconsistent destination type + !! @note + !! If no error occured, the function always set a value which is the default value + !! if the argument has not been parsed. Otherwise, `output` value is undefined. + OBJECT(argparser), INTENT(in) :: this + !! An argparser object reference + CHARACTER(len=*), INTENT(in) :: name + !! Name of the argument + COMPLEX, INTENT(out) :: output + !! A scalar with the first value of the argument + TYPE(error) :: ret + !! Error object with the first error encountered in the process + INTEGER :: idx + ret = ap_check_state(this) + IF (ret == 0) THEN + idx = ap_get_arg_index(this,name) + IF (idx == -1) THEN + ret = error("argparse: Argument not found ("//TRIM(name)//")",-7) + ELSE + ret = argc_get_value(this%args(idx),output) + ENDIF + ENDIF + RETURN + END FUNCTION ap_get_cv_sc + + FUNCTION ap_get_sv_sc(this, name, output) RESULT(ret) + !! Get a scalar `STRING` value from given argument + !! The error returned by the method can be either: + !! - 0 : No error + !! - -1 : parser has not been initialized + !! - -7 : argument not found (i.e. does not set in the parser) + !! - -19 : parsing not done yet + !! - -20 : (previous) parsing failed + !! - -21 : inconsistent destination type + !! @note + !! If no error occured, the function always set a value which is the default value + !! if the argument has not been parsed. Otherwise, `output` status is undefined. + OBJECT(argparser), INTENT(in) :: this + !! An argparser object reference + CHARACTER(len=*), INTENT(in) :: name + !! Name of the argument + CHARACTER(len=:), INTENT(out), ALLOCATABLE :: output + !! An allocatable string with the first value of the argument + TYPE(error) :: ret + !! Error object with the first error encountered in the process + INTEGER :: idx + ret = ap_check_state(this) + IF (ret == 0) THEN + idx = ap_get_arg_index(this,name) + IF (idx == -1) THEN + ret = error("argparse: Argument not found ("//TRIM(name)//")",-7) + ELSE + ret = argc_get_value(this%args(idx),output) + ENDIF + ENDIF + RETURN + END FUNCTION ap_get_sv_sc + + FUNCTION ap_get_dv_ve(this, name, output) RESULT(ret) + !! Get a vector of `REAL(kind=8)` values from given argument + !! The error returned by the method can be either: + !! - 0 : No error + !! - -1 : parser has not been initialized + !! - -7 : argument not found (i.e. does not set in the parser) + !! - -19 : parsing not done yet + !! - -20 : (previous) parsing failed + !! - -21 : inconsistent destination type + !! @note + !! If no error occured, the function always set a value which is the default value + !! if the argument has not been parsed. Otherwise, `output` status is undefined. + OBJECT(argparser), INTENT(in) :: this + !! An argparser object reference + CHARACTER(len=*), INTENT(in) :: name + !! Name of the argument + REAL(kind=8), INTENT(out), ALLOCATABLE, DIMENSION(:) :: output + !! An allocatable vector with the values of the argument + TYPE(error) :: ret + !! Error object with the first error encountered in the process + INTEGER :: idx + ret = ap_check_state(this) + IF (ret == 0) THEN + idx = ap_get_arg_index(this,name) + IF (idx == -1) THEN + ret = error("argparse: Argument not found ("//TRIM(name)//")",-7) + ELSE + ret = argc_get_value(this%args(idx),output) + ENDIF + ENDIF + END FUNCTION ap_get_dv_ve + + FUNCTION ap_get_rv_ve(this, name, output) RESULT(ret) + !! Get a vector of `REAL(kind=4)` values from given argument + !! The error returned by the method can be either: + !! - 0 : No error + !! - -1 : parser has not been initialized + !! - -7 : argument not found (i.e. does not set in the parser) + !! - -19 : parsing not done yet + !! - -20 : (previous) parsing failed + !! - -21 : inconsistent destination type + !! @note + !! If no error occured, the function always set a value which is the default value + !! if the argument has not been parsed. Otherwise, `output` status is undefined. + OBJECT(argparser), INTENT(in) :: this + !! An argparser object reference + CHARACTER(len=*), INTENT(in) :: name + !! Name of the argument + REAL(kind=4), INTENT(out), ALLOCATABLE, DIMENSION(:) :: output + !! An allocatable vector with the values of the argument + TYPE(error) :: ret + !! Error object with the first error encountered in the process + INTEGER :: idx + ret = ap_check_state(this) + IF (ret == 0) THEN + idx = ap_get_arg_index(this,name) + IF (idx == -1) THEN + ret = error("argparse: Argument not found ("//TRIM(name)//")",-7) + ELSE + ret = argc_get_value(this%args(idx),output) + ENDIF + ENDIF + END FUNCTION ap_get_rv_ve + + FUNCTION ap_get_iv_ve(this, name, output) RESULT(ret) + !! Get a vector of `INTEGER` values from given argument + !! The error returned by the method can be either: + !! - 0 : No error + !! - -1 : parser has not been initialized + !! - -7 : argument not found (i.e. does not set in the parser) + !! - -19 : parsing not done yet + !! - -20 : (previous) parsing failed + !! - -21 : inconsistent destination type + !! @note + !! If no error occured, the function always set a value which is the default value + !! if the argument has not been parsed. Otherwise, `output` status is undefined. + OBJECT(argparser), INTENT(in) :: this + !! An argparser object reference + CHARACTER(len=*), INTENT(in) :: name + !! Name of the argument + INTEGER, INTENT(out), ALLOCATABLE, DIMENSION(:) :: output + !! An allocatable vector with the values of the argument + TYPE(error) :: ret + !! Error object with the first error encountered in the process + INTEGER :: idx + ret = ap_check_state(this) + IF (ret == 0) THEN + idx = ap_get_arg_index(this,name) + IF (idx == -1) THEN + ret = error("argparse: Argument not found ("//TRIM(name)//")",-7) + ELSE + ret = argc_get_value(this%args(idx),output) + ENDIF + ENDIF + END FUNCTION ap_get_iv_ve + + FUNCTION ap_get_lv_ve(this, name, output) RESULT(ret) + !! Get a vector of `LOGICAL` values from given argument + !! The error returned by the method can be either: + !! - 0 : No error + !! - -1 : parser has not been initialized + !! - -7 : argument not found (i.e. does not set in the parser) + !! - -19 : parsing not done yet + !! - -20 : (previous) parsing failed + !! - -21 : inconsistent destination type + !! @note + !! If no error occured, the function always set a value which is the default value + !! if the argument has not been parsed. Otherwise, `output` status is undefined. + OBJECT(argparser), INTENT(in) :: this + !! An argparser object reference + CHARACTER(len=*), INTENT(in) :: name + !! Name of the argument + LOGICAL, INTENT(out), ALLOCATABLE, DIMENSION(:) :: output + !! An allocatable vector with the values of the argument + TYPE(error) :: ret + !! Error object with the first error encountered in the process + INTEGER :: idx + ret = ap_check_state(this) + IF (ret == 0) THEN + idx = ap_get_arg_index(this,name) + IF (idx == -1) THEN + ret = error("argparse: Argument not found ("//TRIM(name)//")",-7) + ELSE + ret = argc_get_value(this%args(idx),output) + ENDIF + ENDIF + END FUNCTION ap_get_lv_ve + + FUNCTION ap_get_cv_ve(this, name, output) RESULT(ret) + !! Get a vector of `COMPLEX` values from given argument + !! The error returned by the method can be either: + !! - 0 : No error + !! - -1 : parser has not been initialized + !! - -7 : argument not found (i.e. does not set in the parser) + !! - -19 : parsing not done yet + !! - -20 : (previous) parsing failed + !! - -21 : inconsistent destination type + !! @note + !! If no error occured, the function always set a value which is the default value + !! if the argument has not been parsed. Otherwise, `output` status is undefined. + OBJECT(argparser), INTENT(in) :: this + !! An argparser object reference + CHARACTER(len=*), INTENT(in) :: name + !! Name of the argument + COMPLEX, INTENT(out), ALLOCATABLE, DIMENSION(:) :: output + !! An allocatable vector with the values of the argument + TYPE(error) :: ret + !! Error object with the first error encountered in the process + INTEGER :: idx + ret = ap_check_state(this) + IF (ret == 0) THEN + idx = ap_get_arg_index(this,name) + IF (idx == -1) THEN + ret = error("argparse: Argument not found ("//TRIM(name)//")",-7) + ELSE + ret = argc_get_value(this%args(idx),output) + ENDIF + ENDIF + END FUNCTION ap_get_cv_ve + + FUNCTION ap_get_sv_ve(this, name, output) RESULT(ret) + !! Get a vector of `STRING` values from given argument + !! The error returned by the method can be either: + !! - 0 : No error + !! - -1 : parser has not been initialized + !! - -7 : argument not found (i.e. does not set in the parser) + !! - -19 : parsing not done yet + !! - -20 : (previous) parsing failed + !! - -21 : inconsistent destination type + !! @note + !! If no error occured, the function always set a value which is the default value + !! if the argument has not been parsed. Otherwise, `output` status is undefined. + OBJECT(argparser), INTENT(in) :: this + !! An argparser object reference + CHARACTER(len=*), INTENT(in) :: name + !! Name of the argument + CHARACTER(len=*), INTENT(out), ALLOCATABLE, DIMENSION(:) :: output + !! An allocatable vector of **assumed length** strings with the values of the argument + TYPE(error) :: ret + !! Error object with the first error encountered in the process + INTEGER :: idx + ret = ap_check_state(this) + IF (ret == 0) THEN + idx = ap_get_arg_index(this,name) + IF (idx == -1) THEN + ret = error("argparse: Argument not found ("//TRIM(name)//")",-7) + ELSE + ret = argc_get_value(this%args(idx),output) + ENDIF + ENDIF + END FUNCTION ap_get_sv_ve + + ! argc getters + ! ------------ + + !> Gets a scalar @p REAL(kind=8) value from given argument + !! @param[in,out] this An argc object + !! @param[out] output A scalar with the first value of the argument + !! @return An errors::error object with -12 if the destination variable's type + !! is inconsistent, 0 otherwise. + FUNCTION ac_get_dv_sc(this, output) RESULT(ret) + !! Get a scalar `REAL(kind=8)` value from given argument + !! If no error occured, the function always returns at least a value (whatever the parser's + !! state is) which is the default value if no specific values are set in the argument. + !! Otherwise, `output` value is undefined. + TYPE(argc), INTENT(in) :: this + !! An argc object + REAL(kind=8), INTENT(out) :: output + !! Output value + TYPE(error) :: ret + !! Error object with the -12 if the destination variable's type is inconsistent, 0 otherwise + ret = noerror + IF (this%ptype /= ap_real) THEN + ret = error("argparse: invalid type for output (expected `"// & + apt2str(this%ptype)//"' got REAL(kind=8))",-21) + ELSEIF (words_length(this%values) == 0) THEN + IF (.NOT.from_string(this%default,output)) & + ret = error("Cannot cast value",-10) + ELSE + IF (.NOT.from_string(words_get(this%values,1), output)) & + ret = error("Cannot cast value",-10) + ENDIF + RETURN + END FUNCTION ac_get_dv_sc + + FUNCTION ac_get_rv_sc(this, output) RESULT(ret) + !! Get a scalar `REAL(kind=4)` value from given argument + !! If no error occured, the function always returns at least a value (whatever the parser's + !! state is) which is the default value if no specific values are set in the argument. + !! Otherwise, `output` value is undefined. + TYPE(argc), INTENT(in) :: this + !! An argc object + REAL(kind=4), INTENT(out) :: output + !! Output value + TYPE(error) :: ret + !! Error object with the first error encountered in the process + ret = noerror + IF (this%ptype /= ap_real) THEN + ret = error("argparse: invalid type for output (expected `"// & + apt2str(this%ptype)//"' got REAL(kind=4))",-21) + ELSEIF (words_length(this%values) == 0) THEN + IF (.NOT.from_string(this%default,output)) & + ret = error("Cannot cast value",-10) + ELSE + IF (.NOT.from_string(words_get(this%values,1), output)) & + ret = error("Cannot cast value",-10) + ENDIF + RETURN + END FUNCTION ac_get_rv_sc + + FUNCTION ac_get_iv_sc(this, output) RESULT(ret) + !! Get a scalar `INTEGER` value from given argument + !! If no error occured, the function always returns at least a value (whatever the parser's + !! state is) which is the default value if no specific values are set in the argument. + !! Otherwise, `output` value is undefined. + TYPE(argc), INTENT(in) :: this + !! An argc object + INTEGER, INTENT(out) :: output + !! Output value + TYPE(error) :: ret + !! Error object with the first error encountered in the process + ret = noerror + IF (this%ptype /= ap_integer) THEN + ret = error("argparse: invalid type for output (expected `"// & + apt2str(this%ptype)//"' got INTEGER)",-21) + ELSEIF (words_length(this%values) == 0) THEN + IF (.NOT.from_string(this%default,output)) & + ret = error("Cannot cast value",-10) + ELSE + IF (.NOT.from_string(words_get(this%values,1), output)) & + ret = error("Cannot cast value",-10) + ENDIF + RETURN + END FUNCTION ac_get_iv_sc + + FUNCTION ac_get_lv_sc(this, output) RESULT(ret) + !! Get a scalar `INTEGER` value from given argument + !! If no error occured, the function always returns at least a value (whatever the parser's + !! state is) which is the default value if no specific values are set in the argument. + !! Otherwise, `output` value is undefined. + TYPE(argc), INTENT(in) :: this + !! An argc object + LOGICAL, INTENT(out) :: output + !! Output value + TYPE(error) :: ret + !! Error object with the first error encountered in the process + ret = noerror + IF (this%ptype /= ap_logical) THEN + ret = error("argparse: invalid type for output (expected `"// & + apt2str(this%ptype)//"' got LOGICAL)",-21) + ELSEIF (words_length(this%values) == 0) THEN + IF (.NOT.from_string(this%default,output)) & + ret = error("Cannot cast value",-10) + ELSE + IF (.NOT.from_string(words_get(this%values,1), output)) & + ret = error("Cannot cast value",-10) + ENDIF + RETURN + END FUNCTION ac_get_lv_sc + + FUNCTION ac_get_cv_sc(this, output) RESULT(ret) + !! Get a scalar `COMPLEX` value from given argument + !! If no error occured, the function always returns at least a value (whatever the parser's + !! state is) which is the default value if no specific values are set in the argument. + !! Otherwise, `output` value is undefined. + TYPE(argc), INTENT(in) :: this + !! An argc object + COMPLEX, INTENT(out) :: output + !! Ouput value + TYPE(error) :: ret + !! Error object with the first error encountered in the process + ret = noerror + IF (this%ptype /= ap_complex) THEN + ret = error("argparse: invalid type for output (expected `"// & + apt2str(this%ptype)//"' got COMPLEX)",-21) + ELSEIF (words_length(this%values) == 0) THEN + IF (.NOT.from_string(this%default,output)) & + ret = error("Cannot cast value",-10) + ELSE + IF (.NOT.from_string(words_get(this%values,1), output)) & + ret = error("Cannot cast value",-10) + ENDIF + RETURN + END FUNCTION ac_get_cv_sc + + FUNCTION ac_get_sv_sc(this, output) RESULT(ret) + !! Get a scalar `STRING` value from given argument + !! If no error occured, the function always returns at least a value (whatever the parser's + !! state is) which is the default value if no specific values are set in the argument. + !! Otherwise, `output` status is undefined. + TYPE(argc), INTENT(in) :: this + !! An argc object + CHARACTER(len=:), INTENT(out), ALLOCATABLE :: output + !! Output value + TYPE(error) :: ret + !! Error object with the first error encountered in the process + ret = noerror + IF (this%ptype /= ap_string) THEN + ret = error("argparse: invalid type for output (expected `"// & + apt2str(this%ptype)//"' got STRING)",-21) + ELSEIF (words_length(this%values) == 0) THEN + output = this%default + ELSE + output = words_get(this%values,1) + ENDIF + END FUNCTION ac_get_sv_sc + + FUNCTION ac_get_dv_ve(this, output) RESULT(ret) + !! Get a vector of `REAL(kind=8)` values from given argument + !! If no error occured, the function always returns at least a value (whatever the parser's + !! state is) which is the default value if no specific values are set in the argument. + !! Otherwise, `output` status is undefined. + TYPE(argc), INTENT(in) :: this + !! Argc object + REAL(kind=8), INTENT(out), ALLOCATABLE, DIMENSION(:) :: output + !! Output values + TYPE(error) :: ret + !! Error object with the first error encountered in the process + CHARACTER(len=st_slen), ALLOCATABLE, DIMENSION(:) :: tmp + LOGICAL :: ok + ret = noerror + IF (this%ptype /= ap_real) THEN + ret = error("argparse: invalid type for output (expected `"// & + apt2str(this%ptype)//"' got REAL(kind=8))",-21) + ELSEIF (words_length(this%values) == 0) THEN + ALLOCATE(output(MAX(this%nrec,1))) + ok = from_string(this%default,output(1)) + output(1:SIZE(output)) = output(1) + ELSE + IF (ALLOCATED(output)) DEALLOCATE(output) + ALLOCATE(output(words_length(this%values))) + ok = words_to_vector(this%values,tmp) + ok = from_string(tmp, output) + ENDIF + END FUNCTION ac_get_dv_ve + + FUNCTION ac_get_rv_ve(this, output) RESULT(ret) + !! Get a vector of `REAL(kind=4)` values from given argument + !! If no error occured, the function always returns at least a value (whatever the parser's + !! state is) which is the default value if no specific values are set in the argument. + !! Otherwise, `output` status is undefined. + TYPE(argc), INTENT(in) :: this + !! Argc object + REAL(kind=4), INTENT(out), ALLOCATABLE, DIMENSION(:) :: output + !! Output values + TYPE(error) :: ret + !! Error object with the first error encountered in the process + CHARACTER(len=st_slen), ALLOCATABLE, DIMENSION(:) :: tmp + LOGICAL :: ok + ret = noerror + IF (this%ptype /= ap_real) THEN + ret = error("argparse: invalid type for output (expected `"// & + apt2str(this%ptype)//"' got REAL(kind=4))",-21) + ELSEIF (words_length(this%values) == 0) THEN + ALLOCATE(output(MAX(this%nrec,1))) + ok = from_string(this%default,output(1)) + output(1:SIZE(output)) = output(1) + ELSE + IF (ALLOCATED(output)) DEALLOCATE(output) + ALLOCATE(output(words_length(this%values))) + ok = words_to_vector(this%values,tmp) + ok = from_string(tmp, output) + ENDIF + END FUNCTION ac_get_rv_ve + + FUNCTION ac_get_iv_ve(this, output) RESULT(ret) + !! Get a vector of `INTEGER` values from given argument + !! If no error occured, the function always returns at least a value (whatever the parser's + !! state is) which is the default value if no specific values are set in the argument. + !! Otherwise, `output` status is undefined. + TYPE(argc), INTENT(in) :: this + !! Argc object + INTEGER, INTENT(out), ALLOCATABLE, DIMENSION(:) :: output + !! Output values + TYPE(error) :: ret + !! Error object with the first error encountered in the process + CHARACTER(len=st_slen), ALLOCATABLE, DIMENSION(:) :: tmp + LOGICAL :: ok + ret = noerror + IF (this%ptype /= ap_integer) THEN + ret = error("argparse: invalid type for output (expected `"// & + apt2str(this%ptype)//"' got INTEGER)",-21) + ELSEIF (words_length(this%values) == 0) THEN + ALLOCATE(output(MAX(this%nrec,1))) + ok = from_string(this%default,output(1)) + output(1:SIZE(output)) = output(1) + ELSE + IF (ALLOCATED(output)) DEALLOCATE(output) + ALLOCATE(output(words_length(this%values))) + ok = words_to_vector(this%values,tmp) + ok = from_string(tmp, output) + ENDIF + END FUNCTION ac_get_iv_ve + + FUNCTION ac_get_lv_ve(this, output) RESULT(ret) + !! Get a vector of `LOGICAL` values from given argument + !! If no error occured, the function always returns at least a value (whatever the parser's + !! state is) which is the default value if no specific values are set in the argument. + !! Otherwise, `output` status is undefined. + TYPE(argc), INTENT(in) :: this + !! Argc object + LOGICAL, INTENT(out), ALLOCATABLE, DIMENSION(:) :: output + !! Output values + TYPE(error) :: ret + !! Error object with the first error encountered in the process + CHARACTER(len=st_slen), ALLOCATABLE, DIMENSION(:) :: tmp + LOGICAL :: ok + ret = noerror + IF (this%ptype /= ap_logical) THEN + ret = error("argparse: invalid type for output (expected `"// & + apt2str(this%ptype)//"' got LOGICAL)",-21) + ELSEIF (words_length(this%values) == 0) THEN + ALLOCATE(output(MAX(this%nrec,1))) + ok = from_string(this%default,output(1)) + output(1:SIZE(output)) = output(1) + ELSE + IF (ALLOCATED(output)) DEALLOCATE(output) + ALLOCATE(output(words_length(this%values))) + ok = words_to_vector(this%values,tmp) + ok = from_string(tmp, output) + ENDIF + END FUNCTION ac_get_lv_ve + + FUNCTION ac_get_cv_ve(this, output) RESULT(ret) + !! Get a vector of `COMPLEX` values from given argument + !! If no error occured, the function always returns at least a value (whatever the parser's + !! state is) which is the default value if no specific values are set in the argument. + !! Otherwise, `output` status is undefined. + TYPE(argc), INTENT(in) :: this + !! Argc object + COMPLEX, INTENT(out), ALLOCATABLE, DIMENSION(:) :: output + !! Output values + TYPE(error) :: ret + !! Error object with the first error encountered in the process + CHARACTER(len=st_slen), ALLOCATABLE, DIMENSION(:) :: tmp + LOGICAL :: ok + ret = noerror + IF (this%ptype /= ap_complex) THEN + ret = error("argparse: invalid type for output (expected `"// & + apt2str(this%ptype)//"' got COMPLEX)",-21) + ELSEIF (words_length(this%values) == 0) THEN + ALLOCATE(output(MAX(this%nrec,1))) + ok = from_string(this%default,output(1)) + output(1:SIZE(output)) = output(1) + ELSE + IF (ALLOCATED(output)) DEALLOCATE(output) + ALLOCATE(output(words_length(this%values))) + ok = words_to_vector(this%values,tmp) + ok = from_string(tmp, output) + ENDIF + END FUNCTION ac_get_cv_ve + + FUNCTION ac_get_sv_ve(this, output) RESULT(ret) + !! Get a vector of `STRING` values from given argument + !! If no error occured, the function always returns at least a value (whatever the parser's + !! state is) which is the default value if no specific values are set in the argument. + !! Otherwise, `output` status is undefined. + TYPE(argc), INTENT(in) :: this + !! Argc object + CHARACTER(len=*), INTENT(out), ALLOCATABLE, DIMENSION(:) :: output + !! Output values + TYPE(error) :: ret + !! Error object with the first error encountered in the process + ret = noerror + IF (this%ptype /= ap_string) THEN + ret = error("argparse: invalid type for output (expected `"// & + apt2str(this%ptype)//"' got STRING)",-21) + ELSEIF (words_length(this%values) == 0) THEN + ALLOCATE(output(MAX(this%nrec,1))) + output(1:SIZE(output)) = TRIM(this%default) + ELSE + IF (.NOT.words_to_vector(this%values,output)) DEALLOCATE(output) + ENDIF + END FUNCTION ac_get_sv_ve + + ! miscellaneous methods + ! --------------------- + + FUNCTION apt2str(ap_t) RESULT(str) + !! Get the string representation of argparse types constants + INTEGER, INTENT(in) :: ap_t + !! One of ap_logical, ap_integer, ap_real, ap_complex or ap_string module constants. + CHARACTER(len=:), ALLOCATABLE :: str + !! String representation of the type. + SELECT CASE(ap_t) + CASE(ap_logical) ; str = 'logical' + CASE(ap_integer) ; str = 'integer' + CASE(ap_real) ; str = 'real' + CASE(ap_complex) ; str = 'complex' + CASE(ap_string) ; str = 'string' + CASE DEFAULT ; str = 'unknown' + END SELECT + RETURN + END FUNCTION apt2str + + FUNCTION apa2str(ap_a) RESULT(str) + !! Get the string representation of argparse actions constants + INTEGER, INTENT(in) :: ap_a + !! One of ap_store, ap_append,cap_count or ap_help module constants + CHARACTER(len=:), ALLOCATABLE :: str + !! String representation of the action. + SELECT CASE(ap_a) + CASE(ap_store) ; str = 'store' + CASE(ap_append) ; str = 'append' + CASE(ap_count) ; str = 'count' + CASE(ap_help) ; str = 'help' + CASE DEFAULT ; str = 'unknown' + END SELECT + RETURN + END FUNCTION apa2str + + FUNCTION get_progname() RESULT(name) + !> Get the name of the program + CHARACTER(len=:), ALLOCATABLE :: name !! The name of the program + INTEGER :: c + CALL GET_COMMAND_ARGUMENT(0,length=c) + ALLOCATE(CHARACTER(len=c) :: name) + CALL GET_COMMAND_ARGUMENT(0,value=name) + c = INDEX(name, "/", back=.true.) + IF (c /= 0.AND.c /= LEN_TRIM(name)) name = TRIM(name(c+1:)) + END FUNCTION get_progname + +END MODULE ARGPARSE + Index: trunk/LMDZ.TITAN/libf/muphytitan/asciiread.f90 =================================================================== --- trunk/LMDZ.TITAN/libf/muphytitan/asciiread.f90 (revision 1793) +++ trunk/LMDZ.TITAN/libf/muphytitan/asciiread.f90 (revision 1793) @@ -0,0 +1,360 @@ +! Copyright Jérémie Burgalat (2010-2015) +! +! burgalat.jeremie@gmail.com +! +! This software is a computer program whose purpose is to provide configuration +! file and command line arguments parsing features to Fortran programs. +! +! This software is governed by the CeCILL-B license under French law and +! abiding by the rules of distribution of free software. You can use, +! modify and/ or redistribute the software under the terms of the CeCILL-B +! license as circulated by CEA, CNRS and INRIA at the following URL +! "http://www.cecill.info". +! +! As a counterpart to the access to the source code and rights to copy, +! modify and redistribute granted by the license, users are provided only +! with a limited warranty and the software's author, the holder of the +! economic rights, and the successive licensors have only limited +! liability. +! +! In this respect, the user's attention is drawn to the risks associated +! with loading, using, modifying and/or developing or reproducing the +! software by the user in light of its specific status of free software, +! that may mean that it is complicated to manipulate, and that also +! therefore means that it is reserved for developers and experienced +! professionals having in-depth computer knowledge. Users are therefore +! encouraged to load and test the software's suitability as regards their +! requirements in conditions enabling the security of their systems and/or +! data to be ensured and, more generally, to use and operate it in the +! same conditions as regards security. +! +! The fact that you are presently reading this means that you have had +! knowledge of the CeCILL-B license and that you accept its terms. + +!! file: asciiread.F90 +!! summary: ASCII data file reader source file +!! author: burgalat +!! date: 2013-2015 +MODULE ASCIIREAD + !! ASCII data file reader module + !! + !! This module provides a single generic method that can be used to read 2D/3D + !! data array from ASCII file. + !! + !! ```fortran + !! FUNCTION read_data(path,data) RESULT(err) + !! ``` + !! + !! Where: + !! + !! - __path__ is a string with the path of the data file. + !! - __data__ is an output __allocatable__ 2D/3D array of real(kind=8) values. + !! + !! ## Expected Format of the data file + !! + !! The input file: + !! - must use blank space(s) as value delimiter. + !! - must have a regular number of columns, that is each data line must + !! have the same number of columns. + !! - can contains any number of empty lines and/or comment line (i.e. line + !! where first non-blank character is "#"). All other lines are assumed + !! to be data. + !! Moreover, in the case of 3D data, it must use a SINGLE empty line for "depth" block separator. + !! + !! Error occured when: + !! + !! - path does not refer to a existing file (1) + !! - Logical unit 666 is not free (1) + !! - the file does not have regular data-columns number (5) + !! - at least a value cannot be cast in double precision (5) + !! + !! On error, __data__ array is not allocated. + !! + !! ## 3D data structure + !! + !! In the case of 3D data the method assumes that the input files consists in _D_ blocks + !! of _R_ lines with _C_ columns. Each block must be separated by a single empty line + !! and each columns must separated by one or more blank spaces (no tabulation ALLOWED). + !! + !! On success, the shape of the 3D output array will be _data(R,C,D)_. + USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: IOSTAT_END, IOSTAT_EOR + USE STRINGS, ONLY: tokenize,from_string, st_slen + USE ERRORS + IMPLICIT NONE + + PRIVATE + PUBLIC :: noerror,error, error_to_string,aborting + PUBLIC :: read_data, OPERATOR(/=), OPERATOR(==) + + !! Global interface to reading methods + INTERFACE read_data + MODULE PROCEDURE read_data_2d, read_data_3d + END INTERFACE + + CONTAINS + + + FUNCTION read_data_3d(path,data3d,delimiter) RESULT(err) + !! Read an input ASCII data file and stores its content in a 3D array + !! + !! The function reads an ASCII file and saves its values in a real(kind=8) 3D-array. + !! + !! The input file: + !! + !! - must have a regular number of columns, that is each data line must have the same number + !! of columns (according to the delimiter used). + !! - must use a SINGLE empty line for "depth" block separator. + !! - can contains any number of comment lines (i.e. line where first non-blank character is "#"). + !! All other lines (except empty lines) are assumed to be data. + !! + !! Error occured when: + !! - Path does not refer to a existing file (-11) + !! - No free logical unit available (-12) + !! - The file does not have regular data-columns number (-5) + !! - At least a value cannot be cast in double precision (-10) + !! + !! The method assumes the input files consists in _D_ block of _R_ lines + !! with _C_ columns. Each block must be separated by a single empty line and + !! each columns must separated by one or more blank spaces (no tabulation ALLOWED). + !! + !! On success, the shape of the 3D output array will be _output(R,C,D)_. + !! On error, the 3D output array is __not allocated__. + !! + !! @note + !! The function uses the logical unit 666 ! + CHARACTER(len=*), INTENT(in) :: path !! Path of the input data file + REAL(kind=8), INTENT(out), DIMENSION(:,:,:), ALLOCATABLE :: data3d !! 3D-array with the output values (double precision) + CHARACTER(len=*), INTENT(in), OPTIONAL :: delimiter !! Optional column delimiter(s) + TYPE(error) :: err !! Error status of the function + LOGICAL :: ok + INTEGER :: i,lc,tlc + INTEGER :: ndr,ndc,ndd + INTEGER :: ir,jc,kd + REAL(kind=8), DIMENSION(:), ALLOCATABLE :: tmp + CHARACTER(len=5) :: slc + CHARACTER(len=15) :: i2s + CHARACTER(len=:), ALLOCATABLE :: line,lm1,zdelim + CHARACTER(len=st_slen), DIMENSION(:), ALLOCATABLE :: wrds + + zdelim = CHAR(9)//CHAR(32) + IF (PRESENT(delimiter)) zdelim = delimiter + ! Check file status + INQUIRE(FILE=TRIM(path),EXIST=ok) + IF (.NOT.ok) THEN + err = error(trim(path)//": no such file",-1) ; RETURN + ENDIF + INQUIRE(unit=666,OPENED=ok) + IF (ok) THEN + err = error("lun 666 is already used",-1) ; RETURN + ENDIF + ! Open file + OPEN(666,FILE=TRIM(path),STATUS='OLD',ACTION='READ') + + ! First pass : + ! ------------ + ! - get size (rows, columns, depth) + ! - check size consistendcy + ! - check value type + lc = 0 ; tlc = 0 + ndr = -1 ; ndc = -1 ; ndd = 1 + DO WHILE(readline(666,line)) + lm1 = line + ! Read the line + lc = lc + 1 ; WRITE(slc,'(I5)') lc ; slc = ADJUSTL(slc) + ! skip comment line + IF (INDEX(TRIM(ADJUSTL(line)),"#") == 1) CYCLE + ! An empty line: new 2D block + IF (LEN_TRIM(line) == 0) THEN + ndd = ndd + 1 + IF (ndr < 0) THEN + ndr = tlc + ELSEIF (tlc /= ndr) THEN + WRITE(i2s,'(I15)') ndd ; i2s = ADJUSTL(i2s) + err = error(trim(path)//":Invalid number of lines in block #"//i2s//"(line "//TRIM(slc)//")",-5) + RETURN + ENDIF + tlc = 0 + CYCLE + ENDIF + tlc = tlc + 1 + ! Splits line in words + IF (.NOT.tokenize(line,wrds,zdelim,.true.)) THEN + ! cannot tokenize + err = error(trim(path)//": Cannot parse line "//TRIM(slc),-5) + RETURN + ELSEIF (.NOT.from_string(wrds,tmp)) THEN + ! cannot cast values + err = error(trim(path)//": Cannot cast values at line "//TRIM(slc),-5) + RETURN + ELSEIF (ndc > 0 .AND. ndc /= SIZE(wrds)) THEN + ! current number of columns not equal to last one + err = error(trim(path)//": Invalid number of columns (line "//TRIM(slc)//")",-5) + RETURN + ENDIF + IF (ndc == -1) ndc = SIZE(wrds) + ENDDO + + ! NOTE: + ! there is a possible bug if data file ends by an empty line: + ! we will have an extra empty bloc ! + ! current patch: we save the last line of the file and check it: + ! - if we have empty line, we reduce ndd by one. + IF (LEN_TRIM(lm1) == 0) ndd = ndd-1 + + ! Rewind input data file + REWIND(666) + ! Allocate memory + ALLOCATE(data3d(ndr,ndc,ndd)) + ir = 0 ; kd = 1 ; + DO WHILE(readline(666,line)) + IF (INDEX(TRIM(ADJUSTL(line)),"#") == 1) CYCLE + ir = ir + 1 + ! empty line update block subscripts + IF (LEN_TRIM(line) == 0) THEN + kd = kd + 1 ; ir = 0 ; CYCLE + ENDIF + ok = tokenize(line,wrds,zdelim,.true.) + DO jc = 1,ndc ; ok = from_string(wrds(jc),data3d(ir,jc,kd)) ; ENDDO + ENDDO + CLOSE(666) + END FUNCTION read_data_3d + + FUNCTION read_data_2d(path,data2d,delimiter) RESULT(err) + !! Read an input ASCII data file and stores its content in a 2D array + !! + !! The function reads an ASCII file and saves its values in a real(kind=8) 2D-array. + !! + !! The input file: + !! + !! - can contains any number of empty lines and/or comment line (i.e. line where first + !! non-blank character is "#"). All other lines are assumed to be data. + !! - must have a regular number of columns, that is each data line must have the same + !! number of columns. + !! - must use blank space(s) as value delimiter. + !! + !! Error occured when: + !! + !! - Path does not refer to a existing file (-1) + !! - Logical unit 666 is not free (-1) + !! - The file does not have regular data-columns number (-5) + !! - At least a value cannot be cast in double precision (-5) + !! + !! On error, the 2D output array is __not allocated__. + !! @note + !! The function uses the logical unit 666 ! + CHARACTER(len=*), INTENT(in) :: path !! Path of the input data file + REAL(kind=8), INTENT(out), DIMENSION(:,:), ALLOCATABLE :: data2d !! 2D-array with the output values (double precision) + CHARACTER(len=*), INTENT(in), OPTIONAL :: delimiter !! Optional column delimiter(s) + TYPE(error) :: err !! Error status of function. + LOGICAL :: ok + INTEGER :: i,e,vc,lc + INTEGER :: nl,nc + REAL(kind=8), DIMENSION(:), ALLOCATABLE :: tmp + CHARACTER(len=5) :: slc + CHARACTER(len=:), ALLOCATABLE :: line,zdelim + CHARACTER(len=st_slen), DIMENSION(:), ALLOCATABLE :: wrds + + zdelim = CHAR(9)//CHAR(32) + IF (PRESENT(delimiter)) zdelim = delimiter + ! Gets array size + INQUIRE(FILE=TRIM(path),EXIST=ok) + IF (.NOT.ok) THEN + err = error(trim(path)//": no such file",-1) ; RETURN + ENDIF + INQUIRE(unit=666,OPENED=ok) + IF (ok) THEN + err = error("lun 666 is already used",-1) ; RETURN + ENDIF + OPEN(666,FILE=TRIM(path),STATUS='OLD',ACTION='READ') + vc = 0 ; lc=0 ; ok = .true. + ! Read the file twice :) + lc=0 ; vc = 0 ; nc=-1 + ! First pass : get number of row values and checks everything ! + DO + ! Read the line + IF (.NOT.readline(666,line)) EXIT + lc = lc + 1 ; WRITE(slc,'(I5)') lc ; slc = ADJUSTL(slc) + ! skip empty/comment line + IF (INDEX(TRIM(ADJUSTL(line)),"#") == 1.OR.LEN_TRIM(line) == 0) CYCLE + ! update row counter + vc = vc + 1 + ! Splits line in words + IF (.NOT.tokenize(line,wrds,zdelim,.true.)) THEN + ! cannot tokenize + err = error(trim(path)//": Cannot parse line "//TRIM(slc),-5) + RETURN + ELSEIF (.NOT.from_string(wrds,tmp)) THEN + ! cannot cast values + do i=1,size(wrds) ; write(*,*) trim(wrds(i)) ; enddo + write(1111,'(a)') line + err = error(trim(path)//": Cannot cast values at line "//TRIM(slc),-5) + RETURN + ELSEIF (nc > 0 .AND. nc /= SIZE(wrds)) THEN + ! current number of columns not equal to last one + err = error(trim(path)//": Invalid number of columns (line "//TRIM(slc)//")",-5) + RETURN + ENDIF + IF (nc == -1) nc = SIZE(wrds) + ENDDO + ! Rewind input data file + REWIND(666) + nl = vc + ! allocate memory + ALLOCATE(data2d(nl,nc)) + ! Second pass : saves values :) + vc = 0 + DO WHILE(vc <= nl) + ! Reads the line + IF (.NOT.readline(666,line)) EXIT + ! Check if we have comment or null string + IF (INDEX(TRIM(ADJUSTL(line)),"#") == 1.OR.LEN_TRIM(line) == 0) CYCLE + vc = vc + 1 + ok = tokenize(line,wrds,zdelim,.true.) + DO i = 1,nc + ok = from_string(wrds(i),data2d(vc,i)) + ENDDO + ENDDO + CLOSE(666) + RETURN + END FUNCTION read_data_2d + + FUNCTION readline(lun,line) RESULT(not_eof) + !! Read a complete line + !! + !! Each time, it is called, the function reads a complete of the file opened in __lun__ + !! logical unit and returns .false. if EOF has been reached, .true. otherwise. + !! + !! The function is intended to read a file line by line: + !! + !! ```fortran + !! lu = 1 + !! open(lu,file="path/to/the/file/to/read") + !! l=0 ! A line counter + !! DO WHILE(readline(lu,line)) + !! l = l + 1 + !! WRITE(*,'("L",I2.2,": ",(a))') il,line + !! ENDDO + !! CLOSE(1) + !! ``` + INTEGER, INTENT(in) :: lun !! Logical unit with the opened file to read. + CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: line !! Processed line + LOGICAL :: not_eof !! .true. if EOF has NOT been reached yet, .false. otherwise + CHARACTER(len=50) :: buf + INTEGER :: e,sz + not_eof = .true. ; line = '' + DO + READ(lun,'(a)',ADVANCE="no",SIZE=sz,IOSTAT=e) buf + IF (e == IOSTAT_END) THEN + not_eof = .false. + IF (sz > 0) line=line//buf(1:sz) + EXIT + ELSE IF (e == IOSTAT_EOR) THEN + line = line//buf(1:sz) + EXIT + ELSE + line = line//buf + ENDIF + ENDDO + END FUNCTION readline + +END MODULE Index: trunk/LMDZ.TITAN/libf/muphytitan/cfgparse.F90 =================================================================== --- trunk/LMDZ.TITAN/libf/muphytitan/cfgparse.F90 (revision 1793) +++ trunk/LMDZ.TITAN/libf/muphytitan/cfgparse.F90 (revision 1793) @@ -0,0 +1,2104 @@ +! Copyright Jérémie Burgalat (2010-2015) +! +! burgalat.jeremie@gmail.com +! +! This software is a computer program whose purpose is to provide configuration +! file and command line arguments parsing features to Fortran programs. +! +! This software is governed by the CeCILL-B license under French law and +! abiding by the rules of distribution of free software. You can use, +! modify and/ or redistribute the software under the terms of the CeCILL-B +! license as circulated by CEA, CNRS and INRIA at the following URL +! "http://www.cecill.info". +! +! As a counterpart to the access to the source code and rights to copy, +! modify and redistribute granted by the license, users are provided only +! with a limited warranty and the software's author, the holder of the +! economic rights, and the successive licensors have only limited +! liability. +! +! In this respect, the user's attention is drawn to the risks associated +! with loading, using, modifying and/or developing or reproducing the +! software by the user in light of its specific status of free software, +! that may mean that it is complicated to manipulate, and that also +! therefore means that it is reserved for developers and experienced +! professionals having in-depth computer knowledge. Users are therefore +! encouraged to load and test the software's suitability as regards their +! requirements in conditions enabling the security of their systems and/or +! data to be ensured and, more generally, to use and operate it in the +! same conditions as regards security. +! +! The fact that you are presently reading this means that you have had +! knowledge of the CeCILL-B license and that you accept its terms. + +!! file: cfgparse.F90 +!! summary: Configuration file parser source file +!! author: burgalat +!! date: 2013-2015, 2017 + +#include "defined.h" + +MODULE CFGPARSE + !! Configuration file parsing module + !! + !! This module defines a set of derived types as well as methods to parse configuration files. + !! @todo + !! Add interpolation from environment and/or parser options + USE, INTRINSIC :: ISO_FORTRAN_ENV + USE ERRORS + USE STRINGS + USE FSYSTEM + IMPLICIT NONE + + PRIVATE + + PUBLIC :: cfg_clear, cfg_read_config, cfg_write_config, & + cfg_get_value, cfg_set_value, cfg_count, cfg_check_name, & + cfg_has_option, cfg_has_section, & + cfg_remove_option, cfg_remove_section, & + cfg_sort_options + + PUBLIC :: noerror,error, error_to_string, aborting + + ! some public definitions from other modules + ! from strings + PUBLIC :: str_to_lower,st_slen, st_llen + + PUBLIC :: OPERATOR(==), OPERATOR(/=), ASSIGNMENT(=) + + TYPE, PUBLIC :: option + !! Define an option + CHARACTER(len=st_slen), PRIVATE :: name = "" !! Name of the option + CHARACTER(len=st_slen), PRIVATE :: section = "" !! Associated section name. + TYPE(words), PRIVATE :: values !! Values of the option + END TYPE option + + TYPE, PUBLIC :: cfgparser + !! Define a parser of options + !! + !! A [[cfgparser(type)]] stores [[option(type)]] objects. + TYPE(option), DIMENSION(:), ALLOCATABLE :: options !! list of options. +#if HAVE_FTNPROC + CONTAINS + PROCEDURE, PRIVATE :: cp_get_rv_sc + PROCEDURE, PRIVATE :: cp_get_dv_sc + PROCEDURE, PRIVATE :: cp_get_iv_sc + PROCEDURE, PRIVATE :: cp_get_lv_sc + PROCEDURE, PRIVATE :: cp_get_cv_sc + PROCEDURE, PRIVATE :: cp_get_sv_sc + PROCEDURE, PRIVATE :: cp_get_rv_ve + PROCEDURE, PRIVATE :: cp_get_dv_ve + PROCEDURE, PRIVATE :: cp_get_iv_ve + PROCEDURE, PRIVATE :: cp_get_lv_ve + PROCEDURE, PRIVATE :: cp_get_cv_ve + PROCEDURE, PRIVATE :: cp_get_sv_ve + PROCEDURE, PRIVATE :: cp_set_rv_sc + PROCEDURE, PRIVATE :: cp_set_dv_sc + PROCEDURE, PRIVATE :: cp_set_iv_sc + PROCEDURE, PRIVATE :: cp_set_lv_sc + PROCEDURE, PRIVATE :: cp_set_cv_sc + PROCEDURE, PRIVATE :: cp_set_sv_sc + PROCEDURE, PRIVATE :: cp_set_rv_ve + PROCEDURE, PRIVATE :: cp_set_dv_ve + PROCEDURE, PRIVATE :: cp_set_iv_ve + PROCEDURE, PRIVATE :: cp_set_lv_ve + PROCEDURE, PRIVATE :: cp_set_cv_ve + PROCEDURE, PRIVATE :: cp_set_sv_ve + !> Read configuration file + PROCEDURE, PUBLIC :: read_config => cfg_read_config + !> Write configuration file + PROCEDURE, PUBLIC :: write_config => cfg_write_config + !> Get the number of sections in the parser + PROCEDURE, PUBLIC :: count => cfg_count + !> Clean the parser (delete all options, free memory) + PROCEDURE, PUBLIC :: clear => cfg_clear + !> Get the names of the user-defined sections in the parser + PROCEDURE, PUBLIC :: section_names => cfg_section_names + !> Get the list of options names + PROCEDURE, PUBLIC :: option_names => cfg_option_names + !> Check if parser has option by name + PROCEDURE, PUBLIC :: has_option => cfg_has_option + !> Check if parser has section by name + PROCEDURE, PUBLIC :: has_section => cfg_has_section + !> Remove an option from the parser. + PROCEDURE, PUBLIC :: remove_option => cfg_remove_option + !> Remove a section (and all the associated options) from the parser. + PROCEDURE, PUBLIC :: remove_section => cfg_remove_section + !> Get value(s) of an option in the parser by name + !! + !! ``` + !! FUNCTION cfg_get_value(this,name,output) RESULT(error) + !! ``` + !! + !! The method attempts to get the value(s) of an option that matches _name_ in _this_ parser. + !! + !! On error, __output__ argument is undefined (that is, left unchanged + !! for scalar versions, **unallocated** for vector version). + !! + !! Errors occur in the following situations: + !! - The option has no value (-6) + !! - The option does not exist (-7) + !! - The option's value cannot be cast in the desired type (-10) + GENERIC, PUBLIC :: get_value => cp_get_rv_sc,cp_get_dv_sc,cp_get_iv_sc, & + cp_get_lv_sc,cp_get_cv_sc,cp_get_sv_sc, & + cp_get_rv_ve,cp_get_dv_ve,cp_get_iv_ve, & + cp_get_lv_ve,cp_get_cv_ve,cp_get_sv_ve + !> Set value(s) of an option in the parser by name + !! + !! ``` + !! FUNCTION cfg_set_value(this,name,input,create) RESULT(error) + !! ``` + !! + !! The method searches for the option matching the given _name_ in _this_ parser and sets new + !! values. + !! + !! If _create_ is set to .true. (default to .false.) the method creates the option if does not + !! exist in _this_ parser. + !! @warning + !! In such case, if the given is not valid, an assertion is raised ! + !! + !! On error (i.e. no option matches the given _name_), no values are set. + GENERIC, PUBLIC :: set_value => cp_set_rv_sc,cp_set_dv_sc,cp_set_iv_sc, & + cp_set_lv_sc,cp_set_cv_sc,cp_set_sv_sc, & + cp_set_rv_ve,cp_set_dv_ve,cp_set_iv_ve, & + cp_set_lv_ve,cp_set_cv_ve,cp_set_sv_ve +#endif + + END TYPE cfgparser + + !> Get value(s) of an option in the parser by name. + !! + !! ``` + !! FUNCTION cfg_get_value(parser,name,output) RESULT(error) + !! ``` + !! + !! The method attempts to get the value(s) of an option that matches _name_ in _this_ parser. + !! + !! On error, __output__ argument is undefined (that is, left unchanged + !! for scalar versions, **unallocated** for vector version). + !! + !! Errors occur in the following situations: + !! - The option has no value (-6) + !! - The option does not exist (-7) + !! - The option's value cannot be cast in the desired type (-10) + INTERFACE cfg_get_value + MODULE PROCEDURE cp_get_rv_sc,cp_get_dv_sc,cp_get_iv_sc, & + cp_get_lv_sc,cp_get_cv_sc,cp_get_sv_sc, & + cp_get_rv_ve,cp_get_dv_ve,cp_get_iv_ve, & + cp_get_lv_ve,cp_get_cv_ve,cp_get_sv_ve + END INTERFACE + + !> Set value(s) of an option in the parser by name + !! + !! ``` + !! FUNCTION set_value(this,name,input,create) RESULT(error) + !! ``` + !! + !! The method searches for the option matching the given _name_ in _this_ parser and sets new + !! values. + !! + !! If _create_ is set to .true. (default to .false.) the method quietly create the option if does not + !! exist in _this_ parser. + !! @warning + !! In such case, if the given is not valid, an assertion is raised ! + !! + !! On error (i.e. no option matches the given _name_), no values are set. + INTERFACE cfg_set_value + MODULE PROCEDURE :: cp_set_rv_sc,cp_set_dv_sc,cp_set_iv_sc, & + cp_set_lv_sc,cp_set_cv_sc,cp_set_sv_sc, & + cp_set_rv_ve,cp_set_dv_ve,cp_set_iv_ve, & + cp_set_lv_ve,cp_set_cv_ve,cp_set_sv_ve + END INTERFACE + + !> Derived type assignment operator + !! + !! This interface defines the assignment operator for the containers defined in the module. + INTERFACE ASSIGNMENT(=) + MODULE PROCEDURE cp_affect_sc, op_affect_sc + END INTERFACE + + CONTAINS + + SUBROUTINE op_affect_sc(this,other) + !! Option object assignment operator subroutine + !! + !! The subroutine assigns __other__ to __this__. + TYPE(option), INTENT(inout) :: this !! An option object to be assigned + TYPE(option), INTENT(in) :: other !! An option object to assign + CALL words_clear(this%values) ! normally not needed + this%name = other%name + this%section = other%section + this%values = other%values + END SUBROUTINE op_affect_sc + + FUNCTION op_valid(opt) RESULT(ok) + !! Check whether or not the option is valid (i.e. has name) + TYPE(option), INTENT(in) :: opt !! An option object + LOGICAL :: ok !! True if the option is valid, false otherwise. + ok = LEN_TRIM(opt%name) > 0 + END FUNCTION op_valid + + SUBROUTINE op_clear(opt) + !! Clear and invalid the given option. + TYPE(option), INTENT(inout) :: opt !! An option object + opt%name = '' + opt%section = '' + CALL words_clear(opt%values) + END SUBROUTINE op_clear + + FUNCTION op_full_name(opt) RESULT(name) + !! Get the full name of an option. + !! + !! @note + !! If no section is defined in the option (that should not happen), "__default__" is used + !! as the section part of the full name. + TYPE(option), INTENT(in) :: opt !! An option object + CHARACTER(len=:), ALLOCATABLE :: name !! The fullname of the option + IF (LEN_TRIM(opt%section) == 0) THEN + name = "__default__/"//TRIM(opt%name) + ELSE + name = TRIM(opt%section)//"/"//TRIM(opt%name) + ENDIF + END FUNCTION op_full_name + + FUNCTION op_split_name(fname,sname,pname) RESULT(err) + !> Split a full name in section and option names + !! + !! The method splits a full name into (section,option) names. Output names (if any) are always + !! set to lower case. + !! + !! A full name simply consists in a section name and an option name separated by a single "/". + !! + !! The method never checks the validity of the output names. Consider using [[cfg_check_name(function)]] + !! to do so. + !! @note + !! If _fname_ does not contains any "/", the method set the special name "\_\_default\_\_" for the output + !! section name. + !! @note + !! On success, option and section names are set to lower case. Otherwise they are set to empty strings. + !! @warning + !! If _fname_ ends with a "/", an error (-6, invalid name) is raised: the method always assumes it can + !! find an option part in the name. + CHARACTER(len=*), INTENT(in) :: fname !! A name to split + CHARACTER(len=:), INTENT(out), ALLOCATABLE :: sname, & !! Section part of the name + pname !! Option part of the name + TYPE(error) :: err !! Error status of the method + INTEGER :: idx + err = noerror ; pname = "" ; sname = "" + ! splits input name in sname, pname + idx = INDEX(fname,'/') + IF (idx == LEN_TRIM(fname)) THEN + err = error("Invalid option name ("//TRIM(fname)//")",-9) + RETURN + ELSE IF (idx <= 1) THEN + sname = "__default__" ; pname = TRIM(fname) + IF (idx == 1) pname=pname(2:) + ELSE + sname = fname(:idx-1) + pname = fname(idx+1:LEN_TRIM(fname)) + ENDIF + ! 17/12/2014: set option name to lower + pname = str_to_lower(pname) + sname = str_to_lower(sname) + END FUNCTION op_split_name + + FUNCTION op_greater_than(left,right) RESULT(ret) + !> greater than operator for option derived type. + !! + !! the comparison is made on section and option name (in alphabetical order). + TYPE(option), INTENT(in) :: left !! LHS option. + TYPE(option), INTENT(in) :: right !! RHS option. + LOGICAL :: ret + !! .true. if LHS is _greater_ than RHS (based on section and option name) + ret = LGT(op_full_name(left),op_full_name(right)) + END FUNCTION op_greater_than + + FUNCTION op_less_than(left,right) RESULT(ret) + !> Less than operator for option derived type. + !! + !! the comparison is made on section and option name (in alphabetical order). + TYPE(option), INTENT(in) :: left !! LHS option. + TYPE(option), INTENT(in) :: right !! RHS option. + LOGICAL :: ret + !! .true. if LHS is _less_ than RHS (based on section and option name) + ret = LLT(op_full_name(left),op_full_name(right)) + END FUNCTION op_less_than + + FUNCTION op_to_str(opt,num_values) RESULT(str) + !! Get the string representation of a option object + !! @note + !! If the object is not valid an empty string is returned. + TYPE(option), INTENT(in) :: opt + !! A option object + INTEGER, INTENT(in), OPTIONAL :: num_values + !! Optional integer with the number of values to print per line + CHARACTER(len=:), ALLOCATABLE :: str + !! An allocated string with the representation of the option object + LOGICAL :: ret + INTEGER :: nv,np,i + CHARACTER(len=:), ALLOCATABLE :: nspcs + CHARACTER(len=st_slen), ALLOCATABLE, DIMENSION(:) :: vec + nv = 8 ; IF (PRESENT(num_values)) nv = MAX(1,num_values) + str = "" + str = TRIM(opt%name)//" = " ; np = LEN(str) + ALLOCATE(CHARACTER(len=np) :: nspcs) ; nspcs(1:) = " " + ! stores the error but do not check... + ret = words_to_vector(opt%values,vec) + IF (.NOT.ALLOCATED(vec)) RETURN + DO i=1,SIZE(vec) + IF (string_is(TRIM(vec(i))) == st_string.AND.TRIM(vec(i))/="NULL") THEN + str = str//'"'//remove_quotes(TRIM(vec(i)))//'",' + ELSE + str = str//TRIM(vec(i))//',' + ENDIF + IF (MOD(i,nv) == 0) THEN + str = str//NEW_LINE('A')//nspcs + ELSE + str = str//CHAR(32) + ENDIF + ENDDO + str = TRIM(str) + IF (str(LEN(str):) == ",") str=str(:LEN(str)-1) + END FUNCTION op_to_str + + !------------------------------- + ! DERIVED TYPE cfgparser METHODS + !------------------------------- + + SUBROUTINE cfg_clear(parser) + !! Clear the cfgparser object ("destructor") + !! + !! This subroutine clears the given parser (deallocates memory). + OBJECT(cfgparser), INTENT(inout) :: parser !! A cfgparser object to clear + INTEGER :: i + IF (ALLOCATED(parser%options)) THEN + DO i = 1, SIZE(parser%options) + CALL op_clear(parser%options(i)) + ENDDO + DEALLOCATE(parser%options) + ENDIF + END SUBROUTINE cfg_clear + + + FUNCTION cfg_check_name(name) RESULT(valid) + !! Check if a name is valid + !! + !! A valid option/section name begins with a letter and is followed by any + !! number of alphanumeric characters and underscore (`[A-Za-z][A-Za-z0-9\_]\*`). + CHARACTER(len=*), INTENT(in) :: name !! A string with the name to check. + LOGICAL :: valid !! .true. if the name is valid, .false. otherwise + INTEGER :: i + CHARACTER(len=26), PARAMETER :: alpha = "abcdefghijklmnopqrstuvwxyz" + CHARACTER(len=12), PARAMETER :: num = "0123456789_" + CHARACTER(len=:), ALLOCATABLE :: pname,sname + TYPE(error) :: err + valid = .false. + i = INDEX(TRIM(name),"/") + IF (i /= 0) THEN + err = op_split_name(name,sname,pname) + IF (err /= 0) THEN + RETURN + ENDIF + ELSE + pname = str_to_lower(TRIM(name)) + sname = "__default__" + ENDIF + ! check option: + i = INDEX(pname,CHAR(32)) + IF (i /= 0.OR.LEN_TRIM(pname) <= 0) RETURN + valid = (VERIFY(pname(1:1),alpha) == 0 .AND.VERIFY(TRIM(pname),alpha//num) == 0) + IF (.NOT.valid) RETURN + ! check section + IF (sname == "__default__") THEN + valid = .true. + RETURN + ELSE + i = INDEX(sname,CHAR(32)) + IF (i /= 0.OR.LEN_TRIM(sname) <= 0) RETURN + valid = (VERIFY(sname(1:1),alpha) == 0 .AND.VERIFY(TRIM(sname),alpha//"/"//num) == 0) + ENDIF + END FUNCTION cfg_check_name + + FUNCTION cfg_count(this) RESULT(num) + !! Get the total number of option in the parser. + !! + !! @internal + !! If no options are defined, then it implies that the internal vector of options is + !! not allocated. + OBJECT(cfgparser), INTENT(in) :: this !! A cfgparser object to search in + INTEGER :: num !! Number of current options registered in the parser. + num = 0 + IF(.NOT.ALLOCATED(this%options)) RETURN + num = SIZE(this%options) + END FUNCTION cfg_count + + FUNCTION cfg_section_names(this) RESULT(list) + !! Get the list of user-defined section names + !! @note + !! If the parser does not have user-defined sections, the vector is still + !! allocated but with 0 elements. + OBJECT(cfgparser), INTENT(in) :: this !! A cfgparser object to process. + CHARACTER(len=st_slen), DIMENSION(:), ALLOCATABLE :: list !! List of section names. + CHARACTER(len=st_slen), DIMENSION(:), ALLOCATABLE :: tmp + INTEGER :: i,j,k,no + LOGICAL :: found + no = cfg_count(this) + IF (no == 0) THEN + ALLOCATE(list(0)) + RETURN + ENDIF + ALLOCATE(tmp(no)) + tmp(1) = '' + ! get the first non-default section + DO i=1,no + IF (this%options(i)%section /= "__default__") THEN + tmp(1) = this%options(i)%section + EXIT + ENDIF + ENDDO + ! no user defined section + IF (LEN_TRIM(tmp(1)) == 0) THEN + DEALLOCATE(tmp) + ALLOCATE(list(0)) + RETURN + ENDIF + k = 1 + DO i=1,no + found = .false. + DO j=1,k + ! Found a match so start looking again + found = (tmp(j) == this%options(i)%section .OR. & + this%options(i)%section == "__default__") + IF (found) EXIT + ENDDO + IF (.NOT.found) THEN + k = k + 1 + tmp(k) = this%options(i)%section + ENDIF + ENDDO + ALLOCATE(list(k)) + list(1:k) = tmp(1:k) + DEALLOCATE(tmp) + END FUNCTION cfg_section_names + + FUNCTION cfg_option_names(this) RESULT(list) + !! Get the list of option names. + !! + !! @note + !! If the parser does not have options, the vector is still allocated but with 0 elements. + OBJECT(cfgparser), INTENT(in) :: this !! A cfgparser object to process. + CHARACTER(len=st_slen), DIMENSION(:), ALLOCATABLE :: list !! List of option names. + INTEGER :: i,no + no = cfg_count(this) + ALLOCATE(list(no)) + IF (no == 0) RETURN + DO i=1,no + IF (this%options(i)%section == "__default__") THEN + list(i) = TRIM(this%options(i)%name) + ELSE + list(i) = TRIM(this%options(i)%section)//"/"//TRIM(this%options(i)%name) + ENDIF + ENDDO + END FUNCTION cfg_option_names + + FUNCTION cfg_has_section(this,name) RESULT(yes) + !! Check if parser has section by name + OBJECT(cfgparser), INTENT(in) :: this !! cfgparser object + CHARACTER(len=*), INTENT(in) :: name !! Name of the section to search + LOGICAL :: yes !! .true. if the section exists, .false. otherwise + CHARACTER(len=:), ALLOCATABLE :: zname + INTEGER :: i,no + yes = .false. + no = cfg_count(this) + IF (no == 0) RETURN + zname = str_to_lower(name) + DO i = 1,no + IF (this%options(i)%section == zname) THEN + yes = .true. + RETURN + ENDIF + ENDDO + END FUNCTION cfg_has_section + + FUNCTION cfg_has_option(this,name) RESULT(yes) + !! Check if parser has option by name + OBJECT(cfgparser), INTENT(in) :: this !! A cfgparser object + CHARACTER(len=*), INTENT(in) :: name !! (extended) Name of the option to search + LOGICAL :: yes !! .true. if the option is found, .false. otherwise + CHARACTER(len=:), ALLOCATABLE :: pname,zname + INTEGER :: i,no + yes = .false. + no = cfg_count(this) + IF (no == 0) RETURN + IF (SCAN(name,"/") <= 0) THEN + zname = "__default__"//"/"//str_to_lower(TRIM(name)) + ELSE + zname = str_to_lower(TRIM(name)) + ENDIF + DO i = 1,no + pname = op_full_name(this%options(i)) + IF (pname == zname) THEN + yes = .true. + RETURN + ENDIF + ENDDO + END FUNCTION cfg_has_option + + SUBROUTINE cfg_sort_options(this) + !! Sort the options in the parser (alphabetiCALLy). + OBJECT(cfgparser), INTENT(inout) :: this !! A cfgparser object + INTEGER :: no + no = cfg_count(this) + IF (no == 0) RETURN + CALL insertionSort(this%options) + END SUBROUTINE cfg_sort_options + + SUBROUTINE cfg_remove_option(this,name) + !! Remove an option from parser by name. + OBJECT(cfgparser), INTENT(inout) :: this !! A cfgparser object to search in + CHARACTER(len=*), INTENT(in) :: name !! The name of the option to remove + CHARACTER(len=:), ALLOCATABLE :: zname,pname + INTEGER :: no,idx,i,j + TYPE(option), DIMENSION(:), ALLOCATABLE :: tmp + IF (SCAN(name,"/") <= 0) THEN + zname = "__default__"//"/"//str_to_lower(TRIM(name)) + ELSE + zname = str_to_lower(TRIM(name)) + ENDIF + idx = cp_get_opt_idx(this,zname) + no = cfg_count(this) + IF (idx == -1) RETURN + ! only one opt + IF (no == 1) THEN + CALL op_clear(this%options(1)) + DEALLOCATE(this%options) + RETURN + ENDIF + ALLOCATE(tmp(no-1)) + j = 1 + DO i=1,no + IF (i /= idx) THEN + tmp(j) = this%options(i) + j= j+1 + ENDIF + CALL op_clear(this%options(i)) + ENDDO + DEALLOCATE(this%options) + ALLOCATE(this%options(no-1)) + DO i=1,no-1 + this%options(i) = tmp(i) + CALL op_clear(tmp(i)) + ENDDO + DEALLOCATE(tmp) + END SUBROUTINE cfg_remove_option + + SUBROUTINE cfg_remove_section(this,name) + !! Remove a section from parser by name. + !! + !! The method removes all the options that belong to the given section name. + OBJECT(cfgparser), INTENT(inout) :: this + !! A cfgparser object to search in + CHARACTER(len=*), INTENT(in) :: name + !! The name of the section to remove + CHARACTER(len=:), ALLOCATABLE :: zname + INTEGER :: no,i,j,icount + INTEGER, DIMENSION(:), ALLOCATABLE :: idxs,itmp + TYPE(option), DIMENSION(:), ALLOCATABLE :: tmp + + no = cfg_count(this) + IF (no == 0) RETURN + zname = str_to_lower(TRIM(name)) + ALLOCATE(itmp(no)) + itmp(:) = -1 + icount = 0 + DO i=1,no + IF (TRIM(this%options(i)%section) == zname) THEN + itmp(icount+1) = i + icount = icount + 1 + ENDIF + ENDDO + IF (icount == 0) RETURN + ALLOCATE(idxs(icount)) + idxs(:) = itmp(1:icount) + !DEALLOCATE(itmp) + ! all options matches (should be rarely the case): remove all + IF (icount == no) THEN + DO i=1,no ; CALL op_clear(this%options(i)); ENDDO + DEALLOCATE(this%options) + RETURN + ENDIF + ALLOCATE(tmp(icount)) + j = 1 + DO i=1,no + IF (ANY(idxs == i)) THEN + tmp(j) = this%options(i) + j = j + 1 + ENDIF + CALL op_clear(this%options(i)) + ENDDO + DEALLOCATE(idxs) + DEALLOCATE(this%options) + ALLOCATE(this%options(icount)) + DO i=1,icount + this%options(i) = tmp(i) + CALL op_clear(tmp(i)) + ENDDO + DEALLOCATE(tmp) + END SUBROUTINE cfg_remove_section + + FUNCTION cfg_read_config(parser,path,override) RESULT(err) + !! Read configuration file + !! + !! @note + !! If the library support C bindings, the method can read included files which are defined + !! by the __#include <...>__ directive (see [p_cfgparse](here) from more details). + OBJECT(cfgparser), INTENT(inout) :: parser + !! A cfgparser object that will store the configuration + CHARACTER(len=*), INTENT(in) :: path + !! Path of the configuration file + LOGICAL, INTENT(in), OPTIONAL :: override + !! An optional boolean flag with .true. to override previous value of duplicated options instead of raising an error. + TYPE(error) :: err + !! An error with the first error encountered + INTEGER :: i + LOGICAL :: zoverride,ok + TYPE(words) :: incfiles + CHARACTER(len=:), ALLOCATABLE :: name + CHARACTER(len=st_slen) :: isec + err = noerror + zoverride = .false. ; IF (PRESENT(override)) zoverride = override + isec = "__default__" + name = TRIM(path) + i = INDEX(name,'/',.true.) ; IF (i /= 0) name = name(i+1:) + IF (i == 0) THEN + name = fs_realpath("./"//path) + ELSE + name = fs_realpath(path) + ENDIF + CALL words_append(incfiles,name) + INQUIRE(FILE=TRIM(path), EXIST=ok) + IF (.NOT.ok) THEN + err = error(TRIM(path)//": no such file",-11) + ELSE + err = read_include(parser,TRIM(path),isec,incfiles,zoverride) + ENDIF + call words_clear(incfiles) + END FUNCTION cfg_read_config + + FUNCTION cfg_write_config(this,lu,num_values) RESULT(err) + !> Write the content of the parser in the logical unit. + !! + !! the method expects the logical unit to be opened and does not close it + !! at the end of the process. + OBJECT(cfgparser), INTENT(inout) :: this + !! Parser to write. + INTEGER, INTENT(in) :: lu + !! Logical unit. It should be already opened or an error is raised. + INTEGER, INTENT(in), OPTIONAL :: num_values + !! Optional integer with the number of values to print per line for options (default to 8). + TYPE(error) :: err + !! Error status + CHARACTER(len=st_slen) :: sname + LOGICAL :: ok + INTEGER :: nv,no,i + err = noerror + INQUIRE(UNIT=lu,OPENED=ok) + IF (.NOT.ok) THEN + err = error("Logical unit not opened",-15) + RETURN + ENDIF + no = cfg_count(this) + IF (no == 0) THEN + err = error("No options to write",-7) + RETURN + ENDIF + ! sort options. + CALL cfg_sort_options(this) + nv = 8 ; IF (PRESENT(num_values)) nv = MAX(1,num_values) + sname = this%options(1)%section + IF (sname /= "__default__") & + WRITE(lu,'(a)') "[ "//TRIM(sname)//" ]" + DO i=1,no + IF (this%options(i)%section /= sname) THEN + sname = this%options(i)%section + ! write section first + WRITE(lu,*) + WRITE(lu,'(a)') "[ "//TRIM(sname)//" ]" + ENDIF + WRITE(lu,'(a)') op_to_str(this%options(i),nv) + ENDDO + END FUNCTION cfg_write_config + + ! internal (private methods) + + SUBROUTINE cp_affect_sc(this,other) + !! cfgparser object assignment operator subroutine + !! + !! The subroutine assigns __other__ to __this__. + TYPE(cfgparser), INTENT(inout) :: this !! A cfgparser object to be assigned + TYPE(cfgparser), INTENT(in) :: other !! A cfgparser object to assign + INTEGER :: i,ono + CALL cfg_clear(this) + ono = cfg_count(other) + IF (ono == 0) RETURN + ALLOCATE(this%options(ono)) + DO i=1,ono + this%options(i) = other%options(i) + ENDDO + RETURN + END SUBROUTINE cp_affect_sc + + FUNCTION cp_get_opt_idx(this,name) RESULT(idx) + !! Get the index of an option by name in the parser. + !! + !! The method searches in the parser for the option with the given (full) __name__. + !! If found, it returns the index of the option in the internal vector of options. Otherwise + !! -1 is returned. + OBJECT(cfgparser), INTENT(in) :: this !! A cfgparser object + CHARACTER(len=*), INTENT(in) :: name !! A string with the name of the option + INTEGER :: idx !! Index of the option (-1 if not found). + CHARACTER(len=:), ALLOCATABLE :: zname,pname + INTEGER :: no,i + idx = -1 + no = cfg_count(this) + IF (no == 0) RETURN + IF (SCAN(name,"/") <= 0) THEN + zname = "__default__"//"/"//str_to_lower(TRIM(name)) + ELSE + zname = str_to_lower(TRIM(name)) + ENDIF + DO i=1,no + pname = op_full_name(this%options(i)) + IF (pname == zname) THEN + idx = i + RETURN + ENDIF + ENDDO + END FUNCTION cp_get_opt_idx + + FUNCTION cp_update_opt(this,sname,pname,values) RESULT(err) + !! Update an option in the parser. + !! + !! The attempts to update the option in the parser that matches __opt__ name. + !! + !! If __name__ is given it is used instead of __opt__ name. + !! + !! If no option is found, __opt__ is appended in the parser. Otherwise the matched + !! option is updated (i.e. its values are set to __opt__ values). + !! + !! If the option is not valid, the method does nothing and -X error status is returned. + !! + !! @internal + !! The method performs the same kind of operations than the setters except that it + !! expects raw data ([[strings(module):words(type)]]). + OBJECT(cfgparser), INTENT(inout) :: this !! cfgparser object to process. + CHARACTER(len=*), INTENT(in) :: sname !! Name of the section. + CHARACTER(len=*), INTENT(in) :: pname !! Name of the option. + TYPE(words), INTENT(in) :: values !! Raw values. + TYPE(error) :: err !! Error status. + CHARACTER(len=:), ALLOCATABLE :: zsname,fname + INTEGER :: i + err = noerror + zsname = str_to_lower(TRIM(sname)) + IF (LEN_TRIM(zsname) == 0 ) zsname = "__default__" + fname = zsname//"/"//str_to_lower(TRIM(pname)) + !print*,"DEBUG6: ",fname + IF (.NOT.cfg_check_name(fname)) THEN + err = error("Invalid option (no name)",-9) + RETURN + ENDIF + i = cp_get_opt_idx(this,fname) + IF (i /= -1) THEN + CALL words_clear(this%options(i)%values) + this%options(i)%values = values + ELSE + err = cp_add_opt(this,zsname,pname,values) + ENDIF + END FUNCTION cp_update_opt + + + FUNCTION cp_add_opt(this,sname,pname,values) RESULT(err) + !! Add an option to the parser. + !! + !! In order to add an option to the default section, _sname_ should be left empty or set to "\_\_default\_\_". + !! + !! If given, _opt_ points to the new option on output. If an error occured the pointer is null. + !! + !! The following error code can be returned: + !! - 0, no error. + !! - -8, the option already exists. + !! - -9, option name is not valid. + OBJECT(cfgparser), INTENT(inout) :: this + !! A cfgparser object to process. + CHARACTER(len=*), INTENT(in) :: sname + !! Section name. + CHARACTER(len=*), INTENT(in) :: pname + !! Option name. + TYPE(words), INTENT(in) :: values + !! Values to set. + TYPE(error) :: err + !! Return error status. + CHARACTER(len=:), ALLOCATABLE :: zsname,fname + TYPE(option), DIMENSION(:), ALLOCATABLE :: tmp + INTEGER :: no,i + + TYPE(option) :: sca + + err = noerror + zsname = sname + no = cfg_count(this) + IF (LEN_TRIM(zsname) == 0) zsname = "__default__" + fname = TRIM(zsname)//"/"//TRIM(pname) + ! check name + IF (.NOT.cfg_check_name(fname)) THEN + err = error("Invalid option name '"//fname//"'",-9) + RETURN + ENDIF + ! check if opt exists in the parser + IF (no > 0) THEN + IF (cp_get_opt_idx(this,fname) /= -1) THEN + err = error("Duplicate option '"//TRIM(pname)//"' in "//TRIM(zsname),-8) + RETURN + ENDIF + ENDIF + + ! build option + CALL op_clear(sca) + sca%name = pname + sca%section = zsname + sca%values = values + + IF (no == 0) THEN + ! no options yet -> allocate + ALLOCATE(this%options(1)) + !this%options(1) = sca + !this%options(1)%name = pname + !this%options(1)%section = zsname + !this%options(1)%values = values + ELSE + ! parser has options: increase this%options size (ugly copy). + ALLOCATE(tmp(no)) + DO i =1,no + tmp(i) = this%options(i) + CALL op_clear(this%options(i)) + ENDDO + DEALLOCATE(this%options) + ALLOCATE(this%options(no+1)) + DO i =1,no + this%options(i) = tmp(i) + CALL op_clear(tmp(i)) + ENDDO + DEALLOCATE(tmp) + !this%options(no+1) = sca + !this%options(no+1)%name = pname + !this%options(no+1)%section = zsname + !this%options(no+1)%values = values + ENDIF + ! always add the option at the end. + !print*, words_length(this%options(no+1)%values) + this%options(no+1) = sca + CALL op_clear(sca) + END FUNCTION cp_add_opt + + FUNCTION cp_get_rv_sc(this,name,output) RESULT(err) + !! Get the first value of an option in the parser by name (real/scalar) + !! + !! The following error status can be returned by the method: + !! - -7, no option matches the given name. + !! - -6, the option does not have value(s). + !! - -10, the value cannot be converted in the output type. + OBJECT(cfgparser), INTENT(in) :: this !! Cfgparser object + CHARACTER(len=*), INTENT(in) :: name !! (Full) Name of the option to get + REAL(kind=4), INTENT(out) :: output !! Output value + TYPE(error) :: err + !! Error status + INTEGER :: idx + CHARACTER(len=:), ALLOCATABLE :: tmp + err = noerror + idx = cp_get_opt_idx(this,name) + IF (idx == -1) THEN + err = error("Option "//TRIM(name)//" does not exist",-7) + RETURN + ENDIF + IF (words_length(this%options(idx)%values)== 0) THEN + err = error("Option "//TRIM(name)//" has no value",-6) + ELSE + tmp = TRIM(ADJUSTL(words_get(this%options(idx)%values,1))) + IF (LEN(tmp) == 0) THEN + err = error("Option "//TRIM(name)//" has no value",-6) + ELSE + IF(.NOT.from_string(tmp,output)) & + err = error(TRIM(name)//": Cannot convert "//tmp//" to real.",-10) + ENDIF + ENDIF + END FUNCTION cp_get_rv_sc + + FUNCTION cp_get_dv_sc(this,name,output) RESULT(err) + !! Get the first value of an option in the parser by name (double/scalar) + !! + !! The following error status can be returned by the method: + !! - -7, no option matches the given name. + !! - -6, the option does not have value(s). + !! - -10, the value cannot be converted in the output type. + OBJECT(cfgparser), INTENT(in) :: this !! Cfgparser object + CHARACTER(len=*), INTENT(in) :: name !! (Full) Name of the option to get + REAL(kind=8), INTENT(out) :: output !! Output value + TYPE(error) :: err + !! Error status + INTEGER :: idx + CHARACTER(len=:), ALLOCATABLE :: tmp + err = noerror + idx = cp_get_opt_idx(this,name) + IF (idx == -1) THEN + err = error("Option "//TRIM(name)//" does not exist",-7) + RETURN + ENDIF + IF (words_length(this%options(idx)%values)== 0) THEN + err = error("Option "//TRIM(name)//" has no value",-6) + ELSE + tmp = TRIM(ADJUSTL(words_get(this%options(idx)%values,1))) + IF (LEN(tmp) == 0) THEN + err = error("Option "//TRIM(name)//" has no value",-6) + ELSE + IF(.NOT.from_string(tmp,output)) & + err = error(TRIM(name)//": Cannot convert "//tmp//" to double.",-10) + ENDIF + ENDIF + END FUNCTION cp_get_dv_sc + + FUNCTION cp_get_iv_sc(this,name,output) RESULT(err) + !! Get the first value of an option in the parser by name (integer/scalar) + !! + !! The following error status can be returned by the method: + !! - -7, no option matches the given name. + !! - -6, the option does not have value(s). + !! - -10, the value cannot be converted in the output type. + OBJECT(cfgparser), INTENT(in) :: this !! Cfgparser object + CHARACTER(len=*), INTENT(in) :: name !! (Full) Name of the option to get + INTEGER, INTENT(out) :: output !! Output value + TYPE(error) :: err + !! Error status + INTEGER :: idx + CHARACTER(len=:), ALLOCATABLE :: tmp + err = noerror + idx = cp_get_opt_idx(this,name) + IF (idx == -1) THEN + err = error("Option "//TRIM(name)//" does not exist",-7) + RETURN + ENDIF + IF (words_length(this%options(idx)%values)== 0) THEN + err = error("Option "//TRIM(name)//" has no value",-6) + ELSE + tmp = TRIM(ADJUSTL(words_get(this%options(idx)%values,1))) + IF (LEN(tmp) == 0) THEN + err = error("Option "//TRIM(name)//" has no value",-6) + ELSE + IF(.NOT.from_string(tmp,output)) & + err = error(TRIM(name)//": Cannot convert "//tmp//" to integer.",-10) + ENDIF + ENDIF + END FUNCTION cp_get_iv_sc + + FUNCTION cp_get_lv_sc(this,name,output) RESULT(err) + !! Get the first value of an option in the parser by name (logical/scalar) + !! + !! The following error status can be returned by the method: + !! - -7, no option matches the given name. + !! - -6, the option does not have value(s). + !! - -10, the value cannot be converted in the output type. + OBJECT(cfgparser), INTENT(in) :: this !! Cfgparser object + CHARACTER(len=*), INTENT(in) :: name !! (Full) Name of the option to get + LOGICAL, INTENT(out) :: output !! Output value + TYPE(error) :: err + !! Error status + INTEGER :: idx + CHARACTER(len=:), ALLOCATABLE :: tmp + err = noerror + idx = cp_get_opt_idx(this,name) + IF (idx == -1) THEN + err = error("Option "//TRIM(name)//" does not exist",-7) + RETURN + ENDIF + IF (words_length(this%options(idx)%values)== 0) THEN + err = error("Option "//TRIM(name)//" has no value",-6) + ELSE + tmp = TRIM(ADJUSTL(words_get(this%options(idx)%values,1))) + IF (LEN(tmp) == 0) THEN + err = error("Option "//TRIM(name)//" has no value",-6) + ELSE + IF(.NOT.from_string(tmp,output)) & + err = error(TRIM(name)//": Cannot convert "//tmp//" to logical.",-10) + ENDIF + ENDIF + END FUNCTION cp_get_lv_sc + + FUNCTION cp_get_cv_sc(this,name,output) RESULT(err) + !! Get the first value of an option in the parser by name (complex/scalar) + !! + !! The following error status can be returned by the method: + !! - -7, no option matches the given name. + !! - -6, the option does not have value(s). + !! - -10, the value cannot be converted in the output type. + OBJECT(cfgparser), INTENT(in) :: this !! Cfgparser object + CHARACTER(len=*), INTENT(in) :: name !! (Full) Name of the option to get + COMPLEX, INTENT(out) :: output !! Output value + TYPE(error) :: err + !! Error status + INTEGER :: idx + CHARACTER(len=:), ALLOCATABLE :: tmp + err = noerror + idx = cp_get_opt_idx(this,name) + IF (idx == -1) THEN + err = error("Option "//TRIM(name)//" does not exist",-7) + RETURN + ENDIF + IF (words_length(this%options(idx)%values)== 0) THEN + err = error("Option "//TRIM(name)//" has no value",-6) + ELSE + tmp = TRIM(ADJUSTL(words_get(this%options(idx)%values,1))) + IF (LEN(tmp) == 0) THEN + err = error("Option "//TRIM(name)//" has no value",-6) + ELSE + IF(.NOT.from_string(tmp,output)) & + err = error(TRIM(name)//": Cannot convert "//tmp//" to complex.",-10) + ENDIF + ENDIF + END FUNCTION cp_get_cv_sc + + FUNCTION cp_get_sv_sc(this,name,output) RESULT(err) + !! Get the first value of an option in the parser by name (string/scalar) + !! + !! The following error status can be returned by the method: + !! - -7, no option matches the given name. + !! - -6, the option does not have value(s). + OBJECT(cfgparser), INTENT(in) :: this !! Cfgparser object + CHARACTER(len=*), INTENT(in) :: name !! (Full) Name of the option to get + CHARACTER(len=*), INTENT(out) :: output !! Output value + TYPE(error) :: err + !! Error status + INTEGER :: idx + !CHARACTER(len=:), ALLOCATABLE :: tmp + err = noerror + idx = cp_get_opt_idx(this,name) + IF (idx == -1) THEN + err = error("Option "//TRIM(name)//" does not exist",-7) + RETURN + ENDIF + IF (words_length(this%options(idx)%values)== 0) THEN + err = error("Option "//TRIM(name)//" has no value",-6) + ELSE + output = TRIM(ADJUSTL(words_get(this%options(idx)%values,1))) + err = noerror + ENDIF + END FUNCTION cp_get_sv_sc + + FUNCTION cp_get_rv_ve(this,name,output) RESULT(err) + !! Get the value(s) of an option in the parser by name (real/vector) + !! + !! On error, the output vector is not allocated. + OBJECT(cfgparser), INTENT(in) :: this !! Cfgparser object + CHARACTER(len=*), INTENT(in) :: name !! (Full) Name of the option to get + REAL(kind=4), INTENT(out), DIMENSION(:), ALLOCATABLE :: output !! Output values + TYPE(error) :: err + !! Error status of the method (see [[cfgparser(type):get_value(bound)]] documentation) + CHARACTER(len=st_slen), DIMENSION(:), ALLOCATABLE :: tmp + LOGICAL :: ok + INTEGER :: i,idx + CHARACTER(len=15) :: i2s + err = noerror + idx = cp_get_opt_idx(this,name) + IF (idx == -1) THEN + err = error("Option "//TRIM(name)//" does not exist",-7) + RETURN + ENDIF + IF (words_length(this%options(idx)%values) == 0) THEN + err = error("Option "//TRIM(name)//" has no value",-6) + ELSE + ALLOCATE(output(words_length(this%options(idx)%values))) + ok = words_to_vector(this%options(idx)%values,tmp) + DO i=1, SIZE(tmp) + WRITE(i2s,'(I15)') i ; i2s=ADJUSTL(i2s) + IF (LEN_TRIM(ADJUSTL(tmp(i))) == 0) THEN + err = error("Cannot get value #"//TRIM(i2s)//" from option "//TRIM(name),-6) + DEALLOCATE(output) ; EXIT + ELSE IF (.NOT.from_string(tmp(i), output(i))) THEN + err = error("Cannot convert value #"//TRIM(i2s)//" from option "//TRIM(name),-10) + DEALLOCATE(output) ; EXIT + ENDIF + ENDDO + ENDIF + DEALLOCATE(tmp) + RETURN + END FUNCTION cp_get_rv_ve + + FUNCTION cp_get_dv_ve(this,name,output) RESULT(err) + !! Get the value(s) of an option in the parser by name (double/vector) + !! + !! On error, the output vector is not allocated. + OBJECT(cfgparser), INTENT(in) :: this !! Cfgparser object + CHARACTER(len=*), INTENT(in) :: name !! (Full) Name of the option to get + REAL(kind=8), INTENT(out), DIMENSION(:), ALLOCATABLE :: output !! Output values + TYPE(error) :: err + !! Error status of the method (see [[cfgparser(type):get_value(bound)]] documentation) + CHARACTER(len=st_slen), DIMENSION(:), ALLOCATABLE :: tmp + LOGICAL :: ok + INTEGER :: i,idx + CHARACTER(len=15) :: i2s + err = noerror + idx = cp_get_opt_idx(this,name) + IF (idx == -1) THEN + err = error("Option "//TRIM(name)//" does not exist",-7) + RETURN + ENDIF + IF (words_length(this%options(idx)%values) == 0) THEN + err = error("Option "//TRIM(name)//" has no value",-6) + ELSE + ALLOCATE(output(words_length(this%options(idx)%values))) + ok = words_to_vector(this%options(idx)%values,tmp) + DO i=1, SIZE(tmp) + WRITE(i2s,'(I15)') i ; i2s=ADJUSTL(i2s) + IF (LEN_TRIM(ADJUSTL(tmp(i))) == 0) THEN + err = error("Cannot get value #"//TRIM(i2s)//" from option "//TRIM(name),-6) + DEALLOCATE(output) ; EXIT + ELSE IF (.NOT.from_string(tmp(i), output(i))) THEN + err = error("Cannot convert value #"//TRIM(i2s)//" from option "//TRIM(name),-10) + DEALLOCATE(output) ; EXIT + ENDIF + ENDDO + ENDIF + DEALLOCATE(tmp) + RETURN + END FUNCTION cp_get_dv_ve + + FUNCTION cp_get_iv_ve(this,name,output) RESULT(err) + !! Get the value(s) of an option in the parser by name (integer/vector) + !! + !! On error, the output vector is not allocated. + OBJECT(cfgparser), INTENT(in) :: this !! Cfgparser object + CHARACTER(len=*), INTENT(in) :: name !! (Full) Name of the option to get + INTEGER, INTENT(out), DIMENSION(:), ALLOCATABLE :: output !! Output values + TYPE(error) :: err + !! Error status of the method (see [[cfgparser(type):get_value(bound)]] documentation) + CHARACTER(len=st_slen), DIMENSION(:), ALLOCATABLE :: tmp + LOGICAL :: ok + INTEGER :: i,idx + CHARACTER(len=15) :: i2s + err = noerror + idx = cp_get_opt_idx(this,name) + IF (idx == -1) THEN + err = error("Option "//TRIM(name)//" does not exist",-7) + RETURN + ENDIF + IF (words_length(this%options(idx)%values) == 0) THEN + err = error("Option "//TRIM(name)//" has no value",-6) + ELSE + ALLOCATE(output(words_length(this%options(idx)%values))) + ok = words_to_vector(this%options(idx)%values,tmp) + DO i=1, SIZE(tmp) + WRITE(i2s,'(I15)') i ; i2s=ADJUSTL(i2s) + IF (LEN_TRIM(ADJUSTL(tmp(i))) == 0) THEN + err = error("Cannot get value #"//TRIM(i2s)//" from option "//TRIM(name),-6) + DEALLOCATE(output) ; EXIT + ELSE IF (.NOT.from_string(tmp(i), output(i))) THEN + err = error("Cannot convert value #"//TRIM(i2s)//" from option "//TRIM(name),-10) + DEALLOCATE(output) ; EXIT + ENDIF + ENDDO + ENDIF + DEALLOCATE(tmp) + RETURN + END FUNCTION cp_get_iv_ve + + FUNCTION cp_get_lv_ve(this,name,output) RESULT(err) + !! Get the value(s) of an option in the parser by name (logical/vector) + !! + !! On error, the output vector is not allocated. + OBJECT(cfgparser), INTENT(in) :: this !! Cfgparser object + CHARACTER(len=*), INTENT(in) :: name !! (Full) Name of the option to get + LOGICAL, INTENT(out), DIMENSION(:), ALLOCATABLE :: output !! Output values + TYPE(error) :: err + !! Error status of the method (see [[cfgparser(type):get_value(bound)]] documentation) + CHARACTER(len=st_slen), DIMENSION(:), ALLOCATABLE :: tmp + LOGICAL :: ok + INTEGER :: i,idx + CHARACTER(len=15) :: i2s + err = noerror + idx = cp_get_opt_idx(this,name) + IF (idx == -1) THEN + err = error("Option "//TRIM(name)//" does not exist",-7) + RETURN + ENDIF + IF (words_length(this%options(idx)%values) == 0) THEN + err = error("Option "//TRIM(name)//" has no value",-6) + ELSE + ALLOCATE(output(words_length(this%options(idx)%values))) + ok = words_to_vector(this%options(idx)%values,tmp) + DO i=1, SIZE(tmp) + WRITE(i2s,'(I15)') i ; i2s=ADJUSTL(i2s) + IF (LEN_TRIM(ADJUSTL(tmp(i))) == 0) THEN + err = error("Cannot get value #"//TRIM(i2s)//" from option "//TRIM(name),-6) + DEALLOCATE(output) ; EXIT + ELSE IF (.NOT.from_string(tmp(i), output(i))) THEN + err = error("Cannot convert value #"//TRIM(i2s)//" from option "//TRIM(name),-10) + DEALLOCATE(output) ; EXIT + ENDIF + ENDDO + ENDIF + DEALLOCATE(tmp) + RETURN + END FUNCTION cp_get_lv_ve + + FUNCTION cp_get_cv_ve(this,name,output) RESULT(err) + !! Get the value(s) of an option in the parser by name (complex/vector) + !! + !! On error, the output vector is not allocated. + OBJECT(cfgparser), INTENT(in) :: this !! Cfgparser object + CHARACTER(len=*), INTENT(in) :: name !! (Full) Name of the option to get + COMPLEX, INTENT(out), DIMENSION(:), ALLOCATABLE :: output !! Output values + TYPE(error) :: err + !! Error status of the method (see [[cfgparser(type):get_value(bound)]] documentation) + CHARACTER(len=st_slen), DIMENSION(:), ALLOCATABLE :: tmp + LOGICAL :: ok + INTEGER :: i,idx + CHARACTER(len=15) :: i2s + err = noerror + idx = cp_get_opt_idx(this,name) + IF (idx == -1) THEN + err = error("Option "//TRIM(name)//" does not exist",-7) + RETURN + ENDIF + IF (words_length(this%options(idx)%values) == 0) THEN + err = error("Option "//TRIM(name)//" has no value",-6) + ELSE + ALLOCATE(output(words_length(this%options(idx)%values))) + ok = words_to_vector(this%options(idx)%values,tmp) + DO i=1, SIZE(tmp) + WRITE(i2s,'(I15)') i ; i2s=ADJUSTL(i2s) + IF (LEN_TRIM(ADJUSTL(tmp(i))) == 0) THEN + err = error("Cannot get value #"//TRIM(i2s)//" from option "//TRIM(name),-6) + DEALLOCATE(output) ; EXIT + ELSE IF (.NOT.from_string(tmp(i), output(i))) THEN + err = error("Cannot convert value #"//TRIM(i2s)//" from option "//TRIM(name),-10) + DEALLOCATE(output) ; EXIT + ENDIF + ENDDO + ENDIF + DEALLOCATE(tmp) + RETURN + END FUNCTION cp_get_cv_ve + + FUNCTION cp_get_sv_ve(this,name,output) RESULT(err) + !! Get the value(s) of an option in the parser by name (string/vector) + !! + !! On error, the output vector is not allocated. + OBJECT(cfgparser), INTENT(in) :: this !! Cfgparser object + CHARACTER(len=*), INTENT(in) :: name !! (Full) Name of the option to get + CHARACTER(len=*), INTENT(out), DIMENSION(:), ALLOCATABLE :: output !! Output values + TYPE(error) :: err + !! Error status of the method (see [[cfgparser(type):get_value(bound)]] documentation) + LOGICAL :: ok + INTEGER :: idx + err = noerror + idx = cp_get_opt_idx(this,name) + IF (idx == -1) THEN + err = error("Option "//TRIM(name)//" does not exist",-7) + RETURN + ENDIF + IF (words_length(this%options(idx)%values) == 0) THEN + err = error("Option "//TRIM(name)//" has no value",-6) + ELSE + ok = words_to_vector(this%options(idx)%values,output) + ENDIF + RETURN + END FUNCTION cp_get_sv_ve + + FUNCTION cp_set_rv_sc(this,name,input,create) RESULT(err) + !! Set new value for the given option by name (real/scalar) + !! + !! If _create_ is given to .true., the method will add a new option if it does not exist in + !! the parser. + !! In such case, an error (-6, invalid name) is raised if the option name is not valid. + !! + !! In other case, if the option is not defined in the parser the error status is set to -7. + OBJECT(cfgparser), INTENT(inout) :: this !! Cfgparser object + CHARACTER(len=*), INTENT(in) :: name !! (Full) Name of the option to set + REAL(kind=4), INTENT(in) :: input !! Input value + LOGICAL, INTENT(in), OPTIONAL :: create !! .true. to create option if it does not exist (default to false). + TYPE(error) :: err !! Error status + LOGICAL :: zcreate + INTEGER :: idx + CHARACTER(len=:), ALLOCATABLE :: sname,pname + TYPE(words) :: values + zcreate = .false. ; IF (PRESENT(create)) zcreate = create + err = noerror + idx = cp_get_opt_idx(this,name) + CALL words_append(values,to_string(input)) + IF (idx == -1) THEN + IF (zcreate) THEN + err = op_split_name(name,sname,pname) + IF (err == 0) err = cp_add_opt(this,sname,pname,values) + ELSE + err = error("Option "//TRIM(name)//" does not exist",-7) + ENDIF + ELSE + this%options(idx)%values = values + ENDIF + CALL words_clear(values) + END FUNCTION cp_set_rv_sc + + FUNCTION cp_set_dv_sc(this,name,input,create) RESULT(err) + !! Set new value for the given option by name (double/scalar) + !! + !! If _create_ is given to .true., the method will add a new option if it does not exist in + !! the parser. + !! In such case, an error (-6, invalid name) is raised if the option name is not valid. + !! + !! In other case, if the option is not defined in the parser the error status is set to -7. + OBJECT(cfgparser), INTENT(inout) :: this !! Cfgparser object + CHARACTER(len=*), INTENT(in) :: name !! (Full) Name of the option to set + REAL(kind=8), INTENT(in) :: input !! Input value + LOGICAL, INTENT(in), OPTIONAL :: create !! .true. to create option if it does not exist (default to false). + TYPE(error) :: err !! Error status + LOGICAL :: zcreate + INTEGER :: idx + CHARACTER(len=:), ALLOCATABLE :: sname,pname + TYPE(words) :: values + zcreate = .false. ; IF (PRESENT(create)) zcreate = create + err = noerror + idx = cp_get_opt_idx(this,name) + CALL words_append(values,to_string(input)) + IF (idx == -1) THEN + IF (zcreate) THEN + err = op_split_name(name,sname,pname) + IF (err == 0) err = cp_add_opt(this,sname,pname,values) + ELSE + err = error("Option "//TRIM(name)//" does not exist",-7) + ENDIF + ELSE + this%options(idx)%values = values + ENDIF + CALL words_clear(values) + END FUNCTION cp_set_dv_sc + + FUNCTION cp_set_iv_sc(this,name,input,create) RESULT(err) + !! Set new value for the given option by name (double/scalar) + !! + !! If _create_ is given to .true., the method will add a new option if it does not exist in + !! the parser. + !! In such case, an error (-6, invalid name) is raised if the option name is not valid. + !! + !! In other case, if the option is not defined in the parser the error status is set to -7. + OBJECT(cfgparser), INTENT(inout) :: this !! Cfgparser object + CHARACTER(len=*), INTENT(in) :: name !! (Full) Name of the option to set + INTEGER, INTENT(in) :: input !! Input value + LOGICAL, INTENT(in), OPTIONAL :: create !! .true. to create option if it does not exist (default to false). + TYPE(error) :: err !! Error status + LOGICAL :: zcreate + INTEGER :: idx + CHARACTER(len=:), ALLOCATABLE :: sname,pname + TYPE(words) :: values + zcreate = .false. ; IF (PRESENT(create)) zcreate = create + err = noerror + idx = cp_get_opt_idx(this,name) + CALL words_append(values,to_string(input)) + IF (idx == -1) THEN + IF (zcreate) THEN + err = op_split_name(name,sname,pname) + !IF (err == 0) err = cp_add_opt(this,sname,pname,values) + err = cp_add_opt(this,sname,pname,values) + ELSE + err = error("Option "//TRIM(name)//" does not exist",-7) + ENDIF + ELSE + this%options(idx)%values = values + ENDIF + CALL words_clear(values) + END FUNCTION cp_set_iv_sc + + FUNCTION cp_set_lv_sc(this,name,input,create) RESULT(err) + !! Set new value for the given option by name (logical/scalar) + !! + !! If _create_ is given to .true., the method will add a new option if it does not exist in + !! the parser. + !! In such case, an error (-6, invalid name) is raised if the option name is not valid. + !! + !! In other case, if the option is not defined in the parser the error status is set to -7. + OBJECT(cfgparser), INTENT(inout) :: this !! Cfgparser object + CHARACTER(len=*), INTENT(in) :: name !! (Full) Name of the option to set + LOGICAL, INTENT(in) :: input !! Input value + LOGICAL, INTENT(in), OPTIONAL :: create !! .true. to create option if it does not exist (default to false). + TYPE(error) :: err !! Error status + LOGICAL :: zcreate + INTEGER :: idx + CHARACTER(len=:), ALLOCATABLE :: sname,pname + TYPE(words) :: values + zcreate = .false. ; IF (PRESENT(create)) zcreate = create + err = noerror + idx = cp_get_opt_idx(this,name) + CALL words_append(values,to_string(input)) + IF (idx == -1) THEN + IF (zcreate) THEN + err = op_split_name(name,sname,pname) + IF (err == 0) err = cp_add_opt(this,sname,pname,values) + ELSE + err = error("Option "//TRIM(name)//" does not exist",-7) + ENDIF + ELSE + this%options(idx)%values = values + ENDIF + CALL words_clear(values) + END FUNCTION cp_set_lv_sc + + FUNCTION cp_set_cv_sc(this,name,input,create) RESULT(err) + !! Set new value for the given option by name (complex/scalar) + !! + !! If _create_ is given to .true., the method will add a new option if it does not exist in + !! the parser. + !! In such case, an error (-6, invalid name) is raised if the option name is not valid. + !! + !! In other case, if the option is not defined in the parser the error status is set to -7. + OBJECT(cfgparser), INTENT(inout) :: this !! Cfgparser object + CHARACTER(len=*), INTENT(in) :: name !! (Full) Name of the option to set + COMPLEX, INTENT(in) :: input !! Input value + LOGICAL, INTENT(in), OPTIONAL :: create !! .true. to create option if it does not exist (default to false). + TYPE(error) :: err !! Error status + LOGICAL :: zcreate + INTEGER :: idx + CHARACTER(len=:), ALLOCATABLE :: sname,pname + TYPE(words) :: values + zcreate = .false. ; IF (PRESENT(create)) zcreate = create + err = noerror + idx = cp_get_opt_idx(this,name) + CALL words_append(values,to_string(input)) + IF (idx == -1) THEN + IF (zcreate) THEN + err = op_split_name(name,sname,pname) + IF (err == 0) err = cp_add_opt(this,sname,pname,values) + ELSE + err = error("Option "//TRIM(name)//" does not exist",-7) + ENDIF + ELSE + this%options(idx)%values = values + ENDIF + CALL words_clear(values) + END FUNCTION cp_set_cv_sc + + FUNCTION cp_set_sv_sc(this,name,input,create) RESULT(err) + !! Set new value for the given option by name (string/scalar) + !! + !! If _create_ is given to .true., the method will add a new option if it does not exist in + !! the parser. + !! In such case, an error (-6, invalid name) is raised if the option name is not valid. + !! + !! In other case, if the option is not defined in the parser the error status is set to -7. + OBJECT(cfgparser), INTENT(inout) :: this !! Cfgparser object + CHARACTER(len=*), INTENT(in) :: name !! (Full) Name of the option to set + CHARACTER(len=*), INTENT(in) :: input !! Input value + LOGICAL, INTENT(in), OPTIONAL :: create !! .true. to create option if it does not exist (default to false). + TYPE(error) :: err !! Error status + LOGICAL :: zcreate + INTEGER :: idx + CHARACTER(len=:), ALLOCATABLE :: sname,pname + TYPE(words) :: values + zcreate = .false. ; IF (PRESENT(create)) zcreate = create + err = noerror + idx = cp_get_opt_idx(this,name) + CALL words_append(values,input) + IF (idx == -1) THEN + IF (zcreate) THEN + err = op_split_name(name,sname,pname) + IF (err == 0) err = cp_add_opt(this,sname,pname,values) + ELSE + err = error("Option "//TRIM(name)//" does not exist",-7) + ENDIF + ELSE + this%options(idx)%values = values + ENDIF + CALL words_clear(values) + END FUNCTION cp_set_sv_sc + + FUNCTION cp_set_rv_ve(this,name,input,create) RESULT(err) + !! Set new value for the given option by name (real/vector) + !! + !! If _create_ is given to .true., the method will add a new option if it does not exist in + !! the parser. + !! In such case, an error (-6, invalid name) is raised if the option name is not valid. + !! + !! In other case, if the option is not defined in the parser the error status is set to -7. + OBJECT(cfgparser), INTENT(inout) :: this !! Cfgparser object + CHARACTER(len=*), INTENT(in) :: name !! (Full) Name of the option to get + REAL(kind=4), INTENT(in), DIMENSION(:) :: input !! Input values + LOGICAL, INTENT(in), OPTIONAL :: create !! .true. to create option if it does not exist (default to false) + TYPE(error) :: err !! Error status + LOGICAL :: zcreate + INTEGER :: i,idx + CHARACTER(len=:), ALLOCATABLE :: sname,pname + TYPE(words) :: values + zcreate = .false. ; IF (PRESENT(create)) zcreate = create + err = noerror + idx = cp_get_opt_idx(this,name) + DO i=1,SIZE(input) ; CALL words_append(values,to_string(input(i))); ENDDO + IF (idx == -1) THEN + IF (zcreate) THEN + err = op_split_name(name,sname,pname) + IF (err == 0) err = cp_add_opt(this,sname,pname,values) + ELSE + err = error("Option "//TRIM(name)//" does not exist",-7) + ENDIF + ELSE + this%options(idx)%values = values + ENDIF + CALL words_clear(values) + END FUNCTION cp_set_rv_ve + + FUNCTION cp_set_dv_ve(this,name,input,create) RESULT(err) + !! Set new value for the given option by name (double/vector)) + !! + !! If _create_ is given to .true., the method will add a new option if it does not exist in + !! the parser. + !! In such case, an error (-6, invalid name) is raised if the option name is not valid. + !! + !! In other case, if the option is not defined in the parser the error status is set to -7. + OBJECT(cfgparser), INTENT(inout) :: this !! Cfgparser object + CHARACTER(len=*), INTENT(in) :: name !! (Full) Name of the option to get + REAL(kind=8), INTENT(in), DIMENSION(:) :: input !! Input values + LOGICAL, INTENT(in), OPTIONAL :: create !! .true. to create option if it does not exist (default to false) + TYPE(error) :: err !! Error status + LOGICAL :: zcreate + INTEGER :: i,idx + CHARACTER(len=:), ALLOCATABLE :: sname,pname + TYPE(words) :: values + zcreate = .false. ; IF (PRESENT(create)) zcreate = create + err = noerror + idx = cp_get_opt_idx(this,name) + DO i=1,SIZE(input) ; CALL words_append(values,to_string(input(i))); ENDDO + IF (idx == -1) THEN + IF (zcreate) THEN + err = op_split_name(name,sname,pname) + IF (err == 0) err = cp_add_opt(this,sname,pname,values) + ELSE + err = error("Option "//TRIM(name)//" does not exist",-7) + ENDIF + ELSE + this%options(idx)%values = values + ENDIF + CALL words_clear(values) + END FUNCTION cp_set_dv_ve + + FUNCTION cp_set_iv_ve(this,name,input,create) RESULT(err) + !! Set new value for the given option by name (integer/vector) + !! + !! If _create_ is given to .true., the method will add a new option if it does not exist in + !! the parser. + !! In such case, an error (-6, invalid name) is raised if the option name is not valid. + !! + !! In other case, if the option is not defined in the parser the error status is set to -7. + OBJECT(cfgparser), INTENT(inout) :: this !! Cfgparser object + CHARACTER(len=*), INTENT(in) :: name !! (Full) Name of the option to get + INTEGER, INTENT(in), DIMENSION(:) :: input !! Input values + LOGICAL, INTENT(in), OPTIONAL :: create !! .true. to create option if it does not exist (default to false) + TYPE(error) :: err !! Error status + LOGICAL :: zcreate + INTEGER :: i,idx + CHARACTER(len=:), ALLOCATABLE :: sname,pname + TYPE(words) :: values + zcreate = .false. ; IF (PRESENT(create)) zcreate = create + err = noerror + idx = cp_get_opt_idx(this,name) + DO i=1,SIZE(input) ; CALL words_append(values,to_string(input(i))); ENDDO + IF (idx == -1) THEN + IF (zcreate) THEN + err = op_split_name(name,sname,pname) + IF (err == 0) err = cp_add_opt(this,sname,pname,values) + ELSE + err = error("Option "//TRIM(name)//" does not exist",-7) + ENDIF + ELSE + this%options(idx)%values = values + ENDIF + CALL words_clear(values) + END FUNCTION cp_set_iv_ve + + FUNCTION cp_set_lv_ve(this,name,input,create) RESULT(err) + !! Set new value for the given option by name (logical/vector) + !! + !! If _create_ is given to .true., the method will add a new option if it does not exist in + !! the parser. + !! In such case, an error (-6, invalid name) is raised if the option name is not valid. + !! + !! In other case, if the option is not defined in the parser the error status is set to -7. + OBJECT(cfgparser), INTENT(inout) :: this !! Cfgparser object + CHARACTER(len=*), INTENT(in) :: name !! (Full) Name of the option to get + LOGICAL, INTENT(in), DIMENSION(:) :: input !! Input values + LOGICAL, INTENT(in), OPTIONAL :: create !! .true. to create option if it does not exist (default to false) + TYPE(error) :: err !! Error status + LOGICAL :: zcreate + INTEGER :: i,idx + CHARACTER(len=:), ALLOCATABLE :: sname,pname + TYPE(words) :: values + zcreate = .false. ; IF (PRESENT(create)) zcreate = create + err = noerror + idx = cp_get_opt_idx(this,name) + DO i=1,SIZE(input) ; CALL words_append(values,to_string(input(i))); ENDDO + IF (idx == -1) THEN + IF (zcreate) THEN + err = op_split_name(name,sname,pname) + IF (err == 0) err = cp_add_opt(this,sname,pname,values) + ELSE + err = error("Option "//TRIM(name)//" does not exist",-7) + ENDIF + ELSE + this%options(idx)%values = values + ENDIF + CALL words_clear(values) + END FUNCTION cp_set_lv_ve + + FUNCTION cp_set_cv_ve(this,name,input,create) RESULT(err) + !! Set new value for the given option by name (complex/vector) + !! + !! If _create_ is given to .true., the method will add a new option if it does not exist in + !! the parser. + !! In such case, an error (-6, invalid name) is raised if the option name is not valid. + !! + !! In other case, if the option is not defined in the parser the error status is set to -7. + OBJECT(cfgparser), INTENT(inout) :: this !! Cfgparser object + CHARACTER(len=*), INTENT(in) :: name !! (Full) Name of the option to get + COMPLEX, INTENT(in), DIMENSION(:) :: input !! Input values + LOGICAL, INTENT(in), OPTIONAL :: create !! .true. to create option if it does not exist (default to false) + TYPE(error) :: err !! Error status + LOGICAL :: zcreate + INTEGER :: i,idx + CHARACTER(len=:), ALLOCATABLE :: sname,pname + TYPE(words) :: values + zcreate = .false. ; IF (PRESENT(create)) zcreate = create + err = noerror + idx = cp_get_opt_idx(this,name) + DO i=1,SIZE(input) ; CALL words_append(values,to_string(input(i))); ENDDO + IF (idx == -1) THEN + IF (zcreate) THEN + err = op_split_name(name,sname,pname) + IF (err == 0) err = cp_add_opt(this,sname,pname,values) + ELSE + err = error("Option "//TRIM(name)//" does not exist",-7) + ENDIF + ELSE + this%options(idx)%values = values + ENDIF + CALL words_clear(values) + END FUNCTION cp_set_cv_ve + + FUNCTION cp_set_sv_ve(this,name,input,create) RESULT(err) + !! Set new value for the given option by name (complex/vector) + !! + !! If _create_ is given to .true., the method will add a new option if it does not exist in + !! the parser. + !! In such case, an error (-6, invalid name) is raised if the option name is not valid. + !! + !! In other case, if the option is not defined in the parser the error status is set to -7. + OBJECT(cfgparser), INTENT(inout) :: this !! Cfgparser object + CHARACTER(len=*), INTENT(in) :: name !! (Full) Name of the option to get + CHARACTER(len=*), INTENT(in), DIMENSION(:) :: input !! Input values + LOGICAL, INTENT(in), OPTIONAL :: create !! .true. to create option if it does not exist (default to false) + TYPE(error) :: err !! Error status + LOGICAL :: zcreate + INTEGER :: i,idx + CHARACTER(len=:), ALLOCATABLE :: sname,pname + TYPE(words) :: values + zcreate = .false. ; IF (PRESENT(create)) zcreate = create + err = noerror + idx = cp_get_opt_idx(this,name) + DO i=1,SIZE(input) ; CALL words_append(values,trim(input(i))); ENDDO + IF (idx == -1) THEN + IF (zcreate) THEN + err = op_split_name(name,sname,pname) + IF (err == 0) err = cp_add_opt(this,sname,pname,values) + ELSE + err = error("Option "//TRIM(name)//" does not exist",-7) + ENDIF + ELSE + this%options(idx)%values = values + ENDIF + CALL words_clear(values) + END FUNCTION cp_set_sv_ve + + ! i/o functions + !-------------- + + RECURSIVE FUNCTION read_include(parser,path,isec,ipaths,override) RESULT(err) + !! Read and parse an included configuration file (internal) + !! @note + !! On error, the cfgparser object is left unchanged. + TYPE(cfgparser), INTENT(inout) :: parser + !! A cfgparser object that will store the configuration + CHARACTER(len=*), INTENT(in) :: path + !! A string with the path of the input file to read + CHARACTER(len=st_slen), INTENT(inout) :: isec + !! Current section name + TYPE(words), INTENT(inout) :: ipaths + !! List of paths of already included files + LOGICAL, INTENT(in), OPTIONAL :: override + !! An optional boolean flag with .true. to override previous value of duplicated options instead of raising an error. + TYPE(error) :: err + !! An error with the first error encountered + TYPE(option) :: curopt + LOGICAL :: zoverride,ok,has_opt + INTEGER :: lineno,lu,i + CHARACTER(len=2), PARAMETER :: space = CHAR(32)//"," ! check if , is really wanted.. + CHARACTER(len=2), PARAMETER :: blanks = CHAR(9)//CHAR(32) ! currently not used because blanks truncate. + CHARACTER(len=15) :: sln + CHARACTER(len=:), ALLOCATABLE :: fulp,dirp,basp + CHARACTER(len=:), ALLOCATABLE :: curval,ipath + CHARACTER(len=:), ALLOCATABLE :: line,name,value + INTEGER, PARAMETER :: cfg_UNKNOWN = -1, & + cfg_SECTION = 0, & + cfg_OPTION = 1 + + zoverride = .false. ; IF (PRESENT(override)) zoverride = override + ! initialize local variables + curval = '' ; line = '' ; name = '' ; value = '' + lineno = 0 ; lu = free_lun() + IF (LEN_TRIM(isec) == 0) isec = "__default__" + i = INDEX(TRIM(path),"/",.true.) + IF (i == 0) THEN + fulp = fs_realpath("./"//TRIM(ADJUSTL(path))) + ELSE + fulp = fs_realpath(TRIM(ADJUSTL(path))) + ENDIF + basp = fs_basename(fulp) + dirp = fs_dirname(fulp) + ! check for file + INQUIRE(FILE=TRIM(path),EXIST=ok) + IF (.NOT.ok) THEN + err = error(TRIM(path)//": no such file",-11) + RETURN + ENDIF + ! check for lun + IF (lu == -1) THEN ; err = error("No available logical unit",-12) ; RETURN ; ENDIF + OPEN(lu,FILE=TRIM(path),STATUS='old',ACTION='READ') + DO WHILE(readline(lu,line)) + lineno = lineno + 1 + WRITE(sln,'(I15)') lineno ; sln=ADJUSTL(sln) + ! comment or blank line ? + IF (is_comment(line,ipath)) THEN + ! check for includes + IF (LEN(ipath) > 0) THEN + ! 1) get relative path + ipath = fs_relpath(ipath,dirp) + ! 2) compute asbolute path) + ipath = TRIM(dirp)//"/"//TRIM(ipath) + ipath = fs_realpath(ipath) + IF (.NOT.check_include(ipaths,ipath)) THEN + ipath = fs_basename(ipath) + err = error(basp//'(L'//TRIM(sln)//"): Circular include & + &reference to "//ipath,-14) + EXIT + ENDIF + IF (op_valid(curopt) .AND. LEN(curval) > 0) THEN + CALL words_extend(curopt%values,TRIM(ADJUSTL(curval)),space,.true.,.true.) + IF (zoverride) THEN + err = cp_update_opt(parser,curopt%section,curopt%name,curopt%values) + ELSE + err = cp_add_opt(parser,curopt%section,curopt%name,curopt%values) + ENDIF + CALL op_clear(curopt); curval = '' + ENDIF + err = read_include(parser,ipath,isec,ipaths,zoverride) + IF (err /= 0) EXIT + ENDIF + CYCLE + ENDIF + ! continuation line ? + IF (SCAN(line(1:1),blanks) /= 0 .AND. op_valid(curopt)) THEN + IF (LEN(curval) == 0) THEN + curval = strip_comment(line) + ELSE + curval = curval//CHAR(32)//strip_comment(line) + ENDIF + ELSE + ! 1. Remove comment part and left adjust line + line = strip_comment(line) + ! a section header or option header? + SELECT CASE (get_kind(line,name,value)) + CASE(cfg_SECTION) + ! 1. add current value to current option (if any) + ! 2. update "isec" variable + IF (op_valid(curopt)) THEN + IF (LEN(curval) > 0) & + CALL words_extend(curopt%values,TRIM(ADJUSTL(curval)),space,.true.,.true.) + IF (zoverride) THEN + err = cp_update_opt(parser,curopt%section,curopt%name,curopt%values) + ELSE + err = cp_add_opt(parser,curopt%section,curopt%name,curopt%values) + ENDIF + ENDIF + CALL op_clear(curopt) ; curval = '' + IF (cfg_has_section(parser,name) .AND. & + TRIM(name)/="__default__" .AND. & + .NOT.zoverride) THEN + err = error(basp//'(L'//TRIM(sln)//"): Duplicate section '"//name,-8) + EXIT + ENDIF + !print*,"DEBUG0: New section ",TRIM(name), " <- ",isec + isec = TRIM(name) + CASE(cfg_OPTION) + ! 1. add current value to current option (if any) + ! 2. search for option in cursect: + ! --> duplicate option error if it exists + ! --> create new option if it does not exist (using curopt) + ! 3. curval is set to value + ! 4. update curval + IF (op_valid(curopt)) THEN + !print*,"DEBUG3: new opt: ",TRIM(isec)//"/"//TRIM(name)," <- ",op_full_name(curopt) + IF (LEN(curval) > 0) & + CALL words_extend(curopt%values,TRIM(ADJUSTL(curval)),space,.true.,.true.) + IF (zoverride) THEN + err = cp_update_opt(parser,curopt%section,curopt%name,curopt%values) + ELSE + err = cp_add_opt(parser,curopt%section,curopt%name,curopt%values) + ENDIF + ENDIF + CALL op_clear(curopt) ; curval = '' + has_opt = cfg_has_option(parser,TRIM(isec)//"/"//TRIM(name)) + + IF (has_opt.AND..NOT.zoverride) THEN + ! it is an error: no duplicate allowed + err = error(basp//'(L'//TRIM(sln)//"): Duplicate option '"//TRIM(name)//"' in "//isec,-8) + EXIT + ENDIF + curopt%name = TRIM(name) + curopt%section = TRIM(isec) + CALL words_clear(curopt%values) + curval = value + CASE(cfg_UNKNOWN) + ! unknown handles also invalid name: it is a critical error + IF (err == -9) EXIT + END SELECT + ENDIF + ENDDO + IF (op_valid(curopt)) THEN + IF (LEN(curval) > 0) & + CALL words_extend(curopt%values,TRIM(ADJUSTL(curval)),space,.true.,.true.) + IF (zoverride) THEN + err = cp_update_opt(parser,curopt%section,curopt%name,curopt%values) + ELSE + err = cp_add_opt(parser,curopt%section,curopt%name,curopt%values) + ENDIF + ENDIF + CALL op_clear(curopt) ; curval = '' + + CLOSE(lu) + + CONTAINS + FUNCTION get_kind(string,name,value) RESULT(kind) + !! Split input line and attempt to guess its relevant kind of statement + !! + !! The input line is searched for section header format or option assignment. + !! + !! - If line begins with '[', has ']' and no '=#' between '[' and ']' + !! it is a section header. + !! - Otherwise, if line has '=', without '#' before '=', it is an option. + !! + !! Then the method returns an integer with the kind flag of the statement which is one of + !! -1 (cfg_UNKNOWN), 0 (cfg_SECTION) or 1 (cfg_OPTION). + CHARACTER(len=*), INTENT(in) :: string !! Input string to process + CHARACTER(len=:), INTENT(out), ALLOCATABLE :: name, & !! Name of the relevant option/section if any, otherwise an empty string. + value !! Value of the relevant option (if any), otherwise an empty string + INTEGER :: kind !! An integer with the kind of statement. + CHARACTER(len=:), ALLOCATABLE :: copy + INTEGER :: bi,ei + CHARACTER(len=2), PARAMETER :: quotes=CHAR(34)//CHAR(39) + kind = cfg_UNKNOWN + ! get a trimmed (and left adjusted) copy + copy = TRIM(string) + ! Is it a section ? + ! ---> search for subscripts of '[' and ']' + ! ---> check that '[' is 1st char and ']' is last char + bi = INDEX(copy,'[') ; ei = INDEX(copy,']') + IF (bi == 1 .AND. ei == LEN(copy) .AND. bi < ei) THEN + ! it is a section header + kind = cfg_SECTION + ! get section name: adjust and trim to remove extra blank spaces + name = str_to_lower(TRIM(ADJUSTL(copy(bi+1:ei-1)))) + IF (TRIM(name) /= "__default__" .AND. .NOT.cfg_check_name(name)) THEN + kind = cfg_UNKNOWN + err = error("Invalid section name ("//name//")",-9) + RETURN + ENDIF + value = '' + ELSE + ! Is it an option ? + ! --> search for '=' and check if it is set before + ! 1st quote (if any) + bi = INDEX(copy,"=") + ! search for quotes + ei = SCAN(copy,quotes) ; IF (ei==0) ei = LEN(copy)+1 + IF (bi /= 0 .AND. bi < ei) THEN + kind = cfg_OPTION + name = str_to_lower(TRIM(copy(1:bi-1))) + IF (.NOT.cfg_check_name(name)) THEN + kind = cfg_UNKNOWN + err = error("Invalid option name ("//TRIM(name)//")",-9) + RETURN + ENDIF + IF (bi == LEN(copy)) THEN + value = '' + ELSE + value = TRIM(copy(bi+1:)) + ENDIF + ELSE + ! not an option and not a section: malformed statement ! + err = error('Malformed statement at line '//TRIM(sln),-13) + ENDIF + ENDIF + RETURN + END FUNCTION get_kind + + FUNCTION strip_comment(line) RESULT(stripped) + !! Replace comments part of a string by blank spaces + !! The method replaces every characters after '#' (included) by spaces. + !! @note + !! Output string is also left adjusted, thus only trailing blank can be present. + CHARACTER(len=*), INTENT(in) :: line !! A string to process + CHARACTER(len=LEN(line)) :: stripped !! A string of same length than 'line' but without comment(s) + + INTEGER :: idx + stripped = ADJUSTL(line) + idx = INDEX(stripped,"#") + IF (idx > 0) stripped(idx:) = REPEAT(CHAR(32),LEN(line)-idx+1) + RETURN + END FUNCTION strip_comment + + FUNCTION readline(lun,string) RESULT(not_eof) + !! Read a complete line + !! + !! Each time it is CALLed, the function reads a complete of the file opened in 'lun' logical + !! unit and returns .false. if EOF has been reached, .true. otherwise. + !! + !! The function is intended to read a file line by line: + !! + !! ```fortran + !! lu = 1 + !! open(lu,file="path/to/the/file/to/read") + !! l=0 ! A line counter + !! DO WHILE(readline(lu,line)) + !! l = l + 1 + !! WRITE(*,'("L",I2.2,": ",(a))') il,line + !! ENDDO + !! CLOSE(1) + !! ``` + INTEGER, INTENT(in) :: lun !! Logical unit with the opened file to read. + CHARACTER(len=:), INTENT(out), ALLOCATABLE :: string !! Output processed line + LOGICAL :: not_eof !! .true. if EOF has NOT been reached yet, .false. otherwise + CHARACTER(len=50) :: buf + INTEGER :: e,sz + not_eof = .true. ; string = '' + DO + READ(lun,'(a)',ADVANCE="no",SIZE=sz,IOSTAT=e) buf + IF (e == IOSTAT_END) THEN + not_eof = .false. + IF (sz > 0) THEN + string=string//buf(1:sz) + ENDIF + EXIT + ELSE IF (e == IOSTAT_EOR) THEN + string = string//buf(1:sz) + EXIT + ELSE + string = string//TRIM(buf) + ENDIF + ENDDO + END FUNCTION readline + + FUNCTION is_comment(str,incpath) RESULT(res) + !! Check if line is a comment or an empty string + !! @warning + !! Currently, if an '#include' statement is found, the method assumes a single path is set after the directive. + CHARACTER(len=*), INTENT(in) :: str + !! The string to check + CHARACTER(len=:), INTENT(out), ALLOCATABLE :: incpath + !! A string with the filepath to be included if '#include' statement is found, empty string otherwise + LOGICAL :: res + !! .true. if line is a comment or an empty string, .false. otherwise + CHARACTER(len=:), ALLOCATABLE :: copy + res = .false. ; incpath = '' + copy = TRIM(ADJUSTL(str)) + IF (LEN(copy) == 0) THEN + res = .true. + ELSE IF (INDEX(copy,"#") == 1) THEN + res = .true. + ! search for include statement + ! IMPORTANT: assume that there is only a path after include statement + IF (INDEX(copy,"#include ") == 1) incpath = TRIM(ADJUSTL(copy(10:))) + ENDIF + RETURN + END FUNCTION is_comment + + FUNCTION check_include(list,incpath) RESULT(ok) + !! Check if path is not in list + !! @note + !! If path is not in list it is added to the list. + TYPE(words), INTENT(inout) :: list !! A list of paths + CHARACTER(len=*), INTENT(in) :: incpath !! Path to check in list + LOGICAL :: ok !! .true. if 'path' is __not__ in list, .false. otherwise + CALL words_reset(list) + ok = .true. + DO WHILE(words_valid(list)) + IF (TRIM(incpath) == TRIM(words_current(list))) THEN + ok = .false. ; EXIT + ENDIF + CALL words_next(list) + ENDDO + IF (ok) CALL words_append(list,TRIM(incpath)) + END FUNCTION check_include + + END FUNCTION read_include + + ! insertion sort... internal + + SUBROUTINE insertionSort(opts) + !! Sort an array of Options using insertion sort algorithm + TYPE(option), INTENT(inout), DIMENSION(:) :: opts !! Array to sort. + TYPE(option) :: temp + INTEGER :: i, j + DO i = 2, SIZE(opts) + j = i - 1 + temp = opts(i) + DO WHILE (j>=1) ! .AND. op_greater_than(opts(j),temp)) + IF (op_greater_than(opts(j),temp)) THEN + opts(j+1) = opts(j) + j = j - 1 + ELSE + EXIT + ENDIF + ENDDO + opts(j+1) = temp + CALL op_clear(temp) + ENDDO + END SUBROUTINE insertionSort + + FUNCTION free_lun() RESULT(lu) + !> Get the first free logical unit + !! + !! The function loops from 7 to 9999 and returns the first free logical unit. + !! @note + !! According to Fortran standard, the maximum value for a lun is processor + !! dependent. I just assume that [7,9999] is a valid range and I believe that + !! 9992 files to be opened is far enough for any program ! + !! @note + !! If you intend to use loggers object from this library, you should keep in + !! mind that loggers open files with the first free logical unit. Consequently + !! if you need to perform I/O operations you should use this function to get a + !! free lun instead of just randomly set a lun ! + INTEGER :: lu + !! First free logical unit in the range [7,999] or -1 if no lun is available + INTEGER, PARAMETER :: mxlu = 9999 + LOGICAL :: notfree + lu = 6 ; notfree = .true. + DO WHILE(notfree.AND.lu<=mxlu) + lu=lu+1 ; INQUIRE(unit=lu,OPENED=notfree) + ENDDO + IF (lu >= mxlu) lu = -1 + END FUNCTION free_lun + +END MODULE CFGPARSE + Index: trunk/LMDZ.TITAN/libf/muphytitan/config/mmp2m1d.titan.cfg =================================================================== --- trunk/LMDZ.TITAN/libf/muphytitan/config/mmp2m1d.titan.cfg (revision 1793) +++ trunk/LMDZ.TITAN/libf/muphytitan/config/mmp2m1d.titan.cfg (revision 1793) @@ -0,0 +1,56 @@ + +## include parameters from YAMMS configuration. +## (all the parameters defined in this file will overriden values defined in mp2m.cfg) +#include inputs/mp2m.cfg + +## INPUT FILES (profiles) +# Path of the spherical mode transfert probability look-up tables file +# (optional if 'transfert_probability' is True) +ps2s_file = inputs/mmp_ps2s.nc +# Path of the spherical mode transfert probability look-up tables file +# (optional if 'transfert_probability' is True) +mq_file = inputs/mmp_qmean.nc + +# Electric charging coagulation correction +# If set to .false. then no correction is assumed +electric_charging = F + +# Enable/disable spherical mode transfert probability +transfert_probability = T + +# MP2M Configuration file (relative to executable path !) +# not needed here.. we have included the file (at the top of this one). +mp2m_cfg = '' + +# alpha_X sections contain the parameters of the inter-moments relation function for +# the mode X: either spherical (s) or fractal (f) +# dndr_X sections contain the parameters of the size-distribution law of the mode X +[alpha_s] +a = 0.09887273981548324 +b = 0.0 +c = 0.0 +[dndr_s] +rc = 1e-6 +a0 = 1.2339698E+15 +c = 0. +a = 6.6133008E-06, 8.9867475E+00, 6.5136506E+00, 4.5832927E-02 +b = 3.1369611E+01, 4.9958440E+00, -6.7012835E+00, -1.5499933E+01 +[alpha_f] +a = -2.5000000E-02, 2.1999082E-02, 1.5642034E-01, 2.5988014E-02, -5.3718083E-02 +b = 1.6000000E+00, 1.7287786E-02, 4.4026716E-01, 2.7319185E-01, 2.2855094E-01 +c = -3.5000000E+01, -3.6736168E-02, -2.3930789E+01, -3.3881667E+00, -6.0753628E+00 +[dndr_f] +rc = 5.1230710E-07 +a0 = 1.2339698E+15 +c = 0. +a = 6.6133008E-06, 8.9867475E+00, 6.5136506E+00, 4.5832927E-02 +b = 3.1369611E+01, 4.9958440E+00, -6.7012835E+00, -1.5499933E+01 +# ================= # +# b^T_k cofficients # +# ================= # +# This section gathers the values of all the btk coefficient used in the coagulation +# equations for the free-molecular regime. +[btks] +bt0 = 0.72d0, 0.72d0, 0.80d0, 0.97d0, 0.00d0 +bt3 = 0.73d0, 0.73d0, 0.00d0, 0.97d0, 0.97d0 + Index: trunk/LMDZ.TITAN/libf/muphytitan/config/mp2m.titan.cfg =================================================================== --- trunk/LMDZ.TITAN/libf/muphytitan/config/mp2m.titan.cfg (revision 1793) +++ trunk/LMDZ.TITAN/libf/muphytitan/config/mp2m.titan.cfg (revision 1793) @@ -0,0 +1,74 @@ +# YAMMS model parameters +# ====================== + +### Model global parameters +###------------------------ +# Model time step (s) +timestep = 5000 +# Enable/disable Haze production process +haze_production = T +# Enable/disable Haze coagulation process +haze_coagulation = T +# Coagulation interactions, a combination of: +# 0 - no interactions (same as haze_coagulation == F) +# 1 - SS interactions +# 2 - SF interactions +# 4 - FF interactions. +# (for example: 5 = 4+1 --> SS and FF coagulation only) +haze_coag_interactions = 7 +# Enable/disable Haze sedimentation process +haze_sedimentation = T +# Disable Fiadero correction for sedimentation process +no_fiadero = F +# Fiadero correction minimum ratio threshold +fiadero_min_ratio = 0.1 +# Fiadero correction maximum ratio threshold +fiadero_max_ratio = 10. +# Force settling velocity to M0 +wsed_m0 = F +# Force settling velocity to M3 +wsed_m3 = F +# Enable/disable clouds microphysics +clouds_microphysics = F +# Enable/disable clouds sedimentation process +# (automatically set to F if clouds microphysics is not enabled) +clouds_sedimentation = T +# Enable/disable clouds nucleation and condensation processes +# (automatically set to F if clouds microphysics is not enabled) +clouds_nuc_cond = T +# Condensible species configuration file +# (not needed if clouds microphysics is not enabled) +specie_cfg = /home/burgalat/test_sedim/inputs/mp2m_species.cfg + +### Aerosols related parameters +###---------------------------- +# Aerosols density (kg.m-3) +rho_aer = 1000. +# Monomer radius (m) +rm = 6.6e-8 +# Fractal dimension of the fractal mode +df = 2. +# Aerosols production pressure level (Pa) +p_prod = 1.0 +# Aerosols production rate (kg.m-2.s-1) +tx_prod = 3.5e-13 +# Characteristic radius for production scheme +rc_prod = 20e-9 +# Aerosols electric charging (e-.m-1) +# (not used, only set as a reminder !) +ne = -15d6 +###-------------------------- + +### Planet related parameters (currently Venus for sedim, Titan for other params) +###-------------------------- +# Planet radius (m) +planet_radius = 2575000. +# Air molecule radius (m) +air_radius = 1.75e-10 +# Air mean molar mass (kg.mol-1) +air_molarmass = 28.e-3 +## Planet acceleration of gravity at the ground (m.s-2) +g0 = 1.35 +###-------------------------- + + Index: trunk/LMDZ.TITAN/libf/muphytitan/config/mp2m_species.cfg =================================================================== --- trunk/LMDZ.TITAN/libf/muphytitan/config/mp2m_species.cfg (revision 1793) +++ trunk/LMDZ.TITAN/libf/muphytitan/config/mp2m_species.cfg (revision 1793) @@ -0,0 +1,135 @@ +#---------------------------------------------------------------------------------------- +# mp_scpecies.cfg +# Thermodynamic properties of chemical species used in the cloud microphysics processes. +# Each condensible specie that should be treated by the model must be entirely described +# here. +# +# Air specie is always mandatory. It is saved in a special variable in the model and is +# never used as cloud condensible specie. +#----------------------------------------------------------------------------------------- +# PARAMETER | DESCRIPTION +# ----------|----------------------------------------------------------------------------- +# name | Specie name, should be the same as the section name +# mas | Molecular weight +# vol | Molecular volume +# ray | Molecular radius +# masmol | Molar mass +# rho | Density +# tc | Critical temperature +# tb | Boiling temperature +# pc | Critical pressure (in bar !!!) +# w | Acentric factor +# a_sat | Coefficient A of Psat equation (from Reid et al. 1986). +# b_sat | Coefficient B of Psat equation (from Reid et al. 1986). +# c_sat | Coefficient C of Psat equation (from Reid et al. 1986). +# d_sat | Coefficient D of Psat equation (from Reid et al. 1986). +# mteta | Wettability (free parameter in most cases, from 0 to 1) +# tx_prod | Production rate (actually this is not used by the model) +#----------------------------------------------------------------------------------------- + +### List of actual species to be used in the model: +### WARNING : the list of species specified here should be ordered: +### In the model, ice tracers as well as condensible gazs species must have the same +### index. +used_species = "CH4", "C2H6", "C2H2" + +# AIR properties (MANDATORY !!!) +################################ +[air] +name = "air" +mas = 4.650e-26 +vol = 5.750e-29 +ray = 1.750e-10 +masmol = 28.e-3 +rho = 808.6 +tc = 126.2 +tb = 77.4 +pc = 33.9 +w = 3.9e-2 +a_sat = -6.09676 +b_sat = 1.13670 +c_sat = -1.04072 +d_sat = -1.93306 +mteta = 0. +tx_prod = 0. + +# CH4 properties (useful for Titan :) +##################################### +[CH4] +name = "CH4" +mas = 2.6578e-26 +vol = 6.252e-29 +ray = 2.000e-10 +masmol = 16.e-3 +rho = 425. +tc = 190.4 +tb = 111.6 +pc = 46.0 +w = 1.1e-2 +a_sat = -6.00435 +b_sat = 1.18850 +c_sat = -0.83408 +d_sat = -1.22833 +mteta = 0.92 +tx_prod = 0. + +# C2H6 properties +################# +[C2H6] +name = "C2H6" +mas = 4.983e-26 +vol = 9.094e-29 +ray = 2.220e-10 +masmol = 30.e-3 +rho = 544.6 +tc = 305.4 +tb = 184.6 +pc = 48.8 +w = 9.9e-2 +a_sat = -6.34307 +b_sat = 1.01163 +c_sat = -1.19116 +d_sat = -2.03539 +mteta = 0.92 +tx_prod = 1.2e-12 + +# C2H2 properties +################# +[C2H2] +name = "C2H2" +mas = 4.319e-26 +vol = 7.020e-29 +ray = 2.015e-10 +masmol = 26.e-3 +rho = 615. +tc = 308.8 +tb = 188.4 +pc = 61.4 +w = 19.0e-2 +a_sat = -6.90128 +b_sat = 1.26873 +c_sat = -2.09113 +d_sat = -2.75601 +mteta = 0.92 +tx_prod = 3.2e-13 + +# HCN properties +################# +[HCN] +name = "HCN" +mas = 4.484e-26 +vol = 6.498e-29 +ray = 2.494e-10 +masmol = 27.e-3 +rho = 690. +tc = 456.7 +tb = 298.9 +pc = 53.9 +w = 0.388 +a_sat = 31.122 +b_sat = 4183.37 +c_sat = -3.004 +d_sat = 1635. +mteta = 0.92 +tx_prod = 1e-12 + Index: trunk/LMDZ.TITAN/libf/muphytitan/config/template.cfg =================================================================== --- trunk/LMDZ.TITAN/libf/muphytitan/config/template.cfg (revision 1793) +++ trunk/LMDZ.TITAN/libf/muphytitan/config/template.cfg (revision 1793) @@ -0,0 +1,87 @@ +# YAMMS model parameters +# ====================== + +### Model global parameters +###------------------------ +# Enable/disable Haze production process +haze_production = T +# Enable/disable Haze coagulation process +haze_coagulation = T +# Coagulation interactions, a combination of: +# 0 - no interactions (same as haze_coagulation == F) +# 1 - SS interactions +# 2 - SF interactions +# 4 - FF interactions. +# (for example: 5 = 4+1 --> SS and FF coagulation only) +haze_coag_interactions = 7 +# Enable/disable Haze sedimentation process +haze_sedimentation = T +# Disable Fiadero correction for sedimentation process +no_fiadero = F +# Fiadero correction minimum ratio threshold +fiadero_min_ratio = 0.1 +# Fiadero correction maximum ratio threshold +fiadero_max_ratio = 10. +# Force settling velocity to M0 +wsed_m0 = T +# Force settling velocity to M3 +wsed_m3 = F +# Enable/disable clouds sedimentation process +# (automatically set to F if clouds microphysics is not enabled) +clouds_sedimentation = T +# Enable/disable clouds nucleation and condensation processes +# (automatically set to F if clouds microphysics is not enabled) +clouds_nuc_cond = T +# Condensible species configuration file +# (not needed if clouds microphysics is not enabled) +specie_cfg = /home/burgalat/test_sedim/inputs/mp2m_species.cfg + + +# Enable/disable spherical mode transfert probability +transfert_probability = F +# Path of the spherical mode transfert probability look-up tables file +# (optional if 'transfert_probability' is False) +ps2s_file = inputs/mmp_ps2s.nc + +# Electric charging coagulation correction +# If set to .false. then no correction is assumed +electric_charging = F +# Path of the electric charging correction factor. +# (optional if 'electric_charging' is False) +mq_file = inputs/mmp_qmean.nc + +# alpha_X sections contain the parameters of the inter-moments relation function for +# the mode X: either spherical (s) or fractal (f) +# dndr_X sections contain the parameters of the size-distribution law of the mode X +[alpha_s] +a = -3.8450202E-04, 1.9300880E-01, -1.5824302E+02, 3.1805033E-01, 1.1335227E-01, 3.0615066E-02 +b = -3.9438738E-01, 3.3815486E+00, -1.7000626E+02, 3.3353316E-01, 2.4314346E-01, -1.6559447E-01 +c = -7.9835178E-01, -1.8853289E+01, -2.0306468E+02, -7.3818724E+00, -3.4832076E+00, -6.5662798E-01 +[dndr_s] +rc = 4.58219580180634588E-007 +a0 = 86144.861255561875 +c = 0d0 +a = 2.48333861883769357E-040, 1.46076790655632173E-013, 1.71525517568997062E-009, + 1.80855172875974993E-019, 1.48212594918347503E-047, 6.87247318898338451E-081 +b = 59.518212357684796, 15.507500262021228, -5.4179933012448069, + -9.3500794017892854, -18.207927270524777, -27.248924688740562 +[alpha_f] +a = -3.8450202E-04, 1.9300880E-01, -1.5824302E+02, 3.1805033E-01, 1.1335227E-01, 3.0615066E-02 +b = -3.9438738E-01, 3.3815486E+00, -1.7000626E+02, 3.3353316E-01, 2.4314346E-01, -1.6559447E-01 +c = -7.9835178E-01, -1.8853289E+01, -2.0306468E+02, -7.3818724E+00, -3.4832076E+00, -6.5662798E-01 +[dndr_f] +rc = 4.58219580180634588E-007 +a0 = 86144.861255561875 +c = 0d0 +a = 2.48333861883769357E-040, 1.46076790655632173E-013, 1.71525517568997062E-009, + 1.80855172875974993E-019, 1.48212594918347503E-047, 6.87247318898338451E-081 + +# ================= # +# b^T_k cofficients # +# ================= # +# This section gathers the values of all the btk coefficient used in the coagulation +# equations for the free-molecular regime. +[btks] +bt0 = 0.72d0, 0.72d0, 0.80d0, 0.97d0, 0.00d0 +bt3 = 0.73d0, 0.73d0, 0.00d0, 0.97d0, 0.97d0 + Index: trunk/LMDZ.TITAN/libf/muphytitan/csystem.c =================================================================== --- trunk/LMDZ.TITAN/libf/muphytitan/csystem.c (revision 1793) +++ trunk/LMDZ.TITAN/libf/muphytitan/csystem.c (revision 1793) @@ -0,0 +1,555 @@ +/* Copyright Jérémie Burgalat (2010-2015) + * + * burgalat.jeremie@gmail.com + * + * This software is a computer program whose purpose is to provide configuration + * file and command line arguments parsing features to Fortran programs. + * + * This software is governed by the CeCILL-B license under French law and + * abiding by the rules of distribution of free software. You can use, + * modify and/ or redistribute the software under the terms of the CeCILL-B + * license as circulated by CEA, CNRS and INRIA at the following URL + * "http://www.cecill.info". + * + * As a counterpart to the access to the source code and rights to copy, + * modify and redistribute granted by the license, users are provided only + * with a limited warranty and the software's author, the holder of the + * economic rights, and the successive licensors have only limited + * liability. + * + * In this respect, the user's attention is drawn to the risks associated + * with loading, using, modifying and/or developing or reproducing the + * software by the user in light of its specific status of free software, + * that may mean that it is complicated to manipulate, and that also + * therefore means that it is reserved for developers and experienced + * professionals having in-depth computer knowledge. Users are therefore + * encouraged to load and test the software's suitability as regards their + * requirements in conditions enabling the security of their systems and/or + * data to be ensured and, more generally, to use and operate it in the + * same conditions as regards security. + * + * The fact that you are presently reading this means that you have had + * knowledge of the CeCILL-B license and that you accept its terms. + */ + +#include +#include +#include +#include +#include +#include +#include // MAXPATHLEN +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#include "csystem.h" + +// Hack to get MAXPATHLEN +#ifndef MAXPATHLEN +#define MAXPATHLEN 4096 +#endif + +/* Get errno */ +int c_get_errno(){ + int ret = errno; + return ret; +} + +/* Get the current working directory */ +char* c_getcwd(){ + char *tmp; + tmp = (char *) malloc((MAXPATHLEN+1)*sizeof(char)); + memset(tmp,'\0',MAXPATHLEN+1); + if (getcwd(tmp,MAXPATHLEN) == NULL) { + free(tmp); + tmp = NULL; + } + return tmp; +} + + +/* Get the realpath of input path and saves it in output path */ +char* c_realpath(const char *input){ + if (!strlen(input)) { + return c_getcwd(); + } + return realpath(input,NULL); +} + + +/* Get directory name of input path */ +char* c_dirname(const char *in){ + char *tmp = strdup(in); + char *ou = strdup(dirname(tmp)); + free(tmp); + return ou; +} + +/* Get base name of input path */ +char* c_basename(const char *in){ + char* tmp = strdup(in); + char *ou = strdup(basename(tmp)); + free(tmp); + return ou; +} + +/* Get the corresponding name of the given user id */ +char* c_uname(int uid){ + struct passwd *pwd; + char *name; + name = NULL; + if ((pwd = getpwuid(uid)) != NULL){ + name = strdup(pwd->pw_name); + } + return name; +} + +/* Get the corresponding name of the given group id */ +char* c_gname(int gid){ + struct group *grp; + char *name; + name = NULL; + if ((grp = getgrgid(gid)) != NULL){ + name = strdup(grp->gr_name); + } + return name; +} + +/* Get the error message of the given error id */ +char* c_strerror(int err){ + char *tmp = strdup(strerror(err)); + if (errno != 0) + tmp = "Unknown error\0"; + return tmp; +} + + +/* Remove a directory and its contents recursively */ +int c_rmdir_f(const char *path) { + DIR *d = opendir(path); + size_t path_len = strlen(path); + int r = -1; + if (d) { + struct dirent *p; + r = 0; + while (!r && (p=readdir(d))) { + int r2 = -1; + char *buf; + size_t len; + /* Skip the names "." and ".." as we don't want to recurse on them. */ + if (!strcmp(p->d_name, ".") || !strcmp(p->d_name, "..")) { + continue; + } + len = path_len + strlen(p->d_name) + 2; + buf = malloc(len); + if (buf) { + struct stat statbuf; + snprintf(buf, len, "%s/%s", path, p->d_name); + if (!stat(buf, &statbuf)) { + if (S_ISDIR(statbuf.st_mode)) { + r2 = c_rmdir_f(buf); + } else { + r2 = unlink(buf); + } + } + free(buf); + } + r = r2; + } + closedir(d); + } + if (!r) { + r = rmdir(path); + return r?errno:0; + } + return r; +} + +/* Get some file informations */ +int c_fstat(const char *p, int *pe, int *nl, int *ty, int *ui, int *gi, + long *si, char a[20], char m[20], char c[20]){ + struct stat stb; + struct tm *t; + int ret ; + //char *tmp; + char tmp[20]; + *pe = *ty = *ui = *gi = *si = -1 ; + if (stat(p, &stb) != -1) { + *pe = (int)(stb.st_mode & (S_IRWXU | S_IRWXG | S_IRWXO)); + *nl = (int)(stb.st_nlink); + if (S_ISREG(stb.st_mode)) *ty = 0 + S_ISLNK(stb.st_mode); + else if (S_ISDIR(stb.st_mode)) *ty = 2 + S_ISLNK(stb.st_mode) ; + else *ty = 4; + *ui = (int)stb.st_uid ; *gi = (int)stb.st_gid ; *si = (long)stb.st_size ; + t = localtime(&stb.st_atime) ; ret = strftime(tmp, 20, "%F,%T", t); + if(ret != 0) {strncpy(a,tmp,20); a[19] = '\0';}else{a[0] = '\0';} + t = localtime(&stb.st_mtime) ; ret = strftime(tmp, 20, "%F,%T", t); + if(ret != 0) {strncpy(m,tmp,20); m[19] = '\0';}else{m[0] = '\0';} + t = localtime(&stb.st_ctime) ; ret = strftime(tmp, 20, "%F,%T", t); + if(ret != 0) {strncpy(c,tmp,20); c[19] = '\0';}else{c[0] = '\0';} + return 0; + } + return errno; +} + +/* Create a directory or a file in given path */ +int c_create(const char* path, mode_t mode, int astype, int forced){ + char *p, *d; + mode_t perm, cmask; + int eval; + // we build a directory + if (!astype){ + if(forced){eval=c_mkdirp(path,mode);}else{eval=c_mkdir(path,mode);} + }else{ + // we build a file + if (forced){ + p = strdup(path) ; if(p == NULL) {return errno;} + d = dirname(p) ; free(p) ; + if(d == NULL) {return -9;} + // we attempts to create parent directory first + cmask = umask(0); + perm =((S_IRWXU | S_IRWXG | S_IRWXO) & ~(cmask & ~(S_IWUSR | S_IXUSR))); + (void)umask(cmask) ; + eval = c_mkdirp(d,perm); + if(eval){return eval;} + } + eval = open(path,O_CREAT|O_EXCL,mode); + if (eval == -1) {eval=errno;}else{close(eval);eval=0;} + } + return eval ; +} + +/* Change current working directory */ +int c_chdir(const char *path){ + if (chdir(path) != 0) return errno ; + return 0; +} + +/* Remove a directory */ +int c_rmdir(const char *path){ + if ( rmdir(path) != 0) return errno; + return 0; +} + +/* Check if path is accessible */ +int c_access(const char *path, int perm) { + int ret; + if (perm<0 && perm >7) perm=0; + ret = access(path,perm); + if (ret) return errno; + return 0; +} + +/* Rename a path */ +int c_rename(const char *old, const char *new){ + if (rename(old,new) != 0) return errno ; + return 0; +} + +/* Change path permissions */ +int c_chmod(const char *path, mode_t mode){ + if (chmod(path,mode) != 0) return errno ; + return 0; +} + +/* Create directory */ +int c_mkdir(const char *path, mode_t mode){ + if(mkdir(path,mode) == 0) { + if (chmod(path, mode) == -1) return errno ; + return 0; + }else{ + return errno; + } +} + +/* Remove file from filesytem */ +int c_remove(const char *path){ + if (remove(path) != 0) return errno ; + return 0; +} + +/* Get terminal size */ +int c_termsize(int *rows,int *cols){ + struct winsize max; + int retval ; + retval = ioctl(0, TIOCGWINSZ , &max); + if (retval != 0) { + retval = errno ; + *rows = 20 ; *cols = 80 ; + }else{ + *rows = max.ws_row ; + *cols = max.ws_col ; + } + return retval; +} + +/* Get the current umask (in decimal system) */ +int c_umask(){ + mode_t mask ; + mask = umask(S_IRWXU | S_IRWXG | S_IRWXO); (void) umask(mask) ; + return (int)mask; +} + +/* ------------------ THIRD PARTY ------------------ */ + +/* + * Copyright (c) 1983, 1992, 1993 + * The Regents of the University of California. All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * 3. All advertising materials mentioning features or use of this software + * must display the following acknowledgement: + * This product includes software developed by the University of + * California, Berkeley and its contributors. + * 4. Neither the name of the University nor the names of its contributors + * may be used to endorse or promote products derived from this software + * without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND + * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE + * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + * SUCH DAMAGE. + */ +/* Creates directories recursively */ +int c_mkdirp(const char *path, mode_t mode) { + struct stat sb; + mode_t numask, oumask; + int first, last, retval; + char *cpath, *p; + cpath=strdup(path); if (cpath == NULL) return -1; + p = cpath; oumask = 0; retval = 0; + if (p[0] == '/') ++p; /* Skip leading '/'. */ + for (first = 1, last = 0; !last ; ++p) { + if (p[0] == '\0') last = 1; + else if (p[0] != '/') continue; + *p = '\0'; + //if (! strlen(p) && p[1] == '\0') last = 1; + if (first) { + oumask = umask(0); + numask = oumask & ~(S_IWUSR | S_IXUSR); + (void)umask(numask); + first = 0; + } + if (last) (void)umask(oumask); + if (mkdir(cpath, last ? mode : S_IRWXU | S_IRWXG | S_IRWXO) < 0) { + if (errno == EEXIST || errno == EISDIR) { + if (stat(cpath, &sb) < 0) { + retval = 1; break; + } else if (!S_ISDIR(sb.st_mode)) { + if (last) errno = EEXIST; else errno = ENOTDIR; + retval = 1; break; + } + } else { + retval = 1; break; + } + } + if (!last) *p = '/'; + } + if (!first && !last) (void)umask(oumask); + if (!retval){ + if (chmod(path, mode) == -1) retval = errno ; + } else { + retval = errno; + } + free(cpath); + return retval ; +} + +/* + * Copyright (c) 1999 Apple Computer, Inc. All rights reserved. + * + * @APPLE_LICENSE_HEADER_START@ + * + * "Portions Copyright (c) 1999 Apple Computer, Inc. All Rights + * Reserved. This file contains Original Code and/or Modifications of + * Original Code as defined in and that are subject to the Apple Public + * Source License Version 1.0 (the 'License'). You may not use this file + * except in compliance with the License. Please obtain a copy of the + * License at http://www.apple.com/publicsource and read it before using + * this file. + * + * The Original Code and all software distributed under the License are + * distributed on an 'AS IS' basis, WITHOUT WARRANTY OF ANY KIND, EITHER + * EXPRESS OR IMPLIED, AND APPLE HEREBY DISCLAIMS ALL SUCH WARRANTIES, + * INCLUDING WITHOUT LIMITATION, ANY WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE OR NON-INFRINGEMENT. Please see the + * License for the specific language governing rights and limitations + * under the License." + * + * @APPLE_LICENSE_HEADER_END@ + * + * Modified version: J. Burgalat (2015) + * + */ + +char* c_relpath(const char *path, const char *reldir) { + char start_path[MAXPATHLEN+1]; + char end_path[MAXPATHLEN+1]; + char *buf; + struct stat st; + int i,mc; + int last_elem; + int prev_path; + char *tmp,*cur; + buf = NULL; + + if (realpath(reldir,start_path) == NULL) + return buf; + + if (realpath(path,end_path) == NULL) + return buf; + + // stat the starting path + if (stat(start_path, &st) < 0) + return buf; + + if ((st.st_mode & S_IFMT) != S_IFDIR) { + errno = ENOTDIR; + return buf; + } + if (start_path[strlen(start_path) - 1] != '/') + strcat(start_path, "/"); + + // stat the ending path path + if (stat(end_path, &st) < 0) + return buf; + + if ((st.st_mode & S_IFMT) == S_IFDIR + && end_path[strlen(end_path) - 1] != '/') + strcat(end_path, "/"); + + tmp = (char *) malloc((2*MAXPATHLEN+1)*sizeof(char)); + memset(tmp,'\0',2*MAXPATHLEN+1); + cur = tmp; + /* strip common prefix */ + i = 0; + last_elem = 0; + while (start_path[i] && start_path[i] == end_path[i]) { + if (start_path[i] == '/') + last_elem = i + 1; + i += 1; + } + prev_path = 0; + for (i = last_elem; start_path[i]; i += 1) { + if (start_path[i] == '/') { + if (prev_path){ + *cur = '/'; cur++; + } + strncpy(cur,"..",2) ; cur +=2; + prev_path = 1; + } + } + if (end_path[last_elem]) { + if (prev_path) { + *cur = '/'; cur++; + } + prev_path = 1; + while (end_path[strlen(end_path) - 1] == '/') + end_path[strlen(end_path) - 1] = '\0'; + strcpy(cur,&end_path[last_elem]) ; + cur += strlen(&end_path[last_elem]); + } + if (! prev_path){ + *cur = '.' ; cur++ ; + } + // Normally here tmp contains our path. We just need to copy it in buf + mc = strlen(tmp)+1; + buf = (char *)malloc(mc*sizeof(char)); + memset(buf,'\0',mc); + strncpy(buf,tmp,strlen(tmp)); + cur = buf; + i=0; + while (*cur != '\0' && i < mc){ + cur++; + i++; + } + free(tmp); + errno = 0; + return buf; +} + +/* This verison of realpath was a dumb attempt to get a resolved path + * that may not exist. As a matter of fact, it cannot cover all range + * of possibilities. + * Thus it has been removed. The current verison of c_realpath simply + * uses POSIX realpath and returns CWD if no path is given... + */ + +/* Get the realpath of input path and saves it in output path */ +/* +char* c_realpath(const char *input){ + char *in,*output, *cur,*tmp,*res,*cwd ; + int c,om,rm,im; + output = NULL; + cwd = c_getcwd(); + if(!strlen(input)) + return cwd; + // check (ugly) if path is absolute + if (input[0] == '/') { + in = strdup(input); + }else{ + fprintf(stderr,"+++ C( in): %s\n",input); + in = malloc((strlen(input)+strlen(cwd)+2)*sizeof(char)); + strncpy(in, cwd, strlen(cwd)); + strncpy(&in[strlen(cwd)+1], input, strlen(input)); + in[strlen(cwd)] = '/'; + in[strlen(input)+strlen(cwd)+1] = '\0'; + } + fprintf(stderr,"C( in): %s\n",in); + c = om = im = strlen(in); + tmp = malloc((c+1)*sizeof(char)); + tmp[c] ='\0'; + // search for the deepest existing directory in "input" path + while(c != 0 && (res = realpath(tmp,NULL)) == NULL){ + // search for the next / from the right (i.e. parent directory) + for (cur=tmp+strlen(tmp) ; *cur != '/' && cur != tmp ; cur--, c--); + free(tmp) ; tmp = malloc((c+1)*sizeof(char)); + strncpy(tmp, in, c); tmp[c] ='\0'; + } + free(tmp); + // On error: null string + if (c == 0 || (res==NULL)) { + output = (char *)malloc(sizeof(char)); + output[0]='\0'; + return output; + } + // no error: allocate output string + rm = strlen(res); + om += rm-c; + output = (char *)malloc(om*sizeof(char)); + strncpy(output,res,rm); + // Here we could have a bug: + // If the path does not exist and contains .. or . references after the deepest + // existing directory, it will simply be appended ! + // Thus we can never resolve the path. + if (c != im) + strncpy(output+rm,in+c,im-c); + //strncpy(output+rm,in+c,im-c-1); + output[om] = '\0'; + fprintf(stderr,"C(tmp): %s\n",res); + fprintf(stderr,"C(out): %s\n",output); + free(res) ; + return output; +} +*/ Index: trunk/LMDZ.TITAN/libf/muphytitan/csystem.h =================================================================== --- trunk/LMDZ.TITAN/libf/muphytitan/csystem.h (revision 1793) +++ trunk/LMDZ.TITAN/libf/muphytitan/csystem.h (revision 1793) @@ -0,0 +1,256 @@ +/* Copyright Jérémie Burgalat (2010-2015) + * + * burgalat.jeremie@gmail.com + * + * This software is a computer program whose purpose is to provide configuration + * file and command line arguments parsing features to Fortran programs. + * + * This software is governed by the CeCILL-B license under French law and + * abiding by the rules of distribution of free software. You can use, + * modify and/ or redistribute the software under the terms of the CeCILL-B + * license as circulated by CEA, CNRS and INRIA at the following URL + * "http://www.cecill.info". + * + * As a counterpart to the access to the source code and rights to copy, + * modify and redistribute granted by the license, users are provided only + * with a limited warranty and the software's author, the holder of the + * economic rights, and the successive licensors have only limited + * liability. + * + * In this respect, the user's attention is drawn to the risks associated + * with loading, using, modifying and/or developing or reproducing the + * software by the user in light of its specific status of free software, + * that may mean that it is complicated to manipulate, and that also + * therefore means that it is reserved for developers and experienced + * professionals having in-depth computer knowledge. Users are therefore + * encouraged to load and test the software's suitability as regards their + * requirements in conditions enabling the security of their systems and/or + * data to be ensured and, more generally, to use and operate it in the + * same conditions as regards security. + * + * The fact that you are presently reading this means that you have had + * knowledge of the CeCILL-B license and that you accept its terms. + *//* csystem.h */ + + + +/* ------------------ WRAPPERS METHODS FOR FORTRAN BINDINGS ------------------ */ + +/** + * Gets the current umask (in decimal system) + * @return An int with the current umask set for the current session + */ +int c_umask(); + +/** + * Get directory name of input path + * @param[in] in A C string with the input path + * @return A pointer to a char array with the directory name of @bti{input} path. + * @note On error, a NULL pointer is returned. + * @warning In any case, the returned pointer must be freed in the Fortran counterpart + * (using fsystem::free_c). + */ +char * c_dirname(const char *in); + +/** + * Get base name of input path + * @param[in] in A C string with the input path + * @return A pointer to a char array with the base name of @bti{input} path. + * @note On error, a NULL pointer is returned. + * @warning In any case, the returned pointer must be freed in the Fortran counterpart + * (using fsystem::free_c). + */ +char* c_basename(const char *in); + +/** + * Get the current working directory. + * @return A pointer to a char array with the current workind directory. + * @note On error, a NULL pointer is returned. + * @warning In any case, the returned pointer must be freed in the Fortran counterpart + * (using fsystem::free_c). + */ +char* c_getcwd(); + + +/** + * Get the realpath of input path. + * @param[in] input A C string with the input path + * @return A pointer to a char array with the realpath of @bti{input} path. + * @note On error, a NULL pointer is returned. + * @warning In any case, the returned pointer must be freed in the Fortran counterpart + * (using fsystem::free_c). + */ +char* c_realpath(const char *input); + +/** + * Get the relative path of two file paths + * @details The method computes the relative path of can_fname to can_reldir if + * possible. + * @param path string with the path to compute in relative representation + * @param reldir a directory path from which output should be relative to + * @return A pointer to a char array with the relative path. + * @note On error, a NULL pointer is returned. + * @warning In any case, the returned pointer must be freed in the Fortran counterpart + * (using fsystem::free_c). + */ +char* c_relpath(const char *path, const char *reldir) ; + +/** + * Get the corresponding name of the given user id + * @param[in] uid An integer with a user id + * @return A pointer to a char array with the user name. + * @note On error, a NULL pointer is returned. + * @warning In any case, the returned pointer must be freed in the Fortran counterpart + * (using fsystem::free_c). + */ +char* c_uname(int uid); + +/** + * Get the corresponding name of the given group id + * @param[in] gid An integer with a group id + * @return A pointer to a char array with the group name. + * @note On error, a NULL pointer is returned. + * @warning In any case, the returned pointer must be freed in the Fortran counterpart + * (using fsystem::free_c). + */ +char* c_gname(int gid); + +/** + * Get last errno from C library + * @return An int with last errno saved in C library. + */ +int c_get_errno(); + +/** + * Get the error message of the given error id + * @param err An integer with the error id + * @return A pointer to a char array with the group name. + * @note On error, the hard-coded message "Unknown error" is returned. + * @warning In any case, the returned pointer must be freed in the Fortran counterpart + * (using fsystem::free_c). + */ +char* c_strerror(int err); + +/** + * Creates directories recursively + * @note The method is simple stripped copy of mkdir tool source code. + * @param[in] path A C string with the path of the directory to create + * @param[in] mode A mode_t structure with the permission of the directory + * @return An integer with 0 on success, last errno on failure + */ +int c_mkdirp(const char *path, mode_t mode); + +/** + * Rename a path + * @param old A string with the (valid) path to rename + * @param new A string with the new name of the path + * @return An integer with 0 on success, last errno on failure + */ +int c_rename(const char *old, const char *new); + +/** + * Change path permissions + * @param path A string with the path + * @param mode A integer with the new permissions to set + * @return An integer with 0 on success, last errno on failure + */ +int c_chmod(const char *path, mode_t mode); + +/** + * Change current working directory + * @param path A C string with the new path + * @return An integer with 0 on success, last errno on failure + */ +int c_chdir(const char *path); + +/** + * Create directory + * @param[in] path A C string with the path of the directory to create + * @param[in] mode A mode_t structure with the permission of the directory + * (as well as all the parent directorie created, if any). + * @return An integer with 0 on success, last errno on failure + */ +int c_mkdir(const char *path, mode_t mode); + +/** + * Remove file from filesytem + * @note Also works for directory (if empty) + * @param path A C string with the filepath to remove + * @return An integer with 0 on success, last errno on failure + */ +int c_remove(const char *path); + +/** + * Remove a directory + * @param path A C string with the path of the directory to remove. + * @return An integer with 0 on success, last errno on failure + */ +int c_rmdir(const char *path); + +/** + * Remove a directory and its contents recursively + * + * This method mimics 'rm -rf' command. + * @param path A C string with the path of the directory to remove. + * @return An integer with 0 on success, last errno on failure + */ +int c_rmdir_f(const char *path) ; + +/** + * Get some file informations + * @note If the path cannot be "stat", most of the output parameters are set + * to -1. + * @param[in] p A C string with the path of a file (or directory) + * @param[out] pe An int with the permissions of the path + * @param[out] nl An int with the inumber of links + * @param[out] ty An int with the type of the file : + * - 0 -> file + * - 1 -> link to a file + * - 2 -> directory + * - 3 -> link to a directory + * - 4 -> Other (fifo, socket, block special, char special ...) + * @param[out] ui An int with the user id of the path + * @param[out] gi An int with the group id of the path + * @param[out] si An int with the size of the path + * @param[out] a A C string (20 chars wide, including NULL character) with the + * last access date + * @param[out] m A C string (20 chars wide, including NULL character) with the + * last modification date + * @param[out] c A C string (20 chars wide, including NULL character) with the + * creation date + * @return An integer with 0 on success, last errno on failure + */ +int c_fstat(const char *p, int *pe, int *nl, int *ty, int *ui, int *gi, + long *si, char a[20], char m[20], char c[20]); + +/** + * Check if path is accessible + * @param[in] path A C string with the path to check + * @param[in] perm An integer with the user's permission to check : + * - 0 do not check for permissions + * - 1 check for execute permission + * - 2 check for write permission + * - 4 check for read permission + * @return An int with 0 on success, errno on failure + */ +int c_access(const char *path, int perm) ; + +/** + * Create a directory or a file in given path + * @param[in] path Path to be created + * @param[in] mode Permission of the path + * @param[in] astype A boolean with False to create a directory, True to create a file. + * @param[in] forced A boolean with True to force creation of intermediate directory + * @return 0 on success, -9 on allocation failure, last errno otherwise + */ +int c_create(const char* path, mode_t mode, int astype, int forced); + +/** + * Create a directory or a file in given path + * @param[out] rows Number of rows of the current terminal window + * @param[out] cols Number of columns of the current terminal window + * @return An int with 0 on success, errno on failure. On failure, rows is set + * to 80 and cols to 20. + */ +int c_termsize(int *rows,int *cols); + Index: trunk/LMDZ.TITAN/libf/muphytitan/datasets.F90 =================================================================== --- trunk/LMDZ.TITAN/libf/muphytitan/datasets.F90 (revision 1793) +++ trunk/LMDZ.TITAN/libf/muphytitan/datasets.F90 (revision 1793) @@ -0,0 +1,1262 @@ +! Copyright Université Reims Champagnne-Ardenne (2010-2015) +! contributor: Jérémie Burgalat +! +! jeremie.burgalat@univ-reims.fr +! +! This software is a computer program whose purpose is to compute multi-variate +! linear interpolation. +! +! This software is governed by the CeCILL-B license under French law and +! abiding by the rules of distribution of free software. You can use, +! modify and/ or redistribute the software under the terms of the CeCILL-B +! license as circulated by CEA, CNRS and INRIA at the following URL +! "http://www.cecill.info". +! +! As a counterpart to the access to the source code and rights to copy, +! modify and redistribute granted by the license, users are provided only +! with a limited warranty and the software's author, the holder of the +! economic rights, and the successive licensors have only limited +! liability. +! +! In this respect, the user's attention is drawn to the risks associated +! with loading, using, modifying and/or developing or reproducing the +! software by the user in light of its specific status of free software, +! that may mean that it is complicated to manipulate, and that also +! therefore means that it is reserved for developers and experienced +! professionals having in-depth computer knowledge. Users are therefore +! encouraged to load and test the software's suitability as regards their +! requirements in conditions enabling the security of their systems and/or +! data to be ensured and, more generally, to use and operate it in the +! same conditions as regards security. +! +! The fact that you are presently reading this means that you have had +! knowledge of the CeCILL-B license and that you accept its terms. + +!! file: datasets.F90 +!! summary: Dataset module definition file +!! author: J. Burgalat +!! date: 2014 + +#if HAVE_CONFIG_H +#include "config.h" +#endif + +MODULE DATASETS + !! dataset definitions module + !! + !! This module defines simple derived types that encapsulate data set variables. For a N-dimension + !! dataset, N vectors of \(n_{i}\) elements and a single N-dimensional array of + !! \(\prod_{i}^{N} n_{i}\) elements are defined. + !! + !! If the data set is to be used within [[lintdset(module)]] module then each coordinate values of the + !! dataset must be sorted either in ascending or descending order with no duplicates. The module does + !! not provide functionnality to sort and to check such requirements. + !! + !! The module also provides two interfaces to initialize data sets from input data file which can be + !! a NetCDF file (if NetCDF support is enabled at compilation time) or an ASCII file. In the latter + !! case, the file must contain a header which is formatted as follows: + !! + !! - The first line must contain only one value which is the number of coordinates (__N__) + !! - The second line must contain all the dimension sizes (that is __N__ values) + !! - Each other lines should contain __N+1__ columns with, for the __N__ first columns, the + !! coordinates values and finally the point value in the last column. + !! + !! @note + !! Note that for ASCII file, data must be ordered so first dimensions vary first. Same requirement + !! is needed for NetCDF file but in most cases, it is implicitly done (if dimensions are ordered). + USE LINT_PREC +#if HAVE_NC_FTN + USE NETCDF +#endif + IMPLICIT NONE + + PRIVATE + + PUBLIC :: read_dset, clear_dset, is_in, debug + + LOGICAL :: debug = .false. !! A control flag to enable verbose mode + +#if HAVE_NC_FTN + LOGICAL, PUBLIC, PARAMETER ::nc_supported = .true. !! NetCDF input files are supported +#else + LOGICAL, PUBLIC, PARAMETER ::nc_supported = .false. !! NetCDF input files are not supported +#endif + + !> Initialize a data set from either an ASCII or a NetCDF file + !! + !! Whatever the kind of file, this interface assumes that you know the dimensionnality of the + !! extracted variable. If file content is not compatible with the kind of data set given as + !! output argument, or if some I/O error occured, the dataset is cleared. + !! @note + !! Netcdf reader interface is available only if the library has been compiled with NetCDF support. + INTERFACE read_dset +#if HAVE_NC_FTN + MODULE PROCEDURE ncdf_rd_1d,ncdf_rd_2d,ncdf_rd_3d,ncdf_rd_4d,ncdf_rd_5d +#if HAVE_NC4_FTN + MODULE PROCEDURE ncdf4_rd_1d,ncdf4_rd_2d,ncdf4_rd_3d,ncdf4_rd_4d,ncdf4_rd_5d +#endif +#endif + MODULE PROCEDURE ascii_rd_1d,ascii_rd_2d,ascii_rd_3d,ascii_rd_4d,ascii_rd_5d + END INTERFACE + + !> Clear the given data set + INTERFACE clear_dset + MODULE PROCEDURE clr_1d_set,clr_2d_set,clr_3d_set,clr_4d_set,clr_5d_set + END INTERFACE + + !> Check if given point is within the data set + INTERFACE is_in + MODULE PROCEDURE is_in_1d,is_in_2d,is_in_3d,is_in_4d,is_in_5d + END INTERFACE + + !> Private interface to netcdf informations getters +#if HAVE_NC_FTN + INTERFACE get_nc_info + MODULE PROCEDURE get_nc3_info +#if HAVE_NC4_FTN + MODULE PROCEDURE get_nc4_info +#endif + END INTERFACE +#endif + + TYPE, PUBLIC :: DSET1D + !! A 1D data set + REAL(kind=wp), DIMENSION(:), ALLOCATABLE :: x !! X coordinate tabulated values + REAL(kind=wp), DIMENSION(:), ALLOCATABLE :: data !! Tabulated function's value at each coordinate + END TYPE DSET1D + + TYPE, PUBLIC :: DSET2D + !! A 2D data set + REAL(kind=wp), DIMENSION(:), ALLOCATABLE :: x !! X coordinate tabulated values + REAL(kind=wp), DIMENSION(:), ALLOCATABLE :: y !! Y coordinate tabulated values + REAL(kind=wp), DIMENSION(:,:), ALLOCATABLE :: data !! Tabulated function's value at each coordinate + END TYPE DSET2D + + TYPE, PUBLIC :: DSET3D + !! A 3D data set + REAL(kind=wp), DIMENSION(:), ALLOCATABLE :: x !! X coordinate tabulated values + REAL(kind=wp), DIMENSION(:), ALLOCATABLE :: y !! Y coordinate tabulated values + REAL(kind=wp), DIMENSION(:), ALLOCATABLE :: z !! Z coordinate tabulated values + REAL(kind=wp), DIMENSION(:,:,:), ALLOCATABLE :: data !! Tabulated function's value at each coordinate + END TYPE DSET3D + + TYPE, PUBLIC :: DSET4D + !! A 4D data set + REAL(kind=wp), DIMENSION(:), ALLOCATABLE :: x !! X coordinate tabulated values + REAL(kind=wp), DIMENSION(:), ALLOCATABLE :: y !! Y coordinate tabulated values + REAL(kind=wp), DIMENSION(:), ALLOCATABLE :: z !! Z coordinate tabulated values + REAL(kind=wp), DIMENSION(:), ALLOCATABLE :: t !! T coordinate tabulated values + REAL(kind=wp), DIMENSION(:,:,:,:), ALLOCATABLE :: data !! Tabulated function's value at each coordinate + END TYPE DSET4D + + TYPE, PUBLIC :: DSET5D + !! A 5D data set + REAL(kind=wp), DIMENSION(:), ALLOCATABLE :: x !! X coordinate tabulated values + REAL(kind=wp), DIMENSION(:), ALLOCATABLE :: y !! Y coordinate tabulated values + REAL(kind=wp), DIMENSION(:), ALLOCATABLE :: z !! Z coordinate tabulated values + REAL(kind=wp), DIMENSION(:), ALLOCATABLE :: t !! T coordinate tabulated values + REAL(kind=wp), DIMENSION(:), ALLOCATABLE :: w !! W coordinate tabulated values + REAL(kind=wp), DIMENSION(:,:,:,:,:), ALLOCATABLE :: data !! Tabulated function's value at each coordinate + END TYPE DSET5D + + CONTAINS + + + FUNCTION is_in_1d(set,x) RESULT(ret) + !! Check if point is in the 1D data set + TYPE(DSET1D), INTENT(in) :: set !! Dataset object to search in + REAL(kind=wp), INTENT(in) :: x !! coordinate of the point to check + LOGICAL :: ret !! .true. if the point is in the data set, .false. otherwise + REAL(kind=wp) :: l,u + ret=.true. + l = set%x(1) ; u= set%x(size(set%x)) + IF ((x>=l.EQV.x<=u).OR.(x<=l.EQV.x>=u)) ret=.false. + RETURN + END FUNCTION is_in_1d + + FUNCTION is_in_2d(set,x,y) RESULT(ret) + !! Check if point is in the 2D data set + TYPE(DSET2D), INTENT(in) :: set !! Dataset object to search in + REAL(kind=wp), INTENT(in) :: x !! X coordinate of the point to check + REAL(kind=wp), INTENT(in) :: y !! Y coordinate of the point to check + LOGICAL :: ret !! .true. if the point is in the data set, .false. otherwise + REAL(kind=wp) :: l,u + ret=.false. + l = set%x(1) ; u= set%x(size(set%x)) + IF ((x>l.AND.x>u).OR.(xl.AND.x>u).OR.(xl.AND.y>u).OR.(yl.AND.x>u).OR.(xl.AND.y>u).OR.(yl.AND.z>u).OR.(zl.AND.x>u).OR.(xl.AND.y>u).OR.(yl.AND.z>u).OR.(zl.AND.t>u).OR.(tl.AND.x>u).OR.(xl.AND.y>u).OR.(yl.AND.z>u).OR.(zl.AND.t>u).OR.(tl.AND.w>u).OR.(w ds(1)) cc(1)=1 + IF (mod(i,dp(2))==0) cc(2) = cc(2)+1 ; IF (cc(2) > ds(2)) cc(2)=1 + ENDDO + READ(666,*,iostat=e) vl(1) + IF (e == 0) THEN + IF (debug) WRITE(*,'(a)') 'ERROR: Extra value found' + ret = .false. ; call clear_dset(set) ; CLOSE(666) ; RETURN + ENDIF + ret = .true. + CLOSE(666) + RETURN + END FUNCTION ascii_rd_2d + + FUNCTION ascii_rd_3d(path,set) RESULT(ret) + !! Read a 3D data set from a ASCII file + CHARACTER(len=*), INTENT(in) :: path !! Path of the ASCII file to read + TYPE(dset3d), INTENT(out) :: set !! output 3D dataset + LOGICAL :: ret !! .true. if no error occured, .false. otherwise + INTEGER :: i,e + REAL(kind=wp), DIMENSION(4) :: vl + INTEGER, DIMENSION(3) :: cc,ds,dp + ret = .false. + CALL clear_dset(set) + IF (.NOT.ascii_header(path,ds,dp)) RETURN + ALLOCATE(set%x(ds(1)),set%y(ds(2)),set%z(ds(3)), & + set%data(ds(1),ds(2),ds(3))) + cc(:) = 1 + DO i=1,PRODUCT(ds) + READ(666,*,iostat=e) vl ! Reads the line + IF (e /= 0) THEN + IF (debug) WRITE(*,'(a)') 'ERROR: Malformed file, line: ',i+2 + ret = .false. ; call clear_dset(set) ; CLOSE(666) ; RETURN + ENDIF + ! --- X coordinate + set%x(cc(1)) = vl(1) + ! --- Y coordinate + set%y(cc(2)) = vl(2) + ! --- Z coordinate + set%z(cc(3)) = vl(3) + ! --- Data + set%data(cc(1),cc(2),cc(3)) = vl(4) + ! - Update counters + IF (mod(i,dp(1))==0) cc(1) = cc(1)+1 ; IF (cc(1) > ds(1)) cc(1)=1 + IF (mod(i,dp(2))==0) cc(2) = cc(2)+1 ; IF (cc(2) > ds(2)) cc(2)=1 + IF (mod(i,dp(3))==0) cc(3) = cc(3)+1 ; IF (cc(3) > ds(3)) cc(3)=1 + ENDDO + READ(666,*,iostat=e) vl(1) + IF (e == 0) THEN + IF (debug) WRITE(*,'(a)') 'ERROR: Extra value found' + ret = .false. ; call clear_dset(set) ; CLOSE(666) ; RETURN + ENDIF + ret = .true. + CLOSE(666) + RETURN + END FUNCTION ascii_rd_3d + + FUNCTION ascii_rd_4d(path,set) RESULT(ret) + !! Read a 4D data set from a ASCII file + CHARACTER(len=*), INTENT(in) :: path !! Path of the ASCII file to read + TYPE(dset4d), INTENT(out) :: set !! output 4D dataset + LOGICAL :: ret !! .true. if no error occured, .false. otherwise + INTEGER :: i,e + REAL(kind=wp), DIMENSION(5) :: vl + INTEGER, DIMENSION(4) :: cc,ds,dp + ret = .false. + CALL clear_dset(set) + IF (.NOT.ascii_header(path,ds,dp)) RETURN + ALLOCATE(set%x(ds(1)),set%y(ds(2)),set%z(ds(3)),set%t(ds(4)), & + set%data(ds(1),ds(2),ds(3),ds(4))) + cc(:) = 1 + DO i=1,PRODUCT(ds) + READ(666,*,iostat=e) vl ! Reads the line + IF (e /= 0) THEN + IF (debug) WRITE(*,'(a)') 'ERROR: Malformed file, line: ',i+2 + ret = .false. ; call clear_dset(set) ; CLOSE(666) ; RETURN + ENDIF + ! --- X coordinate + set%x(cc(1)) = vl(1) + ! --- Y coordinate + set%y(cc(2)) = vl(2) + ! --- Z coordinate + set%z(cc(3)) = vl(3) + ! --- T coordinate + set%t(cc(4)) = vl(4) + ! --- Data + set%data(cc(1),cc(2),cc(3),cc(4)) = vl(5) + ! - Update counters + IF (mod(i,dp(1))==0) cc(1) = cc(1)+1 ; IF (cc(1) > ds(1)) cc(1)=1 + IF (mod(i,dp(2))==0) cc(2) = cc(2)+1 ; IF (cc(2) > ds(2)) cc(2)=1 + IF (mod(i,dp(3))==0) cc(3) = cc(3)+1 ; IF (cc(3) > ds(3)) cc(3)=1 + IF (mod(i,dp(4))==0) cc(4) = cc(4)+1 ; IF (cc(4) > ds(4)) cc(4)=1 + ENDDO + READ(666,*,iostat=e) vl(1) + IF (e == 0) THEN + IF (debug) WRITE(*,'(a)') 'ERROR: Extra value found' + ret = .false. ; call clear_dset(set) ; CLOSE(666) ; RETURN + ENDIF + CLOSE(666) + ret = .true. + RETURN + END FUNCTION ascii_rd_4d + + FUNCTION ascii_rd_5d(path,set) RESULT(ret) + !! Read a 5D data set from a ASCII file + CHARACTER(len=*), INTENT(in) :: path !! Path of the ASCII file to read + TYPE(dset5d), INTENT(out) :: set !! output 5D dataset + LOGICAL :: ret !! .true. if no error occured, .false. otherwise + INTEGER :: i,e + REAL(kind=wp), DIMENSION(6) :: vl + INTEGER, DIMENSION(5) :: cc,ds,dp + ret = .false. + CALL clear_dset(set) + IF (.NOT.ascii_header(path,ds,dp)) RETURN + ALLOCATE(set%x(ds(1)),set%y(ds(2)),set%z(ds(3)),set%t(ds(4)),set%w(ds(5)), & + set%data(ds(1),ds(2),ds(3),ds(4),ds(5))) + cc(:) = 1 + DO i=1,PRODUCT(ds) + READ(666,*,iostat=e) vl ! Reads the line + IF (e /= 0) THEN + IF (debug) WRITE(*,'(a)') 'ERROR: Malformed file, line: ',i+2 + ret = .false. ; call clear_dset(set) ; CLOSE(666) ; RETURN + ENDIF + ! --- X coordinate + set%x(cc(1)) = vl(1) + ! --- Y coordinate + set%y(cc(2)) = vl(2) + ! --- Z coordinate + set%z(cc(3)) = vl(3) + ! --- T coordinate + set%t(cc(4)) = vl(4) + ! --- W coordinate + set%w(cc(5)) = vl(5) + ! --- Data + set%data(cc(1),cc(2),cc(3),cc(4),cc(5)) = vl(6) + ! - Update counters + IF (mod(i,dp(1)) == 0) cc(1)=cc(1)+1 ; IF (cc(1) > ds(1)) cc(1)=1 + IF (mod(i,dp(2)) == 0) cc(2)=cc(2)+1 ; IF (cc(2) > ds(2)) cc(2)=1 + IF (mod(i,dp(3)) == 0) cc(3)=cc(3)+1 ; IF (cc(3) > ds(3)) cc(3)=1 + IF (mod(i,dp(4)) == 0) cc(4)=cc(4)+1 ; IF (cc(4) > ds(4)) cc(4)=1 + IF (mod(i,dp(5)) == 0) cc(5)=cc(5)+1 ; IF (cc(5) > ds(5)) cc(5)=1 + ENDDO + READ(666,*,iostat=e) vl(1) + IF (e == 0) THEN + IF (debug) WRITE(*,'(a)') 'ERROR: Extra value found' + ret = .false. ; call clear_dset(set) ; CLOSE(666) ; RETURN + ENDIF + CLOSE(666) + ret = .true. + RETURN + END FUNCTION ascii_rd_5d + + SUBROUTINE clr_1d_set(set) + !! Clear the given 1D data set + TYPE(DSET1D), INTENT(inout) :: set !! dataset object to clear + IF (ALLOCATED(set%data)) DEALLOCATE(set%data) + IF (ALLOCATED(set%x)) DEALLOCATE(set%x) + RETURN + END SUBROUTINE clr_1d_set + + SUBROUTINE clr_2d_set(set) + !! Clear the given 2D data set + TYPE(DSET2D), INTENT(inout) :: set !! dataset object to clear + IF (ALLOCATED(set%data)) DEALLOCATE(set%data) + IF (ALLOCATED(set%x)) DEALLOCATE(set%x) + IF (ALLOCATED(set%y)) DEALLOCATE(set%y) + RETURN + END SUBROUTINE clr_2d_set + + SUBROUTINE clr_3d_set(set) + !! Clear the given 3D data set + TYPE(DSET3D), INTENT(inout) :: set !! dataset object to clear + IF (ALLOCATED(set%data)) DEALLOCATE(set%data) + IF (ALLOCATED(set%x)) DEALLOCATE(set%x) + IF (ALLOCATED(set%y)) DEALLOCATE(set%y) + IF (ALLOCATED(set%z)) DEALLOCATE(set%z) + RETURN + END SUBROUTINE clr_3d_set + + SUBROUTINE clr_4d_set(set) + !! Clear the given 4D data set + TYPE(DSET4D), INTENT(inout) :: set !! dataset object to clear + IF (ALLOCATED(set%data)) DEALLOCATE(set%data) + IF (ALLOCATED(set%x)) DEALLOCATE(set%x) + IF (ALLOCATED(set%y)) DEALLOCATE(set%y) + IF (ALLOCATED(set%z)) DEALLOCATE(set%z) + IF (ALLOCATED(set%t)) DEALLOCATE(set%t) + RETURN + END SUBROUTINE clr_4d_set + + SUBROUTINE clr_5d_set(set) + !! Clear the given 5D data set + TYPE(DSET5D), INTENT(inout) :: set !! dataset object to clear + IF (ALLOCATED(set%data)) DEALLOCATE(set%data) + IF (ALLOCATED(set%x)) DEALLOCATE(set%x) + IF (ALLOCATED(set%y)) DEALLOCATE(set%y) + IF (ALLOCATED(set%z)) DEALLOCATE(set%z) + IF (ALLOCATED(set%t)) DEALLOCATE(set%t) + IF (ALLOCATED(set%w)) DEALLOCATE(set%w) + RETURN + END SUBROUTINE clr_5d_set + +END MODULE DATASETS Index: trunk/LMDZ.TITAN/libf/muphytitan/defined.h =================================================================== --- trunk/LMDZ.TITAN/libf/muphytitan/defined.h (revision 1793) +++ trunk/LMDZ.TITAN/libf/muphytitan/defined.h (revision 1793) @@ -0,0 +1,84 @@ +/* Copyright Jérémie Burgalat (2010-2015) + * + * burgalat.jeremie@gmail.com + * + * This software is a computer program whose purpose is to provide configuration + * file and command line arguments parsing features to Fortran programs. + * + * This software is governed by the CeCILL-B license under French law and + * abiding by the rules of distribution of free software. You can use, + * modify and/ or redistribute the software under the terms of the CeCILL-B + * license as circulated by CEA, CNRS and INRIA at the following URL + * "http://www.cecill.info". + * + * As a counterpart to the access to the source code and rights to copy, + * modify and redistribute granted by the license, users are provided only + * with a limited warranty and the software's author, the holder of the + * economic rights, and the successive licensors have only limited + * liability. + * + * In this respect, the user's attention is drawn to the risks associated + * with loading, using, modifying and/or developing or reproducing the + * software by the user in light of its specific status of free software, + * that may mean that it is complicated to manipulate, and that also + * therefore means that it is reserved for developers and experienced + * professionals having in-depth computer knowledge. Users are therefore + * encouraged to load and test the software's suitability as regards their + * requirements in conditions enabling the security of their systems and/or + * data to be ensured and, more generally, to use and operate it in the + * same conditions as regards security. + * + * The fact that you are presently reading this means that you have had + * knowledge of the CeCILL-B license and that you accept its terms. + */ + + /** + * @file defined.h + * @brief CPP macro definitions files + * @details This header defines few CPP symbols and macros that are used + * in the library source code. + */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif + +/** @def ASSIGN_DTSTR(in,out) + * Performs string assignment + * + * This macro definition depends on compiler's support for allocatable string + * in derived type: + * - If it actually supports this feature, the macro defines an allocation + * statement. + * - Otherwise it defines a simple assignment statement. + */ +#if ! HAVE_FTNDTSTR +#define ASSIGN_DTSTR(in,out) out = in +#else +#define ASSIGN_DTSTR(in,out) ALLOCATE(out,source=in) +#endif + +/** @def OBJECT(name) + * Derived type declaration + * + * This macro definition depends on compiler's support for Bounded procedures + * in derived type (more precisely, Fortran 2003 PROCEDURE keyword support): + * - If it actually supports this feature, the macro defines derived type + * declaration as dummy argument of subroutine/function using CLASS keyword. + * - Otherwise, derived type dummy argument are declared using TYPE keyword. + */ +#if ! HAVE_FTNPROC +#define OBJECT(name) TYPE(name) +#else +#define OBJECT(name) CLASS(name) +#endif + +/* Defines SSLEN if needed */ +#ifndef SSLEN +#define SSLEN 200 +#endif + +/* Defines SLLEN if needed */ +#ifndef SLLEN +#define SLLEN 2000 +#endif Index: trunk/LMDZ.TITAN/libf/muphytitan/errors.F90 =================================================================== --- trunk/LMDZ.TITAN/libf/muphytitan/errors.F90 (revision 1793) +++ trunk/LMDZ.TITAN/libf/muphytitan/errors.F90 (revision 1793) @@ -0,0 +1,297 @@ +! Copyright Jérémie Burgalat (2010-2015) +! +! burgalat.jeremie@gmail.com +! +! This software is a computer program whose purpose is to provide configuration +! file and command line arguments parsing features to Fortran programs. +! +! This software is governed by the CeCILL-B license under French law and +! abiding by the rules of distribution of free software. You can use, +! modify and/ or redistribute the software under the terms of the CeCILL-B +! license as circulated by CEA, CNRS and INRIA at the following URL +! "http://www.cecill.info". +! +! As a counterpart to the access to the source code and rights to copy, +! modify and redistribute granted by the license, users are provided only +! with a limited warranty and the software's author, the holder of the +! economic rights, and the successive licensors have only limited +! liability. +! +! In this respect, the user's attention is drawn to the risks associated +! with loading, using, modifying and/or developing or reproducing the +! software by the user in light of its specific status of free software, +! that may mean that it is complicated to manipulate, and that also +! therefore means that it is reserved for developers and experienced +! professionals having in-depth computer knowledge. Users are therefore +! encouraged to load and test the software's suitability as regards their +! requirements in conditions enabling the security of their systems and/or +! data to be ensured and, more generally, to use and operate it in the +! same conditions as regards security. +! +! The fact that you are presently reading this means that you have had +! knowledge of the CeCILL-B license and that you accept its terms. + +!! file: errors.F90 +!! summary: Errors handling source file +!! author: Burgalat +!! date: 2013-2015 + +#include "defined.h" + +MODULE ERRORS + !! Error handler module + !! + !! This module provides a single derived type, [[error(type)]] which is used in all + !! other parts of the library in order to handle errors. + USE, INTRINSIC :: ISO_C_BINDING + USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY : stdout=>OUTPUT_UNIT, stderr=>ERROR_UNIT + + IMPLICIT NONE + + PUBLIC + + PRIVATE :: error_equals,error_equals_int,error_differs,error_differs_int, & + msg_length + + + INTEGER, PARAMETER :: msg_length = 250 !! Length of error message. + + TYPE, PUBLIC :: error + !! Define an error + !! + !! The following derived type represents in the simplest way (I believe) an error which + !! stores: + !! + !! - An integer to numerically identify the error + !! - A string (250 chars max) with an appropriate error message + !! - A bounded procedure to get a string representation of the error (if bounded + !! procedures are supported by the library). + !! - internal subroutines for derived type IO WRITE statement (if Derived IO + !! subroutines are supported by the library). + !! + !! error type comes also with two operators ("==", "/=") to compare error type with + !! another one or an integer. + !! If an error is not initialized explicitly, then it is set to [[errors(module):noerror(variable)]]. + CHARACTER(len=msg_length) :: msg = "No error" + !! Message associated to the error + !! @note + !! The message should be short (250 characters maximum) and explicit. + INTEGER :: id = 0 + !! Numerical identifier of the error + !! @note + !! The error identifier is used to test the equality/inequality of two error objects. +#if HAVE_FTNPROC + CONTAINS + PROCEDURE, PUBLIC :: to_string => error_to_string + !! Get a string representation of the error +!#if HAVE_FTNDTIO +! PROCEDURE, PRIVATE :: e_write_wfm +! PROCEDURE, PRIVATE :: e_write_wofm +! GENERIC, PUBLIC :: write(formatted) => e_write_wfm +! !! Generic formatted write statement subroutine interface +! GENERIC, PUBLIC :: write(unformatted) => e_write_wofm +! !! Generic unformatted write statement subroutine interface +!#endif +#endif + END TYPE error + + INTERFACE + !! Clean subroutine interface + SUBROUTINE clean_callback(err) + !! A subroutine that may perform cleaning computation(s) before exit + IMPORT error + IMPLICIT NONE + TYPE(error), INTENT(in) :: err + !! An error object with the input error + END SUBROUTINE clean_callback + END INTERFACE + + INTERFACE + subroutine abort_() bind(C, name="abort") + end subroutine + END INTERFACE + + INTERFACE assert + !! _Raise_ an assertion. + !! + !! An assertion can be understood as a development error that should be raised in production mode. + MODULE PROCEDURE :: assert_r,assert_w + END INTERFACE assert + + !> error equality operator + INTERFACE OPERATOR(==) + MODULE PROCEDURE error_equals, error_equals_int + END INTERFACE + + !> error inequality operator + INTERFACE OPERATOR(/=) + MODULE PROCEDURE error_differs, error_differs_int + END INTERFACE + + !> The no error error ! + TYPE(error), PUBLIC, PARAMETER :: noerror = error("No error",0) + + CONTAINS + +!=============================================================================== +! error TYPE RELATED METHODS +!=============================================================================== + + FUNCTION error_equals(this, other) RESULT(res) + !! Check if two error objects are equivalent + TYPE(error), INTENT(in) :: this, & !! The first error object to compare + other !! The second error object to compare + LOGICAL :: res !! .true. if __this__ and __other__ identifiers are the same, .false. otherwise + res = (this%id == other%id) + RETURN + END FUNCTION error_equals + + FUNCTION error_equals_int(this, id) RESULT(res) + !! Check if an error id is equal to a given integer + TYPE(error), INTENT(in) :: this !! An error object reference + INTEGER, INTENT(in) :: id !! An integer to compare to __this__ identifier + LOGICAL :: res !! .true. if __this__ identifier and __id__ have the same value, .false. otherwise + res = (this%id == id) + RETURN + END FUNCTION error_equals_int + + FUNCTION error_differs(this, other) RESULT(res) + !! Check if two error objects are different + TYPE(error), INTENT(in) :: this, & !! The first error object to compare + other !! The second error object to compare + LOGICAL :: res !! .false. if __this__ and __other__ identifiers are the same, .true. otherwise + res = (this%id /= other%id) + RETURN + END FUNCTION error_differs + + FUNCTION error_differs_int(this, id) RESULT(res) + !! Check if an error id is different from a given integer + TYPE(error), INTENT(in) :: this !! An error object reference + INTEGER, INTENT(in) :: id !! An integer to compare to __this__ identifier + LOGICAL :: res !! .false. if __this__ identifier and __id__ have the same value, .true. otherwise + res = (this%id /= id) + RETURN + END FUNCTION error_differs_int + + FUNCTION error_to_string(this,progname,as_warning) RESULT(str) + !! (simple) String representation of the error + !! + !! The function returns a very simple formatted string with the error. + OBJECT(error), INTENT(in) :: this + !! An error object reference + CHARACTER(len=*), INTENT(in), OPTIONAL :: progname + !! An optional string with the name of the program + LOGICAL, INTENT(in), OPTIONAL :: as_warning + !! An optional boolean flag to print the message as warning rather than as error (default to .false.). + CHARACTER(len=:), ALLOCATABLE :: str + !! An allocatable string with the string representation of the error + CHARACTER(len=:), ALLOCATABLE :: pref + pref = "error: " + IF (PRESENT(as_warning)) THEN ; IF (as_warning) pref = "warning: " ; ENDIF + IF (PRESENT(progname)) THEN + IF (LEN_TRIM(progname) /=0) THEN + str = TRIM(progname)//': '//pref//TRIM(this%msg) + ELSE + str = pref//TRIM(this%msg) + ENDIF + ELSE + str = pref//TRIM(this%msg) + ENDIF + RETURN + END FUNCTION error_to_string + +!#if HAVE_FTNDTIO +! SUBROUTINE e_write_wfm(dtv,unit,iotype,v_list,iostat,iomsg) +! !> Error derived type formatted IO write statement subroutine +! !! +! !! The method quietly ignores the derived type edit descriptor as the +! !! purpose of the subroutine is only to print a string. The edit descriptor +! !! used here is simply '(a)'. +! CLASS(error), INTENT(in) :: dtv +! !! A reference to the string object +! INTEGER, INTENT(in) :: unit +! !! Logical unit where to print the object +! CHARACTER (len=*), INTENT(in) :: iotype +! !! Type of IO +! INTEGER, INTENT(in) :: v_list(:) +! !! List of value from edit descriptor +! INTEGER, INTENT(out) :: iostat +! !! Error status code (set to 2 if dtv's value if not allocated) +! CHARACTER (len=*), INTENT(inout) :: iomsg +! !! Error message +! CHARACTER(len=15) :: i2s +! iostat = 0 ; iomsg = "" +! WRITE(i2s,'(I15)') dtv%id ; i2s=ADJUSTL(i2s) +! WRITE(unit, '(a)') 'error('//TRIM(i2s)//'): '//TRIM(dtv%msg) +! END SUBROUTINE e_write_wfm +! +! SUBROUTINE e_write_wofm(dtv, unit, iostat, iomsg) +! !! Error type IO unformatted write statement subroutine +! CLASS(error), INTENT(in) :: dtv +! !! A reference to the string object +! INTEGER, INTENT(in) :: unit +! !! Logical unit where to print the object +! INTEGER, INTENT(out) :: iostat +! !! Error status code (set to 2 if dtv's value if not allocated) +! CHARACTER (len=*), INTENT(inout) :: iomsg +! !! Error message +! CHARACTER(len=15) :: i2s +! iostat = 0 ; iomsg = "" +! WRITE(i2s,'(I15)') dtv%id ; i2s=ADJUSTL(i2s) +! WRITE(unit, '(a)') 'error('//TRIM(i2s)//'): '//TRIM(dtv%msg) +! END SUBROUTINE e_write_wofm +!#endif + + SUBROUTINE aborting(err) + !! Abort the program with specific exit code + !! + !! The method prints the message of the given error object and + !! stops the program using exit() subroutine. + TYPE(error), INTENT(in) :: err + !! An error object + IF (err /= 0) THEN + WRITE(*,'(a)') error_to_string(err) + CALL EXIT(err%id) + ENDIF + END SUBROUTINE aborting + + SUBROUTINE assert_r(test,reason) + !! _Raise_ an assertion. + !! + !! The method raises an assertion and stops the execution if __test__ is .false. + !! + !! @note + !! If ISO_C_BINDING module is available, the method calls the method abort from the C standard library. Doing so, + !! developer is able to debug the source code by getting the backtrace of the execution. + !! In other situation, the method simply uses the Fortran STOP statement which makes its usage... useless. + LOGICAL, INTENT(in) :: test + !! Expression to test. + CHARACTER(len=*), INTENT(in) :: reason + !! Optional assertion reason. + IF (.NOT.test) THEN + WRITE(stderr,'(a)') "assertion: "//reason + call abort_() + ENDIF + END SUBROUTINE assert_r + + SUBROUTINE assert_w(test,where,reason) + !! _Raise_ an assertion. + !! + !! The method raises an assertion and stops the execution if __test__ is .false. + !! + !! See [[errors(module):assert_r(subroutine)] remark. + LOGICAL, INTENT(in) :: test + !! Expression to test. + CHARACTER(len=*), INTENT(in) :: where + !! Optional _location_ of the assertion. + CHARACTER(len=*), INTENT(in) :: reason + !! Optional assertion reason. + IF (.NOT.test) THEN + WRITE(stderr,'(a)') "assertion in "//where//": "//reason + call abort_() + ENDIF + END SUBROUTINE assert_w + + +END MODULE ERRORS + Index: trunk/LMDZ.TITAN/libf/muphytitan/fsystem.F90 =================================================================== --- trunk/LMDZ.TITAN/libf/muphytitan/fsystem.F90 (revision 1793) +++ trunk/LMDZ.TITAN/libf/muphytitan/fsystem.F90 (revision 1793) @@ -0,0 +1,1034 @@ +! Copyright Jérémie Burgalat (2010-2015) +! +! burgalat.jeremie@gmail.com +! +! This software is a computer program whose purpose is to provide configuration +! file and command line arguments parsing features to Fortran programs. +! +! This software is governed by the CeCILL-B license under French law and +! abiding by the rules of distribution of free software. You can use, +! modify and/ or redistribute the software under the terms of the CeCILL-B +! license as circulated by CEA, CNRS and INRIA at the following URL +! "http://www.cecill.info". +! +! As a counterpart to the access to the source code and rights to copy, +! modify and redistribute granted by the license, users are provided only +! with a limited warranty and the software's author, the holder of the +! economic rights, and the successive licensors have only limited +! liability. +! +! In this respect, the user's attention is drawn to the risks associated +! with loading, using, modifying and/or developing or reproducing the +! software by the user in light of its specific status of free software, +! that may mean that it is complicated to manipulate, and that also +! therefore means that it is reserved for developers and experienced +! professionals having in-depth computer knowledge. Users are therefore +! encouraged to load and test the software's suitability as regards their +! requirements in conditions enabling the security of their systems and/or +! data to be ensured and, more generally, to use and operate it in the +! same conditions as regards security. +! +! The fact that you are presently reading this means that you have had +! knowledge of the CeCILL-B license and that you accept its terms. + +!! file: fsystem.F90 +!! summary: File system methods source file +!! date: 2013-2015 +!! author: Burgalat + +#include "defined.h" + +MODULE FSYSTEM + !! File system methods module + USE, INTRINSIC :: ISO_C_BINDING + USE ERRORS + IMPLICIT NONE + + PUBLIC + + PRIVATE :: get_umask + + INTEGER, PARAMETER :: MAX_PATH = 512 !! Maximum length of a path + + + INTERFACE + + FUNCTION strlen_c(s) RESULT(length) bind(C,name="strlen") + !! Get length of C-string up to (but not including) the terminator + IMPORT C_PTR, C_SIZE_T + TYPE(C_PTR), INTENT(in), VALUE :: s !! C string (a C_PTR type) + INTEGER(kind=C_SIZE_T) :: length !! An integer with the size of the string. + END FUNCTION strlen_c + + SUBROUTINE free_c(ptr) bind(C,name="free") + !! Free memory used by a C pointer + IMPORT C_PTR + TYPE(C_PTR), INTENT(in), VALUE :: ptr !! TYPE(C_PTR) object with the underlying C pointer to free + END SUBROUTINE free_c + + FUNCTION errno_c() BIND(C,name="c_get_errno") + !! Get last error numbero + IMPORT C_INT + INTEGER(kind=C_INT) :: errno_c !! Last errno + END FUNCTION errno_c + + FUNCTION usleep_c(usec) BIND(C,name="usleep") + !! (attemps to) Sleep for a given number of microseconds + IMPORT C_INT + INTEGER(kind=C_INT), INTENT(in), VALUE :: usec !! Number of microseconds to sleep + INTEGER(kind=C_INT) :: usleep_c !! An integer with 0 on success, last errno otherwise + END FUNCTION usleep_c + + FUNCTION getgid_c() BIND(C, name="getgid") + !! Get Group ID + IMPORT C_INT + INTEGER(kind=C_INT) :: getgid_c !! Group identifier + END FUNCTION getgid_c + + FUNCTION getpid_c() BIND(C, name="getpid") + !! Get Process ID + IMPORT C_INT + INTEGER(kind=C_INT) :: getpid_c !! Current process identifier + END FUNCTION getpid_c + + FUNCTION getuid_c() BIND(C, name="getuid") + !! Get User ID + IMPORT C_INT + INTEGER(kind=C_INT) :: getuid_c !! User identifier + END FUNCTION getuid_c + + FUNCTION umask_c() BIND(C,name="c_umask") + !! Get the current umask of the session + IMPORT C_INT + INTEGER(kind=C_INT) :: umask_c !! Current umask value in decimal system + END FUNCTION umask_c + + FUNCTION access_c(path,perm) BIND(C,name="c_access") + !! Check if path is accessible for current user + IMPORT c_char, C_INT + CHARACTER(len=c_char), INTENT(in) :: path(*) !! Path to check + INTEGER(kind=C_INT), INTENT(in), VALUE :: perm !! User's permission to check + INTEGER(kind=C_INT) :: access_c !! 0 on success, last errno on failure + END FUNCTION access_c + + FUNCTION create_c(path,mode,asfile,forced) BIND(C,name="c_create") + !! Create a directory or a file in given path + IMPORT c_char, C_INT + CHARACTER(len=c_char), INTENT(in) :: path(*) !! Path to create + INTEGER(kind=C_INT), INTENT(in), VALUE :: mode, & !! Decimal permission of the path + asfile, & !! 0 to create a directory, any other value to create file + forced !! non-zero value to force the creation of intermediate directories + INTEGER(kind=C_INT) :: create_c !! 0 on success, last errno otherwise + END FUNCTION create_c + + FUNCTION uname_c(uid) BIND(C, name="c_uname") + !! Get the name of the given user id + IMPORT C_INT, c_ptr + INTEGER(kind=C_INT), INTENT(in), VALUE :: uid !! User id + TYPE(C_PTR) :: uname_c !! C_PTR to the underlying char* pointer storing user name + END FUNCTION uname_c + + FUNCTION gname_c(gid) BIND(C, name="c_gname") + !! Get the name of the given group id + IMPORT C_INT, c_ptr + INTEGER(kind=C_INT), INTENT(in), VALUE :: gid !! Group id + TYPE(C_PTR) :: gname_c !! C_PTR to the underlying char* pointer storing group name + END FUNCTION gname_c + + FUNCTION dirname_c(path) BIND(C,name="c_dirname") + !! Get the directory name of the path + IMPORT c_char, c_ptr + CHARACTER(kind=c_char), INTENT(in) :: path(*) !! Input path + TYPE(C_PTR) :: dirname_c !! C_PTR to the underlying char* pointer storing dirname + END FUNCTION dirname_c + + FUNCTION basename_c(path) BIND(C,name="c_basename") + !! Get the basename of the path + IMPORT c_char, c_ptr + CHARACTER(kind=c_char), INTENT(in) :: path(*) !! Input path + TYPE(C_PTR) :: basename_c !! C_PTR to the underlying char* pointer sotring basename + END FUNCTION basename_c + + FUNCTION getcwd_c() BIND(C,name="c_getcwd") + !! Get the current working directory + IMPORT c_ptr + TYPE(C_PTR) :: getcwd_c !! C_PTR to the underlying char* pointer storing current working directory + END FUNCTION getcwd_c + + FUNCTION realpath_c(path) BIND(C, name="c_realpath") + !! Get the real path from given path + IMPORT c_char, c_ptr + CHARACTER(kind=c_char), INTENT(in) :: path(*) !! The path to expand + TYPE(C_PTR) :: realpath_c !! C_PTR to the underlying char* pointer storing realpath + END FUNCTION realpath_c + + FUNCTION relpath_c(fname,reldir) BIND(C, name="c_relpath") + !! Get the relative path of path from another + IMPORT c_char, c_ptr + CHARACTER(kind=c_char), INTENT(in) :: fname(*), & !! Path to process + reldir(*) !! New base path + TYPE(C_PTR) :: relpath_c !! C_PTR to the underlying char* pointer storing relative path + END FUNCTION + + FUNCTION rename_c(input,output) BIND(C,name="c_rename") + !! Rename a path + IMPORT c_char, C_INT + CHARACTER(kind=c_char), INTENT(in) :: input(*) !! Path to rename + CHARACTER(kind=c_char), INTENT(in) :: output(*) !! New name of the path + INTEGER(kind=C_INT) :: rename_c !! 0 on success, last errno on failure + END FUNCTION rename_c + + FUNCTION chmod_c(path,mode) BIND(C,name="c_chmod") + !! Change file/directory permissions + IMPORT c_char, C_INT + CHARACTER(kind=c_char), INTENT(in) :: path(*) !! Path to modify + INTEGER(kind=C_INT), INTENT(in), VALUE :: mode !! New decimal permissions of the path to set + INTEGER(kind=C_INT) :: chmod_c !! 0 on success, last errno on failure + END FUNCTION chmod_c + + FUNCTION chdir_c(new) BIND(C,name="c_chdir") + !! Change current directory + IMPORT c_char, C_INT + CHARACTER(kind=c_char), INTENT(in) :: new(*) !! Path of the new working directory + INTEGER(kind=C_INT) :: chdir_c !! 0 on success, last errno on failure + END FUNCTION chdir_c + + FUNCTION mkdir_c(dirname,mode) BIND(C,name="c_mkdir") + !! Create directory + IMPORT c_char, C_INT + CHARACTER(kind=c_char), INTENT(in) :: dirname(*) !! Path of the directory to create + INTEGER(kind=C_INT), INTENT(in), VALUE :: mode !! Decimal permission to set + INTEGER(kind=C_INT) :: mkdir_c !! 0 on success, last errno on failure + END FUNCTION mkdir_c + + FUNCTION mkdirp_c(dirname,mode) BIND(C,name="c_mkdirp") + !! Create directory recursively + IMPORT c_char, C_INT + CHARACTER(kind=c_char), INTENT(in) :: dirname(*) !! Path of the directory to create + INTEGER(kind=C_INT), INTENT(in), VALUE :: mode !! Decimal permission to set + INTEGER(kind=C_INT) :: mkdirp_c !! 0 on success, last errno on failure + END FUNCTION mkdirp_c + + FUNCTION remove_c(path) BIND(C,name="c_remove") + !! Remove a file (or a directory) from the filesystem + IMPORT c_char, C_INT + CHARACTER(kind=c_char), INTENT(in) :: path(*) !! Path to delete + INTEGER(kind=C_INT) :: remove_c !! 0 on success, last errno on failure + END FUNCTION remove_c + + FUNCTION rmdir_c(dirpath) BIND(C,name="c_rmdir") + !! Remove empty directory + IMPORT c_char, C_INT + CHARACTER(kind=c_char), INTENT(in) :: dirpath(*) !! Directory to delete + INTEGER(kind=C_INT) :: rmdir_c !! 0 on success, last errno on failure + END FUNCTION rmdir_c + + FUNCTION rmdirf_c(dirpath) BIND(C,name="c_rmdir_f") + !! Remove directory (forced) + IMPORT c_char, C_INT + CHARACTER(kind=c_char), INTENT(in) :: dirpath(*) !! Directory to delete + INTEGER(kind=C_INT) :: rmdirf_c !! 0 on success, last errno on failure + END FUNCTION rmdirf_c + + FUNCTION fstat_c(pa, pe, ln, ty, ui, gi, si, at, mt, ct) BIND(C, name='c_fstat') + !! Get file informations + IMPORT c_char, c_long, C_INT + CHARACTER(kind=c_char), INTENT(in) :: pa(*) !! Path of the file + INTEGER(kind=C_INT), INTENT(out) :: pe !! Decimal permission of the path + INTEGER(kind=C_INT), INTENT(out) :: ln !! Number of links + INTEGER(kind=C_INT), INTENT(out) :: ty !! Type of the path + INTEGER(kind=C_INT), INTENT(out) :: ui !! User ID of the path + INTEGER(kind=C_INT), INTENT(out) :: gi !! Group ID of the path + INTEGER(kind=c_long), INTENT(out) :: si !! Size of the path + CHARACTER(kind=c_char), INTENT(out) :: at(20) !! Last access date + CHARACTER(kind=c_char), INTENT(out) :: mt(20) !! Last modification date + CHARACTER(kind=c_char), INTENT(out) :: ct(20) !! Creation date + INTEGER(kind=C_INT) :: fstat_c !! 0 on success, last errno on failure + END FUNCTION fstat_c + + FUNCTION termsize_c(r,c) BIND(C, name='c_termsize') + !! Get terminal window size + IMPORT C_INT + INTEGER(kind=C_INT), INTENT(out) :: r, & !! Number of rows + c !! Number of columns + INTEGER(kind=C_INT) :: termsize_c !! 0 on success, last errno on failure + END FUNCTION termsize_c + + END INTERFACE + + + CONTAINS + + FUNCTION fstring(string) RESULT(str) + !! Convert C string to Fortran string + !! + !! The method copies the input C string up to the last C_NULL_CHAR found (not including it), + !! and returns the converted Fortran string. + !! All other C_NULL_CHAR found in the C string are removed. + CHARACTER(len=*), INTENT(in) :: string !! A string from C + CHARACTER(len=:), ALLOCATABLE :: str !! Converted fortran string + INTEGER :: i,idx + str = "" + idx = INDEX(string,C_NULL_CHAR,.true.) + IF (idx == 0) THEN + str = string + ELSE + DO i=1,idx-1 + IF (string(i:i) /= C_NULL_CHAR) str = str//string(i:i) + ENDDO + ENDIF + str = TRIM(str) + END FUNCTION fstring + + FUNCTION cstr2fstr(cstr) RESULT(fstr) + !! Get a Fortran (allocatable) string from a C string + !! + !! The method build the fortran string from a TYPE(C_PTR) object that represent a + !! C char\* pointer string. + !! @note + !! If __cstr__ is not allocated (i.e. the C_PTR is not associated) or if it is set + !! to a C empty string (i.e. '\0') then the method returns an empty string. + !! @attention + !! The method does not free the underlying C string and it should be free using + !! [[fsystem(module):free_c(interface)]] method. + TYPE(C_PTR), INTENT(in) :: cstr + !! A TYPE(C_PTR) that represent the pointer to the C char array. + CHARACTER(len=:), ALLOCATABLE :: fstr + !! An allocatable Fortran string with the content of the input char array. + CHARACTER(len=1,kind=C_CHAR), DIMENSION(:), POINTER :: pchars + INTEGER :: i,length + IF (.NOT.C_ASSOCIATED(cstr)) THEN + fstr = "" + RETURN + ENDIF + length = INT(strlen_c(cstr), kind=4) + IF (length ==0) THEN + fstr = "" + RETURN + ENDIF + CALL C_F_POINTER(cstr,pchars,(/length/)) + ALLOCATE(CHARACTER(len=length) :: fstr) + DO i=1,length + fstr(i:i) = pchars(i) + ENDDO + END FUNCTION cstr2fstr + + + FUNCTION cstring(string) RESULT(str) + !> convert Fortran string to cstring + !! + !! The method returns a copy of the input string suitable for C functions argument. + !! @note + !! Input string is trimmed during computations + CHARACTER(len=*), INTENT(in) :: string + !! A fortran string + CHARACTER(len=:,kind=C_CHAR), ALLOCATABLE :: str + !! Same string as __string__ except that C_NULL_CHAR is appended at the end + INTEGER :: slen + slen = LEN_TRIM(string) + ALLOCATE(CHARACTER(len=slen+1,kind=C_CHAR) :: str) + str(:slen) = TRIM(string) ; str(slen+1:slen+1) = C_NULL_CHAR + END FUNCTION cstring + +!=============================================================================== +! C WRAPPER FUNCTIONS/SUBROUTINES +!=============================================================================== + + FUNCTION fs_getgid() RESULT(ret) + !! Get Group ID + INTEGER(kind=4) :: ret !! An integer with the group identifier + ret = INT(getgid_c(),kind=4) + RETURN + END FUNCTION fs_getgid + + FUNCTION fs_getpid() RESULT(ret) + !! Get Process ID + INTEGER(kind=4) :: ret !! An integer with the current process identifier + ret = INT(getpid_c(),kind=4) + RETURN + END FUNCTION fs_getpid + + FUNCTION fs_getuid() RESULT(ret) + !! Get User ID + INTEGER(kind=4) :: ret !! An integer with the user identifier + ret = INT(getuid_c(),kind=4) + RETURN + END FUNCTION fs_getuid + + FUNCTION fs_gname(gid) RESULT(gname) + !! Get a group name from a group id + INTEGER, INTENT(in) :: gid !! User id to check + CHARACTER(len=:), ALLOCATABLE :: gname !! A string with the name of the group id + TYPE(C_PTR) :: zname + zname = gname_c(gid) + IF (.NOT.C_ASSOCIATED(zname)) THEN + gname = "" + ELSE + gname = cstr2fstr(zname) + ENDIF + CALL free_c(zname) + END FUNCTION fs_gname + + FUNCTION fs_uname(uid) RESULT(uname) + !! Get a user name from a user id + INTEGER, INTENT(in) :: uid !! User id to check + CHARACTER(len=:), ALLOCATABLE :: uname !! A string with the name of the user id + TYPE(C_PTR) :: zname + zname = gname_c(uid) + IF (.NOT.C_ASSOCIATED(zname)) THEN + uname = "" + ELSE + uname = cstr2fstr(zname) + ENDIF + CALL free_c(zname) + END FUNCTION fs_uname + + FUNCTION fs_dirname(path) RESULT(opath) + !! Get the parent directory path of the given path + CHARACTER(len=*), INTENT(in) :: path + !! A string with a (valid) path + CHARACTER(len=:), ALLOCATABLE :: opath + !! A Fortran allocated string with the parent directory path or an empty string if method fails + TYPE(C_PTR) :: zpath + IF (LEN_TRIM(path) == 0) THEN + opath = "" + RETURN + ENDIF + zpath = dirname_c(cstring(ADJUSTL(path))) + IF (.NOT.C_ASSOCIATED(zpath)) THEN + opath = "" + ELSE + opath = cstr2fstr(zpath) + ENDIF + CALL free_c(zpath) + END FUNCTION fs_dirname + + FUNCTION fs_basename(path) RESULT(opath) + !! Get the base name of the path + CHARACTER(len=*), INTENT(in) :: path + !! A string with a (valid) path + CHARACTER(len=:), ALLOCATABLE :: opath + !! The basename of the path or an empty string if method fails + TYPE(C_PTR) :: zpath + IF (LEN_TRIM(path) == 0) THEN + opath = "" + RETURN + ENDIF + zpath = basename_c(cstring(ADJUSTL(path))) + IF (.NOT.C_ASSOCIATED(zpath)) THEN + opath = "" + ELSE + opath = cstr2fstr(zpath) + ENDIF + CALL free_c(zpath) + END FUNCTION fs_basename + + FUNCTION fs_realpath(path) RESULT(opath) + !! Get the real path of the path + !! + !! The method computes the absolute path of the given path using C realpath function. + !! @note + !! If the input path is empty then current working directory is returned. + CHARACTER(len=*), INTENT(in) :: path + !! A string with a (valid) path + CHARACTER(len=:), ALLOCATABLE :: opath + !! The absolute of the path or an empty string if method fails + TYPE(C_PTR) :: zpath + zpath = realpath_c(cstring(ADJUSTL(path))) + IF (.NOT.C_ASSOCIATED(zpath)) THEN + opath = "" + ELSE + opath = cstr2fstr(zpath) + ENDIF + CALL free_c(zpath) + END FUNCTION fs_realpath + + FUNCTION fs_relpath(path,reldir) RESULT(res) + !! Get the relative representation of two paths + !! + !! The method computes the relative representation of __path__ from __reldir__ if possible. + !! If no common prefix is found, the method returns __path__. + CHARACTER(len=*), INTENT(in) :: path, & !! Path to be computed relative to reldir + reldir !! A directory path from which output should be relative to + CHARACTER(len=:), ALLOCATABLE :: res !! An allocated string with the resulting path + TYPE(C_PTR) :: zpath + zpath = relpath_c(cstring(ADJUSTL(path)),cstring(ADJUSTL(reldir))) + IF (.NOT.C_ASSOCIATED(zpath)) THEN + res = TRIM(ADJUSTL(path)) + ELSE + res = cstr2fstr(zpath) + ENDIF + CALL free_c(zpath) + END FUNCTION fs_relpath + + FUNCTION fs_getcwd() RESULT(path) + !! Get the current working directory + CHARACTER(len=:), ALLOCATABLE :: path + !! The current working directory or an empty string if method fails + TYPE(C_PTR) :: zpath + zpath = getcwd_c() + IF (C_ASSOCIATED(zpath)) THEN + path = cstr2fstr(zpath) + ELSE + path = "" + ENDIF + CALL free_c(zpath) + RETURN + END FUNCTION fs_getcwd + + FUNCTION fs_remove(path) RESULT(ret) + !! Delete the file/directory pointed by the given path + CHARACTER(len=*), INTENT(in) :: path !! A string with the (valid) file path to delete + LOGICAL :: ret !! True on success, false otherwise. + IF (LEN_TRIM(path) == 0) THEN + ret = .false. + ELSE + ret = INT(remove_c(cstring(ADJUSTL(path)))) == 0 + ENDIF + RETURN + END FUNCTION fs_remove + + FUNCTION fs_rename(old, new) RESULT(ret) + !! Rename a path + CHARACTER(len=*), INTENT(in) :: old, & !! A string with the (valid) path to rename + new !! A string with the new name of the path + LOGICAL :: ret !! True on success, false otherwise. + IF (LEN_TRIM(old) == 0.OR.LEN_TRIM(new) == 0) THEN + ret = .false. + ELSE + ret = INT(rename_c(cstring(ADJUSTL(old)),cstring(ADJUSTL(new)))) == 0 + ENDIF + RETURN + END FUNCTION fs_rename + + FUNCTION fs_chmod(path, mode) RESULT(ret) + !! Change file/directory permissions + CHARACTER(len=*), INTENT(in) :: path !! Path to modify + INTEGER, INTENT(in) :: mode !! New octal permissions of the file + LOGICAL :: ret !! True on success, false otherwise. + INTEGER(kind=C_INT) :: zmode + IF (LEN_TRIM(path) == 0) THEN + ret = .false. + ELSE + zmode = INT(oct_2_dec(mode),kind=C_INT) + ret = INT(chmod_c(cstring(ADJUSTL(path)), zmode)) == 0 + ENDIF + RETURN + END FUNCTION fs_chmod + + FUNCTION fs_chdir(path) RESULT(ret) + !! Change current working directory + CHARACTER(len=*), INTENT(in) :: path !! Path of the new working directory + LOGICAL :: ret !! True on success, false otherwise. + IF (LEN_TRIM(path) == 0) THEN + ret = .false. + ELSE + ret = INT(chdir_c(cstring(ADJUSTL(path)))) == 0 + ENDIF + RETURN + END FUNCTION fs_chdir + + FUNCTION fs_mkdir(path, mode, permissive) RESULT(ret) + !! Create directory + !! + !! The method attempts to create a new directory pointed by __path__ with the permission + !! given by mode. + CHARACTER(len=*), INTENT(in) :: path + !! The path to modify + INTEGER, INTENT(in), OPTIONAL :: mode + !! Optional octal permission to set for the new directory + LOGICAL, INTENT(in), OPTIONAL :: permissive + !! Optional boolean with .true. to create intermediate directories in the path + LOGICAL :: ret + !! True on success, false otherwise. + INTEGER :: zmode + LOGICAL :: zperm + IF (LEN_TRIM(path) == 0) THEN + ret = .false. + ELSE + zmode = oct_2_dec(744) + IF (PRESENT(mode)) THEN + IF (.NOT.chk_pm(mode)) THEN + ret = .false. ; RETURN + ENDIF + zmode = oct_2_dec(mode) + ENDIF + zperm = .false. ; IF (PRESENT(permissive)) zperm = permissive + IF (zperm) THEN + ret = INT(mkdirp_c(cstring(ADJUSTL(path)),INT(zmode,kind=C_INT))) == 0 + ELSE + ret = INT(mkdir_c(cstring(ADJUSTL(path)),INT(zmode,kind=C_INT))) == 0 + ENDIF + ENDIF + RETURN + END FUNCTION fs_mkdir + + FUNCTION fs_rmdir(path,forced) RESULT(ret) + !! Remove directory + !! + !! By default, the function removes an __empty__ directory. If __forced__ is given and set + !! to .true. then the function recursively deletes the directory and __ALL__ its content. + CHARACTER(len=*), INTENT(in) :: path + !! The path of the directory to delete + LOGICAL, INTENT(in), OPTIONAL :: forced + !! Optional boolean with @ti{.true.} to remove all contents of the directory. + LOGICAL :: ret + !! True on success, false otherwise. + LOGICAL :: zforce + IF (LEN_TRIM(path) == 0) THEN + ret = .false. + ELSE + zforce = .false. ; IF (PRESENT(forced)) zforce = forced + IF (.NOT.zforce) THEN + ret = INT(rmdir_c(cstring(ADJUSTL(path)))) == 0 + ELSE + ret = INT(rmdirf_c(cstring(ADJUSTL(path)))) == 0 + ENDIF + ENDIF + RETURN + END FUNCTION fs_rmdir + + FUNCTION fs_stat(path,type,perm,nlnks,uid,gid,fsize,atime,mtime,ctime) RESULT(ret) + !! Get some informations about a path + !! + !! The method retrieves various informations about the input path using fstat C function. + !! The type of path as returned in __type__ argument is can take the following values: + !! + !! - 0, a file + !! - 1, a link to a file + !! - 2, a directory + !! - 3, a link to a directory + !! - 4, other (fifo, socket, block special, char special...) + CHARACTER(len=*), INTENT(in) :: path !! Input path + INTEGER, INTENT(out), OPTIONAL :: type, & !! Optional type of path (see function documentation). + perm, & !! Optional permission of the path + nlnks, & !! Optional number of links to the path + uid, & !! Optional user id + gid !! Optional group id + INTEGER(kind=8), INTENT(out), OPTIONAL :: fsize !! Optional file size + CHARACTER(len=19), INTENT(out), OPTIONAL :: atime, & !! Optional last access time + mtime, & !! Optional last modification time + ctime !! Optional creation time + LOGICAL :: ret !! True on success, false otherwise. + INTEGER :: ty,pe,ln,ud,gd + INTEGER(kind=8) :: fs + CHARACTER(len=:), ALLOCATABLE :: at,mt,ct + INTEGER(kind=C_INT) :: p,l,t,u,g + INTEGER(kind=c_long) :: f + CHARACTER(len=20,kind=C_CHAR) :: ta,tm,tc + IF (LEN_TRIM(path) == 0) THEN + ret = .false.; RETURN + ELSE IF (.NOT.(PRESENT(type) .OR. PRESENT(perm) .OR. PRESENT(nlnks) .OR. & + PRESENT(uid) .OR. PRESENT(gid) .OR. PRESENT(fsize) .OR. & + PRESENT(atime) .OR. PRESENT(mtime) .OR. PRESENT(ctime))) THEN + ret = .true. + ELSE + ! set default values + pe=-1 ; ty=-1 ; ud=-1 ; gd=-1 ; fs=-1 ; at="" ; mt="" ; ct="" + ret = INT(fstat_c(cstring(ADJUSTL(path)),p,l,t,u,g,f,ta,tm,tc)) == 0 + IF (ret) THEN + pe=INT(p) ; ln=INT(l) ; ty=INT(t) ; ud=INT(u) ; gd=INT(g) + fs=INT(f,kind=8) + at = fstring(ta) + mt = fstring(tm) + ct = fstring(tc) + ENDIF + IF (PRESENT(type)) type = ty + IF (PRESENT(perm)) perm = pe + IF (PRESENT(nlnks)) nlnks = ln + IF (PRESENT(uid)) uid = ud + IF (PRESENT(gid)) gid = gd + IF (PRESENT(fsize)) fsize = fs + IF (PRESENT(atime)) atime = at + IF (PRESENT(mtime)) mtime = mt + IF (PRESENT(ctime)) ctime = ct + ENDIF + RETURN + END FUNCTION fs_stat + + FUNCTION fs_isdir(path) RESULT (ret) + !! Check if a path is a directory + !! + !! The method is just a wrapper of [[fsystem(module):fs_stat(function)]] to get only specific + !! information about __path__ type. + CHARACTER(len=*), INTENT(in) :: path !! The path to check + LOGICAL :: ret !! .true. if the path is a directory, .false. otherwise. + INTEGER :: ty + ret = fs_stat(path,type=ty) + ret = ret.AND.(ty==2.or.ty==3) + RETURN + END FUNCTION fs_isdir + + FUNCTION fs_isfile(path) RESULT (ret) + !! Check if a path is a file + !! + !! The method is just a wrapper of [[fsystem(module):fs_stat(function)]] to get only specific + !! information about __path__ type. + CHARACTER(len=*), INTENT(in) :: path !! The path to check + LOGICAL :: ret !! .true. if the path is a file, .false. otherwise. + INTEGER :: ty + ret=fs_stat(path,type=ty) + ret = ret.and.(ty==0.or.ty==1) + RETURN + END FUNCTION fs_isfile + + FUNCTION fs_islink(path) RESULT (ret) + !! Check if a path is a link + !! + !! The method is just a wrapper of [[fsystem(module):fs_stat(function)]] to get only specific + !! information about __path__ type. + CHARACTER(len=*), INTENT(in) :: path !! The path to check + LOGICAL :: ret !! .true. if the path is a link, .false. otherwise. + INTEGER :: ty + ret=fs_stat(path,type=ty) + ret = ret.and.(ty==1.or.ty==3) + RETURN + END FUNCTION fs_islink + + FUNCTION fs_access(path,permission) RESULT(ret) + !! Check if a path is accessible for current user + !! + !! The method checks if the given path is accessible for the current user. By default, + !! it does not check for specific permissions. If __permission__ is given it should be + !! an integer between 0 and 7 resulting from the possible combinations: + !! + !! - 0 : Checks for path existence (default) + !! - 1 : Checks for EXECUTE permission + !! - 2 : Checks for WRITE permission + !! - 4 : Checks for READ permission + CHARACTER(len=*), INTENT(in) :: path !! Path to check + INTEGER, INTENT(in), OPTIONAL :: permission !! Optional permission to check + LOGICAL :: ret !! True on success, false otherwise. + INTEGER(kind=C_INT) :: zp + IF (LEN_TRIM(path) == 0) THEN + ret = .false. + ELSE + zp = 0 ; IF (PRESENT(permission)) zp = INT(permission,kind=C_INT) + ! Defaults are set in the C function. + ret = INT(access_c(cstring(ADJUSTL(path)),zp)) == 0 + ENDIF + RETURN + END FUNCTION fs_access + + FUNCTION fs_split_ext(path, base, ext, absolute) RESULT(ret) + !! Split given path into base,extension + !! + !! The __base__ of a path is conventionnally defined as all characters before the last dot of the path. + !! The extension (__ext__) of the path gathers consequently all characters from the last dot to the end + !! of the string. + !! @note + !! If the basename of the path begins by a dot then the path is assumed to be an hidden file (directory). + !! __ext__ will then be empty. + CHARACTER(len=*), INTENT(in) :: path !! Path to split + CHARACTER(len=:), INTENT(out), ALLOCATABLE :: base, & !! Output base of the path + ext !! Output extension of the path + LOGICAL, INTENT(in), OPTIONAL :: absolute !! .true. to return absolute path + LOGICAL :: ret !! .true. on success, .false. otherwise. + LOGICAL :: zabs + INTEGER :: p + CHARACTER(len=:), ALLOCATABLE :: d,b,apath + base = "" ; ext = "" + ret = .false. + IF (LEN_TRIM(path) == 0) THEN + RETURN + ENDIF + zabs = .false. ; IF (PRESENT(absolute)) zabs = absolute + apath = TRIM(path) + IF (zabs) THEN + apath = fs_realpath(path) ; IF (LEN_TRIM(apath) == 0) RETURN + ENDIF + d = fs_dirname(apath) ; IF (LEN_TRIM(d) == 0) RETURN + b = fs_basename(apath) ; IF (LEN_TRIM(b) == 0) RETURN + p = INDEX(b,".",.true.) + ! If dot is set as first char of basename : it's an hidden file + IF (p > 1) THEN + ext = b(p:) ; base = TRIM(d)//"/"//b(:p-1) + ELSE + base = TRIM(apath) + ENDIF + ret = .true. + RETURN + END FUNCTION fs_split_ext + + FUNCTION fs_create(path, mode, type, permissive) RESULT(ret) + !! Create a directory/file + !! + !! The method creates the file/directory pointed by given __path__. + !! If __type__ is not given, the method builds the path as : + !! + !! -# A file if the basename of the path contains an extension + !! -# A directory in any other cases. + !! + !! Otherwise __type__ should be set to "f" for file or "d" for directory. + !! + !! Unless __permissive__ is set to .true., the method will fails if intermediate + !! directories in the path do not exist. + CHARACTER(len=*), INTENT(in) :: path !! Path to create + INTEGER, INTENT(in), OPTIONAL :: mode !! Optional octal permisions to set + CHARACTER(len=1), INTENT(in), OPTIONAL :: type !! Optional type of path to create + LOGICAL, INTENT(in), OPTIONAL :: permissive !! .true. to create intermediate directories if not existing + LOGICAL :: ret !! True on success, false otherwise. + INTEGER :: zmd,zt,zp + CHARACTER(len=:), ALLOCATABLE :: b,e + ret = .false. + ! Checking for existence + IF (LEN_TRIM(path) == 0) THEN + RETURN + ELSE IF (fs_access(path)) THEN + RETURN + ENDIF + ! Set type of path + IF (PRESENT(type)) THEN + IF (.NOT.(type(1:1)=="f".OR.type(1:1)=="d")) THEN + RETURN + ELSE + zt=0 ; IF (type(1:1)=="f") zt = 1 + ENDIF + ELSE + IF(.NOT.fs_split_ext(path,b,e)) RETURN + zt = 0 ; IF (LEN_TRIM(e) /= 0) zt=1 + ENDIF + ! set permissions according to type + IF (zt == 0) THEN + zmd = oct_2_dec(777)-get_umask() + ELSE + zmd = oct_2_dec(666) -get_umask() + ENDIF + ! Check mode argument if present + IF (PRESENT(mode)) THEN + IF(.NOT.chk_pm(mode)) THEN + ! not a valid permission : We raise an error and abort + RETURN + ELSE + zmd = oct_2_dec(mode) + ENDIF + ENDIF + zp = 0 ; IF(PRESENT(permissive)) THEN ; IF(permissive) zp=1 ; ENDIF + ret = INT(create_c(cstring(ADJUSTL(path)),INT(zmd,kind=C_INT),INT(zt,kind=C_INT),INT(zp,kind=C_INT))) == 0 + RETURN + END FUNCTION fs_create + + FUNCTION fs_get_parent(path, n) RESULT(opath) + !! Get the nth parent of the given path + !! + !! The method first resolves the given path using [[fsystem(module):fs_realpath(function)]] + !! to get an absolute path. + !! @note + !! If __n__ is greater than the maximum parent level of the path, "/" is returned. + CHARACTER(len=*), INTENT(in) :: path + !! Input path + INTEGER, INTENT(in), OPTIONAL :: n + !! The level of the parent to get + CHARACTER(len=:), ALLOCATABLE :: opath + !! The nth parent of the given path, or an empty string if the parent can not be computed + CHARACTER(len=:), ALLOCATABLE :: zp + INTEGER :: i,mx,zl,mzl + opath = "" + zl = 1 ; IF (PRESENT(n)) zl = MAX(n,1) + IF (LEN_TRIM(path) == 0) THEN + RETURN + ENDIF + ! Gets the absolute path + zp = fs_realpath(TRIM(ADJUSTL(path))) + IF (LEN_TRIM(zp) == 0) RETURN + ! removing trailing / (only if it's not the first ^^) + mx = LEN_TRIM(zp) ; IF (zp(mx:mx)=="/".AND.mx/=1) zp(mx:mx) = "" + ! compute maximum level + mzl = 1 ; DO i=1,mx ; IF(zp(i:i) == '/') mzl=mzl+1 ; ENDDO + i=0 + DO + mx = INDEX(zp(1:mx),'/',.true.) ; i=i+1 + IF (mx==0.OR.i>=zl.OR.i>=mzl) EXIT + mx = mx - 1 + ENDDO + IF (mx >= 1) THEN + opath = zp(1:MAX(1,mx-1)) + ELSE + opath = "/" + ENDIF + RETURN + END FUNCTION fs_get_parent + + SUBROUTINE fs_termsize(row, column) + !! Get the current terminal window size + !! @attention + !! If the program is redirected to a file (and maybe some other device), the C + !! function can raise an error. In that case, the default values (20,80) are + !! returned by the C function and thus the subroutine ! + INTEGER, INTENT(out) :: row, & !! Number of rows of the window + column !! Number of columns of the window + INTEGER(kind=C_INT) :: r, c, ret + ret = termsize_c(r,c) + row = INT(r) ; column = INT(c) + RETURN + END SUBROUTINE fs_termsize + + SUBROUTINE fs_usleep(usec) + !! Sleep for a given number of microseconds + !! @note + !! Currently if C usleep function failed, the system... does not sleep ! + INTEGER, INTENT(in) :: usec !! The number of microseconds to sleep for + INTEGER(kind=C_INT) :: ret + ! usleep expects useconds_t (unsigned int) which is given here as a 4-bytes int + ret = usleep_c(INT(usec,kind=C_INT)) + END SUBROUTINE fs_usleep + + SUBROUTINE fs_msleep(msec) + !! Sleep for a given number of milliseconds + INTEGER, INTENT(in) :: msec !! The number of milliseconds to sleep for + CALL fs_usleep(msec*1000) + END SUBROUTINE fs_msleep + +!=============================================================================== +! MODULE MISCELLANEOUS METHODS +!=============================================================================== + + FUNCTION oct_2_dec(octal) RESULT(res) + !> Octal to decimal conversion + !! + !! The method converts the octal number ranging from 0 to 777 in the decimal system. + !! @attention + !! If the __octal__ number is out of range then the method returns 384 (600 in octal). + INTEGER, INTENT(in) :: octal !! The octal value to convert + INTEGER :: res !! The converted decimal value + INTEGER :: o,d,i + IF (octal < 0 .OR. octal > 777) THEN + res = 384 ; RETURN ! --> 600 in octal : rw------- + ENDIF + d = 0 ; i = 0 ; o = octal + DO WHILE(o/=0) + d=d+mod(o,10)*8**i ; i=i+1 ; o=o/10 + ENDDO + res=d + RETURN + END FUNCTION oct_2_dec + + FUNCTION dec_2_oct(decimal) RESULT(res) + !! Decimal to octal conversion + !! The method converts the decimal number ranging from 0 to 511 in the octal system. + !! @attention + !! If the __decimal__ number is out of range, then it the method returns 600 (384 in decimal). + INTEGER, INTENT(in) :: decimal !! The decimal value to convert + INTEGER :: res !! The converted octal value + ! - LOCAL + INTEGER :: o,d,i,m + IF (decimal < 0 .OR. decimal > 511) THEN + res = 600 ; RETURN ! --> 384 in decimal : rw------- + ENDIF + o=0 ; d = decimal ; i=0 ; m=0 + DO WHILE(d/=0) + d=d/8 ; m=m+1 + ENDDO + m=m-1 ; d=decimal + DO i=0,m + o=o+mod(d,8)*10**i ; d=d/8 + ENDDO + res = o + RETURN + END FUNCTION dec_2_oct + + FUNCTION sp_2_op(str) RESULT(oct) + !! Get octal number of string representation's permission + CHARACTER(len=3),INTENT(in) :: str !! The permission to convert + INTEGER :: oct !! Octal value of the string permission on succes, -1 otherwise. + oct = -1 + IF (LEN_TRIM(str) /= 3) RETURN + SELECT CASE(str) + CASE("---") ; oct = 0 + CASE("--x") ; oct = 1 + CASE("-w-") ; oct = 2 + CASE("-wx") ; oct = 3 + CASE("r--") ; oct = 4 + CASE("r-x") ; oct = 5 + CASE("rw-") ; oct = 6 + CASE("rwx") ; oct = 7 + CASE DEFAULT + oct = -1 ; RETURN + END SELECT + RETURN + END FUNCTION sp_2_op + + FUNCTION op_2_sp(oct) RESULT(str) + !! Get string representation of the octal number's permission + INTEGER, INTENT(in) :: oct !! Octal number to convert + CHARACTER(len=3) :: str !! String representation of the octal number on succes, 'ukn' otherwise + SELECT CASE(oct) + CASE(0) ; str="---" + CASE(1) ; str="--x" + CASE(2) ; str="-w-" + CASE(3) ; str="-wx" + CASE(4) ; str="r--" + CASE(5) ; str="r-x" + CASE(6) ; str="rw-" + CASE(7) ; str="rwx" + CASE DEFAULT + str='ukn' ; RETURN + END SELECT + RETURN + END FUNCTION op_2_sp + + FUNCTION str_perm(oct_perm) RESULT(ret) + !! Get the string representation of the given permission mask + INTEGER, INTENT(in) :: oct_perm !! The octal representation of the permission + CHARACTER(len=9) :: ret !! String representation of the octal number on succes, 'ukn' otherwise + INTEGER :: u,g,o + IF (.NOT.chk_pm(oct_perm)) THEN + ret = "ukn" ; RETURN + ENDIF + u=int(oct_perm/100) ; g=int((oct_perm-u*100)/10) ; o=int(oct_perm-u*100-g*10) + ret(1:3) = op_2_sp(u) ; ret(4:6) = op_2_sp(g) ; ret(7:9) = op_2_sp(o) + RETURN + END FUNCTION str_perm + + FUNCTION oct_perm(str) RESULT(ret) + !! Get the string representation of the given permission mask + CHARACTER(len=9), INTENT(in) :: str !! The string representation of the permission + INTEGER :: ret !! Octal permission on success, -1 otherwise + ! - LOCAL + INTEGER :: u,g,o + u = sp_2_op(str(1:3)) ; g = sp_2_op(str(4:6)) ; o = sp_2_op(str(7:9)) + IF (u==-1.OR.g==-1.OR.o==-1) THEN + ret = -1 ; RETURN + ELSE + ret = u*100 + g*10 + o + ENDIF + RETURN + END FUNCTION oct_perm + + FUNCTION chk_pm(perm) RESULT(valid) + !! Check if the given permission is valid + INTEGER, INTENT(in) :: perm !! Octal permission mask + LOGICAL :: valid !! .true. if the permission mask is valid, .false. otherwise + INTEGER :: u,g,o + u=int(perm/100) ; g=int((perm-u*100)/10) ; o=int(perm-u*100-g*10) + valid = (u>=0.AND.u<=7).AND.(g>=0.AND.g<=7).AND.(o>=0.AND.o<=7) + RETURN + END FUNCTION chk_pm + + FUNCTION get_umask() RESULT(mask) + !! Get the umask value of the current session + INTEGER :: mask !! Current umask value in decimal system + mask = INT(umask_c()) + RETURN + END FUNCTION get_umask + + FUNCTION sz2str(file_size) RESULT(fstr) + !! Get a human readable file size + INTEGER(kind=8), INTENT(in) :: file_size !! File size (assumed to be bytes) + CHARACTER(len=50) :: fstr !! Size in a human readable format + ! - LOCAL + INTEGER :: cc + REAL(kind=8) :: zfs + CHARACTER(len=2), DIMENSION(6), PARAMETER :: sn = & + (/'B ','KB','MB','GB','TB','PB'/) + zfs=DBLE(file_size) + DO cc=1,size(sn)-1 ; IF (zfs<1024.) EXIT ; zfs=zfs/1024. ; ENDDO + IF (MOD(zfs,1.0) == 0) THEN + WRITE(fstr,'(I50)') INT(zfs) ; fstr = TRIM(ADJUSTL(fstr))//sn(cc) + ELSE + WRITE(fstr,'(F50.2)') zfs ; fstr = TRIM(ADJUSTL(fstr))//sn(cc) + ENDIF + RETURN + END FUNCTION sz2str + +END MODULE FSYSTEM Index: trunk/LMDZ.TITAN/libf/muphytitan/lint_prec.F90 =================================================================== --- trunk/LMDZ.TITAN/libf/muphytitan/lint_prec.F90 (revision 1793) +++ trunk/LMDZ.TITAN/libf/muphytitan/lint_prec.F90 (revision 1793) @@ -0,0 +1,64 @@ +! Copyright Université Reims Champagnne-Ardenne (2010-2015) +! contributor: Jérémie Burgalat +! +! jeremie.burgalat@univ-reims.fr +! +! This software is a computer program whose purpose is to compute multi-variate +! linear interpolation. +! +! This software is governed by the CeCILL-B license under French law and +! abiding by the rules of distribution of free software. You can use, +! modify and/ or redistribute the software under the terms of the CeCILL-B +! license as circulated by CEA, CNRS and INRIA at the following URL +! "http://www.cecill.info". +! +! As a counterpart to the access to the source code and rights to copy, +! modify and redistribute granted by the license, users are provided only +! with a limited warranty and the software's author, the holder of the +! economic rights, and the successive licensors have only limited +! liability. +! +! In this respect, the user's attention is drawn to the risks associated +! with loading, using, modifying and/or developing or reproducing the +! software by the user in light of its specific status of free software, +! that may mean that it is complicated to manipulate, and that also +! therefore means that it is reserved for developers and experienced +! professionals having in-depth computer knowledge. Users are therefore +! encouraged to load and test the software's suitability as regards their +! requirements in conditions enabling the security of their systems and/or +! data to be ensured and, more generally, to use and operate it in the +! same conditions as regards security. +! +! The fact that you are presently reading this means that you have had +! knowledge of the CeCILL-B license and that you accept its terms. + +!! file: lint_prec.F90 +!! summary: Library floating point computations precision module. +!! author: J. Burgalat +!! date: 2010-2014 + +#undef PREC +#define PREC 64 +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif + +MODULE LINT_PREC + !! Library floating point computations precision module. + !! + !! This module only defines a single variable [[lint_prec(module):wp(variable)]] which + !! set the kind of floating point value used in all other parts of the library. + IMPLICIT NONE + +#if (PREC == 32) + !> Size of floating point variables in the library (single). + INTEGER, PUBLIC, PARAMETER :: wp = SELECTED_REAL_KIND(p=6) ! 32 bits +#elif (PREC == 64) + !> Size of floating point variables in the library (double). + INTEGER, PUBLIC, PARAMETER :: wp = SELECTED_REAL_KIND(p=15) ! 64 bits +#elif (PREC == 80) + !> Size of floating point variables in the library (extended-double). + INTEGER, PUBLIC, PARAMETER :: wp = SELECTED_REAL_KIND(p=18) ! 80 bits +#endif +END MODULE LINT_PREC + Index: trunk/LMDZ.TITAN/libf/muphytitan/lintcore.f90 =================================================================== --- trunk/LMDZ.TITAN/libf/muphytitan/lintcore.f90 (revision 1793) +++ trunk/LMDZ.TITAN/libf/muphytitan/lintcore.f90 (revision 1793) @@ -0,0 +1,114 @@ +! Copyright Université Reims Champagnne-Ardenne (2010-2015) +! contributor: Jérémie Burgalat +! +! jeremie.burgalat@univ-reims.fr +! +! This software is a computer program whose purpose is to compute multi-variate +! linear interpolation. +! +! This software is governed by the CeCILL-B license under French law and +! abiding by the rules of distribution of free software. You can use, +! modify and/ or redistribute the software under the terms of the CeCILL-B +! license as circulated by CEA, CNRS and INRIA at the following URL +! "http://www.cecill.info". +! +! As a counterpart to the access to the source code and rights to copy, +! modify and redistribute granted by the license, users are provided only +! with a limited warranty and the software's author, the holder of the +! economic rights, and the successive licensors have only limited +! liability. +! +! In this respect, the user's attention is drawn to the risks associated +! with loading, using, modifying and/or developing or reproducing the +! software by the user in light of its specific status of free software, +! that may mean that it is complicated to manipulate, and that also +! therefore means that it is reserved for developers and experienced +! professionals having in-depth computer knowledge. Users are therefore +! encouraged to load and test the software's suitability as regards their +! requirements in conditions enabling the security of their systems and/or +! data to be ensured and, more generally, to use and operate it in the +! same conditions as regards security. +! +! The fact that you are presently reading this means that you have had +! knowledge of the CeCILL-B license and that you accept its terms. + +!! file: lintcore.f90 +!! summary: linear interpolation core function file +!! author: burgalat +!! date: 2010-2014 + +MODULE LINTCORE + !! Core module of the library. + !! + !! This module contains a single function that performs the linear + !! interpolation of a single _N_-D point between \(2^{N}\) adjacents + !! points. + USE LINT_PREC + IMPLICIT NONE + + PRIVATE :: wp ! from LINT_PREC + + INTERFACE + FUNCTION locate(value,vector) RESULT(idx) + !! Locate the nearest default value in vector + !! + !! the method should search the subscript of the nearest value by default in + !! in the input vector. + IMPORT wp + REAL(kind=wp), INTENT(in) :: value !! value to search + REAL(kind=wp), INTENT(in), DIMENSION(:) :: vector !! Vector to search in + INTEGER :: idx !! Subscript of the nearest value in vector + END FUNCTION locate + END INTERFACE + + + CONTAINS + + FUNCTION lintc_(point,grid) RESULT(res) + !! Multivariate linear interpolation core function + !! + !! The method computes multivariate linear interpolation at the given __point__ using its + !! neighbours given in __grid__. + !! + !! @warning + !! In order to get a correct result, __grid__ must be ordered so first dimensions vary first + !! (see [Generic method](page/index.html/#generic-method) section of main documentation). + !! + !! @warning + !! The method in its current version does not check array boundaries. This operation should be + !! performed in wrappers of the function ! + INTEGER, PARAMETER :: np = 2 + REAL(kind=wp), INTENT(in), DIMENSION(:) :: point + !! Coordinates of the point to compute. + !! + !! For __N__-D interpolation, ut should be a vector of __N__ points. + REAL(kind=wp), INTENT(in), DIMENSION(:,:) :: grid + !! Grid of values used for interpolation. + !! + !! For __N__-D interpolation, it should be a 2D-array of \(2^{N}\) rows and \(N+1\) columns. + !! Each row corresponds to a point with N coordinates, the last column is reserved for the + !! value of the point. + REAL(kind=wp) :: res + !! Interpolated value + REAL(kind=wp), DIMENSION(:),ALLOCATABLE :: val + REAL(kind=wp) :: cd + INTEGER :: nv,mi,ngp,cp,i,j,k + nv = SIZE(point) ; mi = np**nv + ALLOCATE(val(2*mi-1)) + val(1:mi) = grid(:,nv+1) ; val(mi+1:2*mi-1) = 0._wp + ! Computes the QnD linear interpolation + cp = 0 + DO i=1,nv + cd = (point(i)-grid(1,i))/(grid(mi,i)-grid(1,i)) + k = 1 ; ngp = np**(nv-i+1) ; cp = cp + ngp + DO j=1,ngp,np + val(cp+k) = val(j+cp-ngp) * (1._wp - cd) + val(j+cp-ngp+1)*cd + k = k + 1 + ENDDO + ENDDO + res = val(cp+k-1) + DEALLOCATE(val) ! useless normally + RETURN + END FUNCTION lintc_ + +END MODULE LINTCORE Index: trunk/LMDZ.TITAN/libf/muphytitan/lintdset.f90 =================================================================== --- trunk/LMDZ.TITAN/libf/muphytitan/lintdset.f90 (revision 1793) +++ trunk/LMDZ.TITAN/libf/muphytitan/lintdset.f90 (revision 1793) @@ -0,0 +1,852 @@ +! Copyright Université Reims Champagnne-Ardenne (2010-2015) +! contributor: Jérémie Burgalat +! +! jeremie.burgalat@univ-reims.fr +! +! This software is a computer program whose purpose is to compute multi-variate +! linear interpolation. +! +! This software is governed by the CeCILL-B license under French law and +! abiding by the rules of distribution of free software. You can use, +! modify and/ or redistribute the software under the terms of the CeCILL-B +! license as circulated by CEA, CNRS and INRIA at the following URL +! "http://www.cecill.info". +! +! As a counterpart to the access to the source code and rights to copy, +! modify and redistribute granted by the license, users are provided only +! with a limited warranty and the software's author, the holder of the +! economic rights, and the successive licensors have only limited +! liability. +! +! In this respect, the user's attention is drawn to the risks associated +! with loading, using, modifying and/or developing or reproducing the +! software by the user in light of its specific status of free software, +! that may mean that it is complicated to manipulate, and that also +! therefore means that it is reserved for developers and experienced +! professionals having in-depth computer knowledge. Users are therefore +! encouraged to load and test the software's suitability as regards their +! requirements in conditions enabling the security of their systems and/or +! data to be ensured and, more generally, to use and operate it in the +! same conditions as regards security. +! +! The fact that you are presently reading this means that you have had +! knowledge of the CeCILL-B license and that you accept its terms. + +!! file: lintdset.f90 +!! summary: Linear interpolation generic interfaces +!! author: burgalat +!! date: 2010-2014 + + +MODULE LINTDSET + !! Generic linear interpolation using simple [[datasets(module)]] + USE LINT_PREC + USE LINTCORE + USE DATASETS + IMPLICIT NONE + + PUBLIC :: lint_dset, hdcd_lint_dset, & + dset1d, dset2d, dset3d, dset4d, dset5d, & + read_dset, clear_dset, is_in + PRIVATE + + !> Interface to multi-variate linear interpolation using data set + !! + !! For __n__, the number of variables, user must provide: + !! + !! - __n__ scalar(s)/vector(s) with the coordinate(s) of the point(s) to + !! interpolate. + !! - A single __n__-D data set with the tabulated function. + !! - A function, satisfying the [[lintcore(module):locate(interface)]] interface, that + !! should locate the neighbourhood of the point to interpolate in the given data + !! set. + !! - Either a scalar or vector which stores the interpolated values. + !! + !! This interface also provides vectorized version of the linear + !! interpolation. In this case, input coordinates should be vector of the same + !! size as well as the output argument. + INTERFACE lint_dset + MODULE PROCEDURE l1d_dset_sc, l2d_dset_sc, l3d_dset_sc, l4d_dset_sc, & + l5d_dset_sc + MODULE PROCEDURE l1d_dset_ve, l2d_dset_ve, l3d_dset_ve, l4d_dset_ve, & + l5d_dset_ve + END INTERFACE + + !> Interface to multi-variate hard-coded linear interpolation using data set + !! + !! Same remarks as in [[lintdset(module):lint_dset(interface)]] apply here. + INTERFACE hdcd_lint_dset + MODULE PROCEDURE hdcdl1d_dset_sc, hdcdl2d_dset_sc, hdcdl3d_dset_sc, & + hdcdl4d_dset_sc, hdcdl5d_dset_sc + MODULE PROCEDURE hdcdl1d_dset_ve, hdcdl2d_dset_ve, hdcdl3d_dset_ve, & + hdcdl4d_dset_ve, hdcdl5d_dset_ve + END INTERFACE + + CONTAINS + + FUNCTION l1d_dset_sc(x,set,locator,res) RESULT(ret) + !! Wrapper interface for 1D linear interpolation (scalar) + !! + !! @warning + !! On error, __res__ output value is undefined. + REAL(kind=wp), INTENT(in) :: x !! X coordinate of the point to interpolate + TYPE(dset1d), INTENT(in) :: set !! Dataset with the tabulated function + REAL(kind=wp), INTENT(out) :: res !! Interpolated value + PROCEDURE(locate) :: locator !! Locator function + LOGICAL :: ret !! .true. on success, .false. otherwise + REAL(kind=wp), DIMENSION(2,2) :: g1d + INTEGER :: i,ix + ret = .false. + res = HUGE(res) + ix = locator(x,set%x) ; IF (ix == 0) RETURN + DO i=0,1 + g1d(i+1,1) = set%x(ix+i) + g1d(i+1,2) = set%data(ix+i) + ENDDO + res = lintc_((/x/),g1d) + ret = .true. + END FUNCTION l1d_dset_sc + + FUNCTION l2d_dset_sc(x,y,set,locator,res) RESULT(ret) + !! Wrapper interface for 2D linear interpolation (scalar) + !! + !! @warning + !! On error, __res__ output value is undefined. + REAL(kind=wp), INTENT(in) :: x !! X coordinate of the point to interpolate + REAL(kind=wp), INTENT(in) :: y !! Y coordinate of the point to interpolate + TYPE(dset2d), INTENT(in) :: set !! Dataset with the tabulated function + REAL(kind=wp), INTENT(out) :: res !! Interpolated value + PROCEDURE(locate) :: locator !! Locator function + LOGICAL :: ret !! .true. on success, .false. otherwise + REAL(kind=wp), DIMENSION(4,3) :: g2d + INTEGER :: i,ix0,iy0,a,b + ret = .false. + res = HUGE(res) + ix0 = locator(x,set%x) ; IF (ix0 == 0) RETURN + iy0 = locator(y,set%y) ; IF (iy0 == 0) RETURN + DO i=1,4 + a=ix0+MOD((i-1),2) ; g2d(i,1) = set%x(a) + b=iy0+MOD((i-1)/2,2) ; g2d(i,2) = set%y(b) + g2d(i,3) = set%data(a,b) + ENDDO + res = lintc_((/x,y/),g2d) + ret = .true. + END FUNCTION l2d_dset_sc + + FUNCTION l3d_dset_sc(x,y,z,set,locator,res) RESULT(ret) + !! Wrapper interface for 3D linear interpolation (scalar) + !! + !! @warning + !! On error, __res__ output value is undefined. + REAL(kind=wp), INTENT(in) :: x !! X coordinate of the point to interpolate + REAL(kind=wp), INTENT(in) :: y !! Y coordinate of the point to interpolate + REAL(kind=wp), INTENT(in) :: z !! Z coordinate of the point to interpolate + TYPE(dset3d), INTENT(in) :: set !! Dataset with the tabulated function + REAL(kind=wp), INTENT(out) :: res !! Interpolated value + PROCEDURE(locate) :: locator !! Locator function + LOGICAL :: ret !! .true. on success, .false. otherwise + REAL(kind=wp), DIMENSION(8,4) :: g3d + INTEGER :: i,ix0,iy0,iz0,a,b,c + ret = .false. + res = HUGE(res) + ix0 = locator(x,set%x) ; IF (ix0 == 0) RETURN + iy0 = locator(y,set%y) ; IF (iy0 == 0) RETURN + iz0 = locator(z,set%z) ; IF (iz0 == 0) RETURN + DO i=1,8 + a=ix0+MOD((i-1),2) ; g3d(i,1) = set%x(a) + b=iy0+MOD((i-1)/2,2) ; g3d(i,2) = set%y(b) + c=iz0+MOD((i-1)/4,2) ; g3d(i,3) = set%z(c) + g3d(i,4) = set%data(a,b,c) + ENDDO + res = lintc_((/x,y,z/),g3d) + ret = .true. + END FUNCTION l3d_dset_sc + + FUNCTION l4d_dset_sc(x,y,z,t,set,locator,res) RESULT(ret) + !! Wrapper interface for 4D linear interpolation (scalar) + !! + !! @warning + !! On error, __res__ output value is undefined. + REAL(kind=wp), INTENT(in) :: x !! X coordinate of the point to interpolate + REAL(kind=wp), INTENT(in) :: y !! Y coordinate of the point to interpolate + REAL(kind=wp), INTENT(in) :: z !! Z coordinate of the point to interpolate + REAL(kind=wp), INTENT(in) :: t !! T coordinate of the point to interpolate + TYPE(dset4d), INTENT(in) :: set !! Dataset with the tabulated function + REAL(kind=wp), INTENT(out) :: res !! Interpolated value + PROCEDURE(locate) :: locator !! Locator function + LOGICAL :: ret !! .true. on success, .false. otherwise + REAL(kind=wp), DIMENSION(16,5) :: g4d + INTEGER :: i,ix0,iy0,iz0,it0,a,b,c,d + ret = .false. + res = HUGE(res) + ix0 = locator(x,set%x) ; IF (ix0 == 0) RETURN + iy0 = locator(y,set%y) ; IF (iy0 == 0) RETURN + iz0 = locator(z,set%z) ; IF (iz0 == 0) RETURN + it0 = locator(t,set%t) ; IF (it0 == 0) RETURN + DO i=1,16 + a=ix0+MOD((i-1),2) ; g4d(i,1) = set%x(a) + b=iy0+MOD((i-1)/2,2) ; g4d(i,2) = set%y(b) + c=iz0+MOD((i-1)/4,2) ; g4d(i,3) = set%z(c) + d=it0+MOD((i-1)/8,2) ; g4d(i,4) = set%t(d) + g4d(i,5) = set%data(a,b,c,d) + ENDDO + res = lintc_((/x,y,z,t/),g4d) + ret = .true. + END FUNCTION l4d_dset_sc + + FUNCTION l5d_dset_sc(x,y,z,t,w,set,locator,res) RESULT(ret) + !! Wrapper interface for 5D linear interpolation (scalar) + !! + !! @warning + !! On error, __res__ output value is undefined. + REAL(kind=wp), INTENT(in) :: x !! X coordinate of the point to interpolate + REAL(kind=wp), INTENT(in) :: y !! Y coordinate of the point to interpolate + REAL(kind=wp), INTENT(in) :: z !! Z coordinate of the point to interpolate + REAL(kind=wp), INTENT(in) :: t !! T coordinate of the point to interpolate + REAL(kind=wp), INTENT(in) :: w !! W coordinate of the point to interpolate + TYPE(dset5d), INTENT(in) :: set !! Dataset with the tabulated function + REAL(kind=wp), INTENT(out) :: res !! Interpolated value + PROCEDURE(locate) :: locator !! Locator function + LOGICAL :: ret !! .true. on success, .false. otherwise + REAL(kind=wp), DIMENSION(32,6) :: g5d + INTEGER :: i,ix0,iy0,iz0,it0,iw0,a,b,c,d,e + ret = .false. + res = HUGE(res) + ix0 = locator(x,set%x) ; IF (ix0 == 0) RETURN + iy0 = locator(y,set%y) ; IF (iy0 == 0) RETURN + iz0 = locator(z,set%z) ; IF (iz0 == 0) RETURN + it0 = locator(t,set%t) ; IF (it0 == 0) RETURN + iw0 = locator(w,set%w) ; IF (iw0 == 0) RETURN + DO i=1,32 + a=ix0+MOD((i-1),2) ; g5d(i,1) = set%x(a) + b=iy0+MOD((i-1)/2,2) ; g5d(i,2) = set%y(b) + c=iz0+MOD((i-1)/4,2) ; g5d(i,3) = set%z(c) + d=it0+MOD((i-1)/8,2) ; g5d(i,4) = set%t(d) + e=iw0+MOD((i-1)/16,2) ; g5d(i,5) = set%w(e) + g5d(i,6) = set%data(a,b,c,d,e) + ENDDO + res = lintc_((/x,y,z,t,w/),g5d) + ret = .true. + END FUNCTION l5d_dset_sc + + FUNCTION l1d_dset_ve(x,set,locator,res) RESULT(ret) + !! Wrapper interface for 1D linear interpolation (vector) + !! + !! @warning + !! On error, __res__ output vector is undefined (i.e. not allocated). + REAL(kind=wp), INTENT(in), DIMENSION(:) :: x !! X coordinate of the points to interpolate + TYPE(dset1d), INTENT(in) :: set !! Dataset with the tabulated function + REAL(kind=wp), INTENT(out), DIMENSION(:), ALLOCATABLE :: res !! Interpolated values + PROCEDURE(locate) :: locator !! Locator function + LOGICAL :: ret !! .true. on success, .false. otherwise + REAL(kind=wp), DIMENSION(2,2) :: g1d + INTEGER :: nv,i,j,ix0 + ret = .false. + nv = SIZE(x) ; ALLOCATE(res(nv)) + DO j=1,nv + ix0 = locator(x(j),set%x) + IF (ix0 == 0) THEN + DEALLOCATE(res) ; RETURN + ENDIF + DO i=0,1 + g1d(i+1,1) = set%x(ix0+i) + g1d(i+1,2) = set%data(ix0+i) + ENDDO + res(j) = lintc_((/x(j)/),g1d) + ENDDO + ret = .true. + END FUNCTION l1d_dset_ve + + FUNCTION l2d_dset_ve(x,y,set,locator,res) RESULT(ret) + !! Wrapper interface for 2D linear interpolation (vector) + !! + !! @warning + !! On error, __res__ output vector is undefined (i.e. not allocated). + REAL(kind=wp), INTENT(in), DIMENSION(:) :: x !! X coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: y !! Y coordinate of the points to interpolate + TYPE(dset2d), INTENT(in) :: set !! Dataset with the tabulated function + REAL(kind=wp), INTENT(out), DIMENSION(:), ALLOCATABLE :: res !! Interpolated values + PROCEDURE(locate) :: locator !! Locator function + LOGICAL :: ret !! .true. on success, .false. otherwise + REAL(kind=wp), DIMENSION(4,3) :: g2d + INTEGER :: nv,i,j,ix0,iy0,a,b + ret = .false. + nv = SIZE(x) ; ALLOCATE(res(nv)) + DO j=1,nv + ix0 = locator(x(j),set%x) + iy0 = locator(y(j),set%y) + IF (ix0 == 0 .OR. iy0 == 0) THEN + DEALLOCATE(res) ; RETURN + ENDIF + DO i=1,4 + a=ix0+MOD((i-1),2) ; g2d(i,1) = set%x(a) + b=iy0+MOD((i-1)/2,2) ; g2d(i,2) = set%y(b) + g2d(i,3) = set%data(a,b) + ENDDO + res(j) = lintc_((/x(j),y(j)/),g2d) + ENDDO + ret = .true. + END FUNCTION l2d_dset_ve + + FUNCTION l3d_dset_ve(x,y,z,set,locator,res) RESULT(ret) + !! Wrapper interface for 3D linear interpolation (vector) + !! + !! @warning + !! On error, __res__ output vector is undefined (i.e. not allocated). + REAL(kind=wp), INTENT(in), DIMENSION(:) :: x !! X coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: y !! Y coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: z !! Z coordinate of the points to interpolate + TYPE(dset3d), INTENT(in) :: set !! Dataset with the tabulated function + REAL(kind=wp), INTENT(out), DIMENSION(:), ALLOCATABLE :: res !! Interpolated values + PROCEDURE(locate) :: locator !! Locator function + LOGICAL :: ret !! .true. on success, .false. otherwise + REAL(kind=wp), DIMENSION(8,4) :: g3d + INTEGER :: nv,i,j,ix0,iy0,iz0,a,b,c + ret = .false. + nv = SIZE(x) ; ALLOCATE(res(nv)) + DO j=1,nv + ix0 = locator(x(j),set%x) + iy0 = locator(y(j),set%y) + iz0 = locator(z(j),set%z) + IF (ix0==0 .OR. iy0==0 .OR. iz0==0) THEN + DEALLOCATE(res) ; RETURN + ENDIF + DO i=1,8 + a=ix0+MOD((i-1),2) ; g3d(i,1) = set%x(a) + b=iy0+MOD((i-1)/2,2) ; g3d(i,2) = set%y(b) + c=iz0+MOD((i-1)/4,2) ; g3d(i,3) = set%z(c) + g3d(i,4) = set%data(a,b,c) + ENDDO + res(j) = lintc_((/x(j),y(j),z(j)/),g3d) + ENDDO + ret = .true. + END FUNCTION l3d_dset_ve + + FUNCTION l4d_dset_ve(x,y,z,t,set,locator,res) RESULT(ret) + !! Wrapper interface for 4D linear interpolation (vector) + !! + !! @warning + !! On error, __res__ output vector is undefined (i.e. not allocated). + REAL(kind=wp), INTENT(in), DIMENSION(:) :: x !! X coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: y !! Y coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: z !! Z coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: t !! T coordinate of the points to interpolate + TYPE(dset4d), INTENT(in) :: set !! Dataset with the tabulated function + REAL(kind=wp), INTENT(out), DIMENSION(:), ALLOCATABLE :: res !! Interpolated values + PROCEDURE(locate) :: locator !! Locator function + LOGICAL :: ret !! .true. on success, .false. otherwise + REAL(kind=wp), DIMENSION(16,5) :: g4d + INTEGER :: nv,i,j,ix0,iy0,iz0,it0,a,b,c,d + ret = .false. + nv = SIZE(x) ; ALLOCATE(res(nv)) + DO j=1,nv + ix0 = locator(x(j),set%x) + iy0 = locator(y(j),set%y) + iz0 = locator(z(j),set%z) + it0 = locator(t(j),set%t) + IF (ix0==0 .OR. iy0==0 .OR. iz0==0 .OR. it0==0) THEN + DEALLOCATE(res) ; RETURN + ENDIF + DO i=1,16 + a=ix0+MOD((i-1),2) ; g4d(i,1) = set%x(a) + b=iy0+MOD((i-1)/2,2) ; g4d(i,2) = set%y(b) + c=iz0+MOD((i-1)/4,2) ; g4d(i,3) = set%z(c) + d=it0+MOD((i-1)/8,2) ; g4d(i,4) = set%t(d) + g4d(i,5) = set%data(a,b,c,d) + ENDDO + res(j) = lintc_((/x(j),y(j),z(j),t(j)/),g4d) + ENDDO + ret = .true. + END FUNCTION l4d_dset_ve + + FUNCTION l5d_dset_ve(x,y,z,t,w,set,locator,res) RESULT(ret) + !! Wrapper interface for 5D linear interpolation (vector) + !! + !! @warning + !! On error, __res__ output vector is undefined (i.e. not allocated). + REAL(kind=wp), INTENT(in), DIMENSION(:) :: x !! X coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: y !! Y coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: z !! Z coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: t !! T coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: w !! W coordinate of the points to interpolate + TYPE(dset5d), INTENT(in) :: set !! Dataset with the tabulated function + REAL(kind=wp), INTENT(out), DIMENSION(:), ALLOCATABLE :: res !! Interpolated values + PROCEDURE(locate) :: locator !! Locator function + LOGICAL :: ret !! .true. on success, .false. otherwise + REAL(kind=wp), DIMENSION(32,6) :: g5d + INTEGER :: nv,i,j,ix0,iy0,iz0,it0,iw0,a,b,c,d,e + ret = .false. + nv = SIZE(x) ; ALLOCATE(res(nv)) + DO j=1,nv + ix0 = locator(x(j),set%x) + iy0 = locator(y(j),set%y) + iz0 = locator(z(j),set%z) + it0 = locator(t(j),set%t) + iw0 = locator(w(j),set%w) + IF (ix0==0 .OR. iy0==0 .OR. iz0==0 .OR. it0==0 .OR. iw0==0) THEN + DEALLOCATE(res) ; RETURN + ENDIF + DO i=1,32 + a=ix0+MOD((i-1),2) ; g5d(i,1) = set%x(a) + b=iy0+MOD((i-1)/2,2) ; g5d(i,2) = set%y(b) + c=iz0+MOD((i-1)/4,2) ; g5d(i,3) = set%z(c) + d=it0+MOD((i-1)/8,2) ; g5d(i,4) = set%t(d) + e=iw0+MOD((i-1)/16,2) ; g5d(i,5) = set%w(e) + g5d(i,6) = set%data(a,b,c,d,e) + ENDDO + res(j) = lintc_((/x(j),y(j),z(j),t(j),w(j)/),g5d) + ENDDO + ret = .true. + END FUNCTION l5d_dset_ve + + !--------------------! + ! HARD CODED VERSION ! + !--------------------! + + FUNCTION hdcdl1d_dset_sc(x,set, locator,res) RESULT(ret) + !! Hard-coded for 1D linear interpolation (scalar) + !! + !! @warning + !! On error, __res__ output value is undefined. + REAL(kind=wp), INTENT(in) :: x !! X coordinate of the point to interpolate + TYPE(dset1d), INTENT(in) :: set !! Dataset with the tabulated function + REAL(kind=wp), INTENT(out) :: res !! Interpolated value + PROCEDURE(locate) :: locator !! Locator function + LOGICAL :: ret !! .true. on success, .false. otherwise + REAL(kind=wp) :: xd + INTEGER :: ix0,ix1 + ret = .false. + res = HUGE(res) + ix0 = locator(x,set%x) ; IF (ix0 == 0) RETURN + ix1 = ix0+1 + xd = (x-set%x(ix0))/(set%x(ix1)-set%x(ix0)) + res = set%data(ix0)*(1d0-xd)+set%data(ix1)*xd + ret = .true. + END FUNCTION hdcdl1d_dset_sc + + FUNCTION hdcdl2d_dset_sc(x,y,set,locator,res) RESULT(ret) + !! Hard-coded for 2D linear interpolation (scalar) + !! + !! @warning + !! On error, __res__ output value is undefined. + REAL(kind=wp), INTENT(in) :: x !! X coordinate of the point to interpolate + REAL(kind=wp), INTENT(in) :: y !! Y coordinate of the point to interpolate + TYPE(dset2d), INTENT(in) :: set !! Dataset with the tabulated function + REAL(kind=wp), INTENT(out) :: res !! Interpolated value + PROCEDURE(locate) :: locator !! Locator function + LOGICAL :: ret !! .true. on success, .false. otherwise + REAL(kind=wp) :: xd,yd + REAL(kind=wp) :: f0,f1 + INTEGER :: ix0,iy0,ix1,iy1 + ret = .false. + res = HUGE(res) + ix0 = locator(x,set%x) ; IF (ix0 == 0) RETURN + iy0 = locator(y,set%y) ; IF (iy0 == 0) RETURN + ix1 = ix0 + 1 ; iy1 = iy0 + 1 + xd = (x-set%x(ix0))/(set%x(ix1)-set%x(ix0)) + yd = (y-set%y(iy0))/(set%y(iy1)-set%y(iy0)) + f0 = set%data(ix0,iy0)*(1d0-xd)+set%data(ix1,iy0)*xd + f1 = set%data(ix0,iy1)*(1d0-xd)+set%data(ix1,iy1)*xd + res = f0*(1d0-yd)+f1*yd + ret = .true. + END FUNCTION hdcdl2d_dset_sc + + FUNCTION hdcdl3d_dset_sc(x,y,z,set,locator,res) RESULT(ret) + !! Hard-coded for 3D linear interpolation (scalar) + !! + !! @warning + !! On error, __res__ output value is undefined. + REAL(kind=wp), INTENT(in) :: x !! X coordinate of the point to interpolate + REAL(kind=wp), INTENT(in) :: y !! Y coordinate of the point to interpolate + REAL(kind=wp), INTENT(in) :: z !! Z coordinate of the point to interpolate + TYPE(dset3d), INTENT(in) :: set !! Dataset with the tabulated function + REAL(kind=wp), INTENT(out) :: res !! Interpolated value + PROCEDURE(locate) :: locator !! Locator function + LOGICAL :: ret !! .true. on success, .false. otherwise + REAL(kind=wp) :: xd,yd,zd + REAL(kind=wp) :: f00,f10,f01,f11,f0,f1 + INTEGER :: ix0,iy0,iz0,ix1,iy1,iz1 + ret = .false. + res = HUGE(res) + ix0 = locator(x,set%x) ; IF (ix0 == 0) RETURN + iy0 = locator(y,set%y) ; IF (iy0 == 0) RETURN + iz0 = locator(z,set%z) ; IF (iz0 == 0) RETURN + ix1=ix0+1 ; iy1=iy0+1 ; iz1=iz0+1 + xd = (x-set%x(ix0))/(set%x(ix1)-set%x(ix0)) + yd = (y-set%y(iy0))/(set%y(iy1)-set%y(iy0)) + zd = (z-set%z(iz0))/(set%z(iz1)-set%z(iz0)) + + f00 = set%data(ix0,iy0,iz0)*(1d0-xd)+set%data(ix1,iy0,iz0)*xd + f10 = set%data(ix0,iy1,iz0)*(1d0-xd)+set%data(ix1,iy1,iz0)*xd + f01 = set%data(ix0,iy0,iz1)*(1d0-xd)+set%data(ix1,iy0,iz1)*xd + f11 = set%data(ix0,iy1,iz1)*(1d0-xd)+set%data(ix1,iy1,iz1)*xd + + f0 = f00 *(1d0-yd)+f10*yd + f1 = f00 *(1d0-yd)+f10*yd + + res = f0*(1d0-zd)+f1*zd + ret = .true. + END FUNCTION hdcdl3d_dset_sc + + FUNCTION hdcdl4d_dset_sc(x,y,z,t,set,locator,res) RESULT(ret) + !! Hard-coded for 4D linear interpolation (scalar) + !! + !! @warning + !! On error, __res__ output value is undefined. + REAL(kind=wp), INTENT(in) :: x !! X coordinate of the point to interpolate + REAL(kind=wp), INTENT(in) :: y !! Y coordinate of the point to interpolate + REAL(kind=wp), INTENT(in) :: z !! Z coordinate of the point to interpolate + REAL(kind=wp), INTENT(in) :: t !! T coordinate of the point to interpolate + TYPE(dset4d), INTENT(in) :: set !! Dataset with the tabulated function + REAL(kind=wp), INTENT(out) :: res !! Interpolated value + PROCEDURE(locate) :: locator !! Locator function + LOGICAL :: ret !! .true. on success, .false. otherwise + REAL(kind=wp) :: xd,yd,zd,td + REAL(kind=wp) :: f000,f100,f010,f110,f001,f101,f011,f111, & + f00,f10,f01,f11,f0,f1 + INTEGER :: ix0,iy0,iz0,it0,ix1,iy1,iz1,it1 + ret = .false. + res = HUGE(res) + ix0 = locator(x,set%x) ; IF (ix0 == 0) RETURN + iy0 = locator(y,set%y) ; IF (iy0 == 0) RETURN + iz0 = locator(z,set%z) ; IF (iz0 == 0) RETURN + it0 = locator(t,set%t) ; IF (it0 == 0) RETURN + + ix1=ix0+1 ; iy1=iy0+1 ; iz1=iz0+1 ; it1=it0+1 + xd = (x-set%x(ix0))/(set%x(ix1)-set%x(ix0)) + yd = (y-set%y(iy0))/(set%y(iy1)-set%y(iy0)) + zd = (z-set%z(iz0))/(set%z(iz1)-set%z(iz0)) + td = (t-set%t(it0))/(set%t(it1)-set%t(it0)) + + f000 = set%data(ix0,iy0,iz0,it0)*(1d0-xd)+set%data(ix1,iy0,iz0,it0)*xd + f100 = set%data(ix0,iy1,iz0,it0)*(1d0-xd)+set%data(ix1,iy1,iz0,it0)*xd + f010 = set%data(ix0,iy0,iz1,it0)*(1d0-xd)+set%data(ix1,iy0,iz1,it0)*xd + f110 = set%data(ix0,iy1,iz1,it0)*(1d0-xd)+set%data(ix1,iy1,iz1,it0)*xd + f001 = set%data(ix0,iy0,iz0,it1)*(1d0-xd)+set%data(ix1,iy0,iz0,it1)*xd + f101 = set%data(ix0,iy1,iz0,it1)*(1d0-xd)+set%data(ix1,iy1,iz0,it1)*xd + f011 = set%data(ix0,iy0,iz1,it1)*(1d0-xd)+set%data(ix1,iy0,iz1,it1)*xd + f111 = set%data(ix0,iy1,iz1,it1)*(1d0-xd)+set%data(ix1,iy1,iz1,it1)*xd + + f00 = f000*(1d0-yd)+f100*yd + f10 = f010*(1d0-yd)+f110*yd + f01 = f001*(1d0-yd)+f101*yd + f11 = f011*(1d0-yd)+f111*yd + + f0 = f00 *(1d0-zd)+f10*zd + f1 = f01 *(1d0-zd)+f11*zd + + res = f0*(1d0-td)+f1*td + ret = .true. + END FUNCTION hdcdl4d_dset_sc + + FUNCTION hdcdl5d_dset_sc(x,y,z,t,w,set,locator,res) RESULT(ret) + !! Hard-coded for 5D linear interpolation (scalar) + !! + !! @warning + !! On error, __res__ output value is undefined. + REAL(kind=wp), INTENT(in) :: x !! X coordinate of the point to interpolate + REAL(kind=wp), INTENT(in) :: y !! Y coordinate of the point to interpolate + REAL(kind=wp), INTENT(in) :: z !! Z coordinate of the point to interpolate + REAL(kind=wp), INTENT(in) :: t !! T coordinate of the point to interpolate + REAL(kind=wp), INTENT(in) :: w !! W coordinate of the point to interpolate + TYPE(dset5d), INTENT(in) :: set !! Dataset with the tabulated function + REAL(kind=wp), INTENT(out) :: res !! Interpolated value + PROCEDURE(locate) :: locator !! Locator function + LOGICAL :: ret !! .true. on success, .false. otherwise + REAL(kind=wp) :: xd,yd,zd,td,wd + REAL(kind=wp) :: f0000,f1000,f0100,f1100,f0010,f1010,f0110,f1110, & + f0001,f1001,f0101,f1101,f0011,f1011,f0111,f1111, & + f000,f100,f010,f110,f001,f101,f011,f111, & + f00,f10,f01,f11,f0,f1 + INTEGER :: ix0,iy0,iz0,it0,iw0,ix1,iy1,iz1,it1,iw1 + ret = .false. + res = HUGE(res) + ix0 = locator(x,set%x) ; IF (ix0 == 0) RETURN + iy0 = locator(y,set%y) ; IF (iy0 == 0) RETURN + iz0 = locator(z,set%z) ; IF (iz0 == 0) RETURN + it0 = locator(t,set%t) ; IF (it0 == 0) RETURN + iw0 = locator(w,set%w) ; IF (iw0 == 0) RETURN + + ix1=ix0+1 ; iy1=iy0+1 ; iz1=iz0+1 + xd = (x-set%x(ix0))/(set%x(ix1)-set%x(ix0)) + yd = (y-set%y(iy0))/(set%y(iy1)-set%y(iy0)) + zd = (z-set%z(iz0))/(set%z(iz1)-set%z(iz0)) + td = (t-set%t(it0))/(set%t(it1)-set%t(it0)) + wd = (w-set%w(it0))/(set%w(it1)-set%w(it0)) + + f0000 = set%data(ix0,iy0,iz0,it0,iw0)*(1d0-xd)+set%data(ix1,iy0,iz0,it0,iw0)*xd + f1000 = set%data(ix0,iy1,iz0,it0,iw0)*(1d0-xd)+set%data(ix0,iy1,iz0,it0,iw0)*xd + f0100 = set%data(ix0,iy0,iz1,it0,iw0)*(1d0-xd)+set%data(ix1,iy0,iz1,it0,iw0)*xd + f1100 = set%data(ix0,iy1,iz1,it0,iw0)*(1d0-xd)+set%data(ix1,iy1,iz1,it0,iw0)*xd + f0010 = set%data(ix0,iy0,iz0,it1,iw0)*(1d0-xd)+set%data(ix1,iy0,iz0,it1,iw0)*xd + f1010 = set%data(ix0,iy1,iz0,it1,iw0)*(1d0-xd)+set%data(ix1,iy1,iz0,it1,iw0)*xd + f0110 = set%data(ix0,iy0,iz1,it1,iw0)*(1d0-xd)+set%data(ix1,iy0,iz1,it1,iw0)*xd + f1110 = set%data(ix0,iy1,iz1,it1,iw0)*(1d0-xd)+set%data(ix1,iy1,iz1,it1,iw0)*xd + f0001 = set%data(ix0,iy0,iz0,it0,iw1)*(1d0-xd)+set%data(ix1,iy0,iz0,it0,iw1)*xd + f1001 = set%data(ix0,iy1,iz0,it0,iw1)*(1d0-xd)+set%data(ix0,iy1,iz0,it0,iw1)*xd + f0101 = set%data(ix0,iy0,iz1,it0,iw1)*(1d0-xd)+set%data(ix1,iy0,iz1,it0,iw1)*xd + f1101 = set%data(ix0,iy1,iz1,it0,iw1)*(1d0-xd)+set%data(ix1,iy1,iz1,it0,iw1)*xd + f0011 = set%data(ix0,iy0,iz0,it1,iw1)*(1d0-xd)+set%data(ix1,iy0,iz0,it1,iw1)*xd + f1011 = set%data(ix0,iy1,iz0,it1,iw1)*(1d0-xd)+set%data(ix1,iy1,iz0,it1,iw1)*xd + f0111 = set%data(ix0,iy0,iz1,it1,iw1)*(1d0-xd)+set%data(ix1,iy0,iz1,it1,iw1)*xd + f1111 = set%data(ix0,iy1,iz1,it1,iw1)*(1d0-xd)+set%data(ix1,iy1,iz1,it1,iw1)*xd + + f000 = f0000*(1d0-yd) + f1000*yd + f100 = f0100*(1d0-yd) + f1100*yd + f010 = f0010*(1d0-yd) + f1010*yd + f110 = f0110*(1d0-yd) + f1110*yd + f101 = f0101*(1d0-yd) + f1101*yd + f011 = f0011*(1d0-yd) + f1011*yd + f111 = f0111*(1d0-yd) + f1111*yd + + f00 = f000*(1d0-zd)+f100*zd + f10 = f010*(1d0-zd)+f110*zd + f01 = f001*(1d0-zd)+f101*zd + f11 = f011*(1d0-zd)+f111*zd + + f0 = f00 *(1d0-td)+f10*td + f1 = f01 *(1d0-td)+f11*td + + res = f0*(1d0-wd)+f1*wd + ret = .true. + END FUNCTION hdcdl5d_dset_sc + + FUNCTION hdcdl1d_dset_ve(x,set,locator,res) RESULT(ret) + !! Hard-coded for 1D linear interpolation (vector) + !! + !! @warning + !! On error, __res__ output vector is undefined (i.e. not allocated). + REAL(kind=wp), INTENT(in), DIMENSION(:) :: x !! X coordinate of the points to interpolate + TYPE(dset1d), INTENT(in) :: set !! Dataset with the tabulated function + REAL(kind=wp), INTENT(out), DIMENSION(:), ALLOCATABLE :: res !! Interpolated values + PROCEDURE(locate) :: locator !! Locator function + LOGICAL :: ret !! .true. on success, .false. otherwise + REAL(kind=wp) :: xd + INTEGER :: nv,j,ix0,ix1 + ret = .false. + nv = SIZE(x) ; ALLOCATE(res(nv)) + DO j=1,nv + ix0 = locator(x(j),set%x) + IF (ix0==0) THEN + DEALLOCATE(res) ; RETURN + ENDIF + ix1 = ix0+1 + xd = (x(j)-set%x(ix0))/(set%x(ix1)-set%x(ix0)) + res(j) = set%data(ix0)*(1d0-xd)+set%data(ix1)*xd + ENDDO + ret = .true. + END FUNCTION hdcdl1d_dset_ve + + FUNCTION hdcdl2d_dset_ve(x,y,set,locator,res) RESULT(ret) + !! Hard-coded for 2D linear interpolation (vector) + !! + !! @warning + !! On error, __res__ output vector is undefined (i.e. not allocated). + REAL(kind=wp), INTENT(in), DIMENSION(:) :: x !! X coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: y !! Y coordinate of the points to interpolate + TYPE(dset2d), INTENT(in) :: set !! Dataset with the tabulated function + REAL(kind=wp), INTENT(out), DIMENSION(:), ALLOCATABLE :: res !! Interpolated values + PROCEDURE(locate) :: locator !! Locator function + LOGICAL :: ret !! .true. on success, .false. otherwise + REAL(kind=wp) :: xd,yd + REAL(kind=wp) :: f0,f1 + INTEGER :: nv,j,ix0,iy0,ix1,iy1 + ret = .false. + nv = SIZE(x) ; ALLOCATE(res(nv)) + DO j=1,nv + ix0 = locator(x(j),set%x) + iy0 = locator(y(j),set%y) + IF (ix0==0 .OR. iy0==0) THEN + DEALLOCATE(res) ; RETURN + ENDIF + ix1 = ix0 + 1 ; iy1 = iy0 + 1 + xd = (x(j)-set%x(ix0))/(set%x(ix1)-set%x(ix0)) + yd = (y(j)-set%y(iy0))/(set%y(iy1)-set%y(iy0)) + f0 = set%data(ix0,iy0)*(1d0-xd)+set%data(ix1,iy0)*xd + f1 = set%data(ix0,iy1)*(1d0-xd)+set%data(ix1,iy1)*xd + res(j) = f0*(1d0-yd)+f1*yd + ENDDO + ret = .true. + END FUNCTION hdcdl2d_dset_ve + + FUNCTION hdcdl3d_dset_ve(x,y,z,set,locator,res) RESULT(ret) + !! Hard-coded for 3D linear interpolation (vector) + !! + !! @warning + !! On error, __res__ output vector is undefined (i.e. not allocated). + REAL(kind=wp), INTENT(in), DIMENSION(:) :: x !! X coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: y !! Y coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: z !! Z coordinate of the points to interpolate + TYPE(dset3d), INTENT(in) :: set !! Dataset with the tabulated function + REAL(kind=wp), INTENT(out), DIMENSION(:), ALLOCATABLE :: res !! Interpolated values + PROCEDURE(locate) :: locator !! Locator function + LOGICAL :: ret !! .true. on success, .false. otherwise + REAL(kind=wp) :: xd,yd,zd + REAL(kind=wp) :: f00,f10,f01,f11,f0,f1 + INTEGER :: nv,j,ix0,iy0,iz0,ix1,iy1,iz1 + ret = .false. + nv = SIZE(x) ; ALLOCATE(res(nv)) + DO j=1,nv + ix0 = locator(x(j),set%x) + iy0 = locator(y(j),set%y) + iz0 = locator(z(j),set%z) + + IF (ix0==0 .OR. iy0==0 .OR. iz0==0) THEN + DEALLOCATE(res) ; RETURN + ENDIF + + ix1=ix0+1 ; iy1=iy0+1 ; iz1=iz0+1 + xd = (x(j)-set%x(ix0))/(set%x(ix1)-set%x(ix0)) + yd = (y(j)-set%y(iy0))/(set%y(iy1)-set%y(iy0)) + zd = (z(j)-set%z(iz0))/(set%z(iz1)-set%z(iz0)) + + f00 = set%data(ix0,iy0,iz0)*(1d0-xd)+set%data(ix1,iy0,iz0)*xd + f10 = set%data(ix0,iy1,iz0)*(1d0-xd)+set%data(ix1,iy1,iz0)*xd + f01 = set%data(ix0,iy0,iz1)*(1d0-xd)+set%data(ix1,iy0,iz1)*xd + f11 = set%data(ix0,iy1,iz1)*(1d0-xd)+set%data(ix1,iy1,iz1)*xd + + f0 = f00 *(1d0-yd)+f10*yd + f1 = f00 *(1d0-yd)+f10*yd + + res(j) = f0*(1d0-zd)+f1*zd + ENDDO + ret = .true. + END FUNCTION hdcdl3d_dset_ve + + FUNCTION hdcdl4d_dset_ve(x,y,z,t,set,locator,res) RESULT(ret) + !! Hard-coded for 4D linear interpolation (vector) + !! + !! @warning + !! On error, __res__ output vector is undefined (i.e. not allocated). + REAL(kind=wp), INTENT(in), DIMENSION(:) :: x !! X coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: y !! Y coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: z !! Z coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: t !! T coordinate of the points to interpolate + TYPE(dset4d), INTENT(in) :: set !! Dataset with the tabulated function + REAL(kind=wp), INTENT(out), DIMENSION(:), ALLOCATABLE :: res !! Interpolated values + PROCEDURE(locate) :: locator !! Locator function + LOGICAL :: ret !! .true. on success, .false. otherwise + REAL(kind=wp) :: xd,yd,zd,td + REAL(kind=wp) :: f000,f100,f010,f110,f001,f101,f011,f111, & + f00,f10,f01,f11,f0,f1 + INTEGER :: nv,j,ix0,iy0,iz0,it0,ix1,iy1,iz1,it1 + ret = .false. + nv = SIZE(x) ; ALLOCATE(res(nv)) + DO j=1,nv + ix0 = locator(x(j),set%x) + iy0 = locator(y(j),set%y) + iz0 = locator(z(j),set%z) + it0 = locator(t(j),set%t) + + IF (ix0==0 .OR. iy0==0 .OR. iz0==0 .OR. it0==0) THEN + DEALLOCATE(res) ; RETURN + ENDIF + + ix1=ix0+1 ; iy1=iy0+1 ; iz1=iz0+1 ; it1=it0+1 + xd = (x(j)-set%x(ix0))/(set%x(ix1)-set%x(ix0)) + yd = (y(j)-set%y(iy0))/(set%y(iy1)-set%y(iy0)) + zd = (z(j)-set%z(iz0))/(set%z(iz1)-set%z(iz0)) + td = (t(j)-set%t(it0))/(set%t(it1)-set%t(it0)) + + f000 = set%data(ix0,iy0,iz0,it0)*(1d0-xd)+set%data(ix1,iy0,iz0,it0)*xd + f100 = set%data(ix0,iy1,iz0,it0)*(1d0-xd)+set%data(ix1,iy1,iz0,it0)*xd + f010 = set%data(ix0,iy0,iz1,it0)*(1d0-xd)+set%data(ix1,iy0,iz1,it0)*xd + f110 = set%data(ix0,iy1,iz1,it0)*(1d0-xd)+set%data(ix1,iy1,iz1,it0)*xd + f001 = set%data(ix0,iy0,iz0,it1)*(1d0-xd)+set%data(ix1,iy0,iz0,it1)*xd + f101 = set%data(ix0,iy1,iz0,it1)*(1d0-xd)+set%data(ix1,iy1,iz0,it1)*xd + f011 = set%data(ix0,iy0,iz1,it1)*(1d0-xd)+set%data(ix1,iy0,iz1,it1)*xd + f111 = set%data(ix0,iy1,iz1,it1)*(1d0-xd)+set%data(ix1,iy1,iz1,it1)*xd + + f00 = f000*(1d0-yd)+f100*yd + f10 = f010*(1d0-yd)+f110*yd + f01 = f001*(1d0-yd)+f101*yd + f11 = f011*(1d0-yd)+f111*yd + + f0 = f00 *(1d0-zd)+f10*zd + f1 = f01 *(1d0-zd)+f11*zd + + res(j) = f0*(1d0-td)+f1*td + ENDDO + ret = .true. + END FUNCTION hdcdl4d_dset_ve + + FUNCTION hdcdl5d_dset_ve(x,y,z,t,w,set,locator,res) RESULT(ret) + !! Hard-coded for 5D linear interpolation (vector) + !! + !! @warning + !! On error, __res__ output vector is undefined (i.e. not allocated). + REAL(kind=wp), INTENT(in), DIMENSION(:) :: x !! X coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: y !! Y coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: z !! Z coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: t !! T coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: w !! W coordinate of the points to interpolate + TYPE(dset5d), INTENT(in) :: set !! Dataset with the tabulated function + REAL(kind=wp), INTENT(out), DIMENSION(:), ALLOCATABLE :: res !! Interpolated values + PROCEDURE(locate) :: locator !! Locator function + LOGICAL :: ret !! .true. on success, .false. otherwise + REAL(kind=wp) :: xd,yd,zd,td,wd + REAL(kind=wp) :: f0000,f1000,f0100,f1100,f0010,f1010,f0110,f1110, & + f0001,f1001,f0101,f1101,f0011,f1011,f0111,f1111, & + f000,f100,f010,f110,f001,f101,f011,f111, & + f00,f10,f01,f11,f0,f1 + INTEGER :: nv,j,ix0,iy0,iz0,it0,iw0,ix1,iy1,iz1,it1,iw1 + ret = .false. + nv = SIZE(x) ; ALLOCATE(res(nv)) + DO j=1,nv + ix0 = locator(x(j),set%x) + iy0 = locator(y(j),set%y) + iz0 = locator(z(j),set%z) + it0 = locator(t(j),set%t) + iw0 = locator(w(j),set%w) + + IF (ix0==0 .OR. iy0==0 .OR. iz0==0 .OR. it0==0 .OR. iw0==0) THEN + DEALLOCATE(res) ; RETURN + ENDIF + + ix1=ix0+1 ; iy1=iy0+1 ; iz1=iz0+1 + xd = (x(j)-set%x(ix0))/(set%x(ix1)-set%x(ix0)) + yd = (y(j)-set%y(iy0))/(set%y(iy1)-set%y(iy0)) + zd = (z(j)-set%z(iz0))/(set%z(iz1)-set%z(iz0)) + td = (t(j)-set%t(it0))/(set%t(it1)-set%t(it0)) + wd = (w(j)-set%w(it0))/(set%w(it1)-set%w(it0)) + + f0000 = set%data(ix0,iy0,iz0,it0,iw0)*(1d0-xd)+set%data(ix1,iy0,iz0,it0,iw0)*xd + f1000 = set%data(ix0,iy1,iz0,it0,iw0)*(1d0-xd)+set%data(ix0,iy1,iz0,it0,iw0)*xd + f0100 = set%data(ix0,iy0,iz1,it0,iw0)*(1d0-xd)+set%data(ix1,iy0,iz1,it0,iw0)*xd + f1100 = set%data(ix0,iy1,iz1,it0,iw0)*(1d0-xd)+set%data(ix1,iy1,iz1,it0,iw0)*xd + f0010 = set%data(ix0,iy0,iz0,it1,iw0)*(1d0-xd)+set%data(ix1,iy0,iz0,it1,iw0)*xd + f1010 = set%data(ix0,iy1,iz0,it1,iw0)*(1d0-xd)+set%data(ix1,iy1,iz0,it1,iw0)*xd + f0110 = set%data(ix0,iy0,iz1,it1,iw0)*(1d0-xd)+set%data(ix1,iy0,iz1,it1,iw0)*xd + f1110 = set%data(ix0,iy1,iz1,it1,iw0)*(1d0-xd)+set%data(ix1,iy1,iz1,it1,iw0)*xd + f0001 = set%data(ix0,iy0,iz0,it0,iw1)*(1d0-xd)+set%data(ix1,iy0,iz0,it0,iw1)*xd + f1001 = set%data(ix0,iy1,iz0,it0,iw1)*(1d0-xd)+set%data(ix0,iy1,iz0,it0,iw1)*xd + f0101 = set%data(ix0,iy0,iz1,it0,iw1)*(1d0-xd)+set%data(ix1,iy0,iz1,it0,iw1)*xd + f1101 = set%data(ix0,iy1,iz1,it0,iw1)*(1d0-xd)+set%data(ix1,iy1,iz1,it0,iw1)*xd + f0011 = set%data(ix0,iy0,iz0,it1,iw1)*(1d0-xd)+set%data(ix1,iy0,iz0,it1,iw1)*xd + f1011 = set%data(ix0,iy1,iz0,it1,iw1)*(1d0-xd)+set%data(ix1,iy1,iz0,it1,iw1)*xd + f0111 = set%data(ix0,iy0,iz1,it1,iw1)*(1d0-xd)+set%data(ix1,iy0,iz1,it1,iw1)*xd + f1111 = set%data(ix0,iy1,iz1,it1,iw1)*(1d0-xd)+set%data(ix1,iy1,iz1,it1,iw1)*xd + + f000 = f0000*(1d0-yd) + f1000*yd + f100 = f0100*(1d0-yd) + f1100*yd + f010 = f0010*(1d0-yd) + f1010*yd + f110 = f0110*(1d0-yd) + f1110*yd + f101 = f0101*(1d0-yd) + f1101*yd + f011 = f0011*(1d0-yd) + f1011*yd + f111 = f0111*(1d0-yd) + f1111*yd + + f00 = f000*(1d0-zd)+f100*zd + f10 = f010*(1d0-zd)+f110*zd + f01 = f001*(1d0-zd)+f101*zd + f11 = f011*(1d0-zd)+f111*zd + + f0 = f00 *(1d0-td)+f10*td + f1 = f01 *(1d0-td)+f11*td + + res(j) = f0*(1d0-wd)+f1*wd + ENDDO + ret = .true. + END FUNCTION hdcdl5d_dset_ve + +END MODULE LINTDSET + Index: trunk/LMDZ.TITAN/libf/muphytitan/lintgen.f90 =================================================================== --- trunk/LMDZ.TITAN/libf/muphytitan/lintgen.f90 (revision 1793) +++ trunk/LMDZ.TITAN/libf/muphytitan/lintgen.f90 (revision 1793) @@ -0,0 +1,907 @@ +! Copyright Université Reims Champagnne-Ardenne (2010-2015) +! contributor: Jérémie Burgalat +! +! jeremie.burgalat@univ-reims.fr +! +! This software is a computer program whose purpose is to compute multi-variate +! linear interpolation. +! +! This software is governed by the CeCILL-B license under French law and +! abiding by the rules of distribution of free software. You can use, +! modify and/ or redistribute the software under the terms of the CeCILL-B +! license as circulated by CEA, CNRS and INRIA at the following URL +! "http://www.cecill.info". +! +! As a counterpart to the access to the source code and rights to copy, +! modify and redistribute granted by the license, users are provided only +! with a limited warranty and the software's author, the holder of the +! economic rights, and the successive licensors have only limited +! liability. +! +! In this respect, the user's attention is drawn to the risks associated +! with loading, using, modifying and/or developing or reproducing the +! software by the user in light of its specific status of free software, +! that may mean that it is complicated to manipulate, and that also +! therefore means that it is reserved for developers and experienced +! professionals having in-depth computer knowledge. Users are therefore +! encouraged to load and test the software's suitability as regards their +! requirements in conditions enabling the security of their systems and/or +! data to be ensured and, more generally, to use and operate it in the +! same conditions as regards security. +! +! The fact that you are presently reading this means that you have had +! knowledge of the CeCILL-B license and that you accept its terms. + +!! file: lintgen.f90 +!! summary: Linear interpolation generic interfaces +!! author: burgalat +!! date: 2010-2014 + +MODULE LINTGEN + !! Generic linear interpolation module + USE LINT_PREC + USE LINTCORE + IMPLICIT NONE + + PUBLIC :: lint_gen, hdcd_lint_gen + PRIVATE + + !> Interface to multi-variate linear interpolation + !! + !! For __n__, the number of function's variables, user must provide: + !! + !! - __n__ scalar(s) with the coordinate(s) of the point to interpolate. + !! - __n__ vector(s) with the tabulated values of each coordinate. + !! - a single __n__-D array with the value of tabulated function at each + !! tabulated coordinate. + !! - A function, satisfying [[lintcore(module):locate(interface)]] interface, + !! that locates the neighbourhood of the point to interpolate. + !! - A scalar that stores the output value. + INTERFACE lint_gen + MODULE PROCEDURE l1d_gen_sc,l2d_gen_sc,l3d_gen_sc,l4d_gen_sc,l5d_gen_sc + MODULE PROCEDURE l1d_gen_ve,l2d_gen_ve,l3d_gen_ve,l4d_gen_ve,l5d_gen_ve + END INTERFACE + + !> Interface to multi-variate hard-coded linear interpolation + !! + !! Same remarks as in [[lintgen(module):lint_gen(interface)]] apply here. + INTERFACE hdcd_lint_gen + MODULE PROCEDURE hdcdl1d_gen_sc, hdcdl2d_gen_sc, hdcdl3d_gen_sc, & + hdcdl4d_gen_sc, hdcdl5d_gen_sc + MODULE PROCEDURE hdcdl1d_gen_ve, hdcdl2d_gen_ve, hdcdl3d_gen_ve, & + hdcdl4d_gen_ve, hdcdl5d_gen_ve + END INTERFACE + + CONTAINS + + ! GENERIC versions + ! ---------------- + + FUNCTION l1d_gen_sc(x,cx,cv, locator,res) RESULT(ret) + !! Wrapper interface for 1D linear interpolation (scalar) + !! + !! @warning + !! On error, __res__ output value is undefined. + REAL(kind=wp), INTENT(in) :: x !! X coordinate of the point to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cx !! Tabulated function X coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cv !! Tabulated function values + REAL(kind=wp), INTENT(out) :: res !! Interpolated value + PROCEDURE(locate) :: locator !! Locator function + LOGICAL :: ret !! .true. on success, .false. otherwise + REAL(kind=wp), DIMENSION(2,2) :: g1d + INTEGER :: i,ix + ret = .false. + ix = locator(x,cx) ; IF (ix == 0) RETURN + DO i=0,1 + g1d(i+1,1) = cx(ix+i) + g1d(i+1,2) = cv(ix+i) + ENDDO + res = lintc_((/x/),g1d) + ret = .true. + END FUNCTION l1d_gen_sc + + FUNCTION l2d_gen_sc(x,y,cx,cy,cv,locator,res) RESULT(ret) + !! Wrapper interface for 2D linear interpolation (scalar) + !! + !! @warning + !! On error, __res__ output value is undefined. + REAL(kind=wp), INTENT(in) :: x !! X coordinate of the point to interpolate + REAL(kind=wp), INTENT(in) :: y !! Y coordinate of the point to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cx !! Tabulated function X coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cy !! Tabulated function Y coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:,:) :: cv !! Tabulated function values + REAL(kind=wp), INTENT(out) :: res !! Interpolated value + PROCEDURE(locate) :: locator !! Locator function + LOGICAL :: ret !! .true. on success, .false. otherwise + REAL(kind=wp), DIMENSION(4,3) :: g2d + INTEGER :: ix0,iy0,i,a,b + ret = .false. + ix0 = locator(x,cx) ; IF (ix0 == 0) RETURN + iy0 = locator(y,cy) ; IF (iy0 == 0) RETURN + DO i=1,4 + a=ix0+MOD((i-1),2) ; g2d(i,1) = cx(a) + b=iy0+MOD((i-1)/2,2) ; g2d(i,2) = cy(b) + g2d(i,3) = cv(a,b) + ENDDO + res = lintc_((/x,y/),g2d) + ret = .true. + END FUNCTION l2d_gen_sc + + FUNCTION l3d_gen_sc(x,y,z,cx,cy,cz,cv,locator,res) RESULT(ret) + !! Wrapper interface for 3D linear interpolation (scalar) + !! + !! @warning + !! On error, __res__ output value is undefined. + REAL(kind=wp), INTENT(in) :: x !! X coordinate of the point to interpolate + REAL(kind=wp), INTENT(in) :: y !! Y coordinate of the point to interpolate + REAL(kind=wp), INTENT(in) :: z !! Z coordinate of the point to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cx !! Tabulated function X coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cy !! Tabulated function Y coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cz !! Tabulated function Z coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:,:,:) :: cv !! Tabulated function values + REAL(kind=wp), INTENT(out) :: res !! Interpolated value + PROCEDURE(locate) :: locator !! Locator function + LOGICAL :: ret !! .true. on success, .false. otherwise + REAL(kind=wp), DIMENSION(8,4) :: g3d + INTEGER :: ix0,iy0,iz0,i,a,b,c + ret = .false. + ix0 = locator(x,cx) ; IF (ix0 == 0) RETURN + iy0 = locator(y,cy) ; IF (iy0 == 0) RETURN + iz0 = locator(z,cz) ; IF (iz0 == 0) RETURN + DO i=1,8 + a=ix0+MOD((i-1),2) ; g3d(i,1) = cx(a) + b=iy0+MOD((i-1)/2,2) ; g3d(i,2) = cy(b) + c=iz0+MOD((i-1)/4,2) ; g3d(i,3) = cz(c) + g3d(i,4) = cv(a,b,c) + ENDDO + res = lintc_((/x,y,z/),g3d) + ret = .true. + END FUNCTION l3d_gen_sc + + FUNCTION l4d_gen_sc(x,y,z,t,cx,cy,cz,ct,cv,locator,res) RESULT(ret) + !! Wrapper interface for 4D linear interpolation (scalar) + !! + !! @warning + !! On error, __res__ output value is undefined. + REAL(kind=wp), INTENT(in) :: x !! X coordinate of the point to interpolate + REAL(kind=wp), INTENT(in) :: y !! Y coordinate of the point to interpolate + REAL(kind=wp), INTENT(in) :: z !! Z coordinate of the point to interpolate + REAL(kind=wp), INTENT(in) :: t !! T coordinate of the point to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cx !! Tabulated function X coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cy !! Tabulated function Y coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cz !! Tabulated function Z coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:) :: ct !! Tabulated function T coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:,:,:,:) :: cv !! Tabulated function values + REAL(kind=wp), INTENT(out) :: res !! Interpolated value + PROCEDURE(locate) :: locator !! Locator function + LOGICAL :: ret !! .true. on success, .false. otherwise + REAL(kind=wp), DIMENSION(16,5) :: g4d + INTEGER :: ix0,iy0,iz0,it0 + INTEGER :: i,a,b,c,d + ret = .false. + ix0 = locator(x,cx) ; IF (ix0 == 0) RETURN + iy0 = locator(y,cy) ; IF (iy0 == 0) RETURN + iz0 = locator(z,cz) ; IF (iz0 == 0) RETURN + it0 = locator(t,ct) ; IF (it0 == 0) RETURN + DO i=1,16 + a=ix0+MOD((i-1),2) ; g4d(i,1) = cx(a) + b=iy0+MOD((i-1)/2,2) ; g4d(i,2) = cy(b) + c=iz0+MOD((i-1)/4,2) ; g4d(i,3) = cz(c) + d=it0+MOD((i-1)/8,2) ; g4d(i,4) = ct(d) + g4d(i,5) = cv(a,b,c,d) + ENDDO + res = lintc_((/x,y,z,t/),g4d) + ret = .true. + END FUNCTION l4d_gen_sc + + FUNCTION l5d_gen_sc(x,y,z,t,w,cx,cy,cz,ct,cw,cv,locator,res) RESULT(ret) + !! Wrapper interface for 5D linear interpolation (scalar) + !! + !! @warning + !! On error, __res__ output value is undefined. + REAL(kind=wp), INTENT(in) :: x !! X coordinate of the point to interpolate + REAL(kind=wp), INTENT(in) :: y !! Y coordinate of the point to interpolate + REAL(kind=wp), INTENT(in) :: z !! Z coordinate of the point to interpolate + REAL(kind=wp), INTENT(in) :: t !! T coordinate of the point to interpolate + REAL(kind=wp), INTENT(in) :: w !! W coordinate of the point to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cx !! Tabulated function X coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cy !! Tabulated function Y coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cz !! Tabulated function Z coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:) :: ct !! Tabulated function T coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cw !! Tabulated function W coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:,:,:,:,:) :: cv !! Tabulated function values + REAL(kind=wp), INTENT(out) :: res !! Interpolated value + PROCEDURE(locate) :: locator !! Locator function + LOGICAL :: ret !! .true. on success, .false. otherwise + REAL(kind=wp), DIMENSION(32,6) :: g5d + INTEGER :: ix0,iy0,iz0,it0,iw0 + INTEGER :: i,a,b,c,d,e + ret = .false. + ix0 = locator(x,cx) ; IF (ix0 == 0) RETURN + iy0 = locator(y,cy) ; IF (iy0 == 0) RETURN + iz0 = locator(z,cz) ; IF (iz0 == 0) RETURN + it0 = locator(t,ct) ; IF (it0 == 0) RETURN + iw0 = locator(w,cw) ; IF (iw0 == 0) RETURN + DO i=1,32 + a=ix0+MOD((i-1),2) ; g5d(i,1) = cx(a) + b=iy0+MOD((i-1)/2,2) ; g5d(i,2) = cy(b) + c=iz0+MOD((i-1)/4,2) ; g5d(i,3) = cz(c) + d=it0+MOD((i-1)/8,2) ; g5d(i,4) = ct(d) + e=iw0+MOD((i-1)/16,2) ; g5d(i,5) = cw(e) + g5d(i,6) = cv(a,b,c,d,e) + ENDDO + res = lintc_((/x,y,z,t,w/),g5d) + ret = .true. + END FUNCTION l5d_gen_sc + + ! HARD-CODED versions + ! ------------------- + + FUNCTION hdcdl1d_gen_sc(x,cx,cv,locator,res) RESULT(ret) + !! Hard-coded 1D linear interpolation (scalar) + !! + !! @warning + !! On error, __res__ output value is undefined. + REAL(kind=wp), INTENT(in) :: x !! X coordinate of the point to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cx !! Tabulated function X coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cv !! Tabulated function values + REAL(kind=wp), INTENT(out) :: res !! Interpolated value + PROCEDURE(locate) :: locator !! Locator function + LOGICAL :: ret !! .true. on success, .false. otherwise + REAL(kind=wp) :: xd + INTEGER :: ix0,ix1 + ret = .false. + ix0 = locator(x,cx) ; IF (ix0 == 0) RETURN + ix1 = ix0+1 + xd = (x-cx(ix0))/(cx(ix1)-cx(ix0)) + res = cv(ix0)*(1d0-xd)+cv(ix1)*xd + ret = .true. + END FUNCTION hdcdl1d_gen_sc + + FUNCTION hdcdl2d_gen_sc(x,y,cx,cy,cv,locator,res) RESULT(ret) + !! Hard-coded 2D linear interpolation (scalar) + !! + !! @warning + !! On error, __res__ output value is undefined. + REAL(kind=wp), INTENT(in) :: x !! X coordinate of the point to interpolate + REAL(kind=wp), INTENT(in) :: y !! Y coordinate of the point to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cx !! Tabulated function X coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cy !! Tabulated function Y coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:,:) :: cv !! Tabulated function values + REAL(kind=wp), INTENT(out) :: res !! Interpolated value + PROCEDURE(locate) :: locator !! Locator function + LOGICAL :: ret !! .true. on success, .false. otherwise + REAL(kind=wp) :: xd,yd + REAL(kind=wp) :: f0,f1 + INTEGER :: ix0,iy0,ix1,iy1 + ret = .false. + ix0 = locator(x,cx) ; IF (ix0 == 0) RETURN + iy0 = locator(y,cy) ; IF (iy0 == 0) RETURN + ix1 = ix0 + 1 ; iy1 = iy0 + 1 + xd = (x-cx(ix0))/(cx(ix1)-cx(ix0)) + yd = (y-cy(iy0))/(cy(iy1)-cy(iy0)) + f0 = cv(ix0,iy0)*(1d0-xd)+cv(ix1,iy0)*xd + f1 = cv(ix0,iy1)*(1d0-xd)+cv(ix1,iy1)*xd + res = f0*(1d0-yd)+f1*yd + ret = .true. + END FUNCTION hdcdl2d_gen_sc + + FUNCTION hdcdl3d_gen_sc(x,y,z,cx,cy,cz,cv,locator,res) RESULT(ret) + !! Hard-coded 3D linear interpolation (scalar) + !! + !! @warning + !! On error, __res__ output value is undefined. + REAL(kind=wp), INTENT(in) :: x !! X coordinate of the point to interpolate + REAL(kind=wp), INTENT(in) :: y !! Y coordinate of the point to interpolate + REAL(kind=wp), INTENT(in) :: z !! Z coordinate of the point to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cx !! Tabulated function X coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cy !! Tabulated function Y coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cz !! Tabulated function Z coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:,:,:) :: cv !! Tabulated function values + REAL(kind=wp), INTENT(out) :: res !! Interpolated value + PROCEDURE(locate) :: locator !! Locator function + LOGICAL :: ret !! .true. on success, .false. otherwise + REAL(kind=wp) :: xd,yd,zd + REAL(kind=wp) :: f00,f10,f01,f11,f0,f1 + INTEGER :: ix0,iy0,iz0,ix1,iy1,iz1 + ret = .false. + ix0 = locator(x,cx) ; IF (ix0 == 0) RETURN + iy0 = locator(y,cy) ; IF (iy0 == 0) RETURN + iz0 = locator(z,cz) ; IF (iz0 == 0) RETURN + ix1=ix0+1 ; iy1=iy0+1 ; iz1=iz0+1 + xd = (x-cx(ix0))/(cx(ix1)-cx(ix0)) + yd = (y-cy(iy0))/(cy(iy1)-cy(iy0)) + zd = (z-cz(iz0))/(cz(iz1)-cz(iz0)) + + f00 = cv(ix0,iy0,iz0)*(1d0-xd)+cv(ix1,iy0,iz0)*xd + f10 = cv(ix0,iy1,iz0)*(1d0-xd)+cv(ix1,iy1,iz0)*xd + f01 = cv(ix0,iy0,iz1)*(1d0-xd)+cv(ix1,iy0,iz1)*xd + f11 = cv(ix0,iy1,iz1)*(1d0-xd)+cv(ix1,iy1,iz1)*xd + + f0 = f00 *(1d0-yd)+f10*yd + f1 = f00 *(1d0-yd)+f10*yd + + res = f0*(1d0-zd)+f1*zd + ret = .true. + END FUNCTION hdcdl3d_gen_sc + + FUNCTION hdcdl4d_gen_sc(x,y,z,t,cx,cy,cz,ct,cv,locator,res) RESULT(ret) + !! Hard-coded 4D linear interpolation (scalar) + !! + !! @warning + !! On error, __res__ output value is undefined. + REAL(kind=wp), INTENT(in) :: x !! X coordinate of the point to interpolate + REAL(kind=wp), INTENT(in) :: y !! Y coordinate of the point to interpolate + REAL(kind=wp), INTENT(in) :: z !! Z coordinate of the point to interpolate + REAL(kind=wp), INTENT(in) :: t !! T coordinate of the point to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cx !! Tabulated function X coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cy !! Tabulated function Y coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cz !! Tabulated function Z coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:) :: ct !! Tabulated function T coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:,:,:,:) :: cv !! Tabulated function values + REAL(kind=wp), INTENT(out) :: res !! Interpolated value + PROCEDURE(locate) :: locator !! Locator function + LOGICAL :: ret !! .true. on success, .false. otherwise + REAL(kind=wp) :: xd,yd,zd,td + REAL(kind=wp) :: f000,f100,f010,f110,f001,f101,f011,f111, & + f00,f10,f01,f11,f0,f1 + INTEGER :: ix0,iy0,iz0,it0,ix1,iy1,iz1,it1 + ret = .false. + ix0 = locator(x,cx) ; IF (ix0 == 0) RETURN + iy0 = locator(y,cy) ; IF (iy0 == 0) RETURN + iz0 = locator(z,cz) ; IF (iz0 == 0) RETURN + it0 = locator(t,ct) ; IF (it0 == 0) RETURN + + ix1=ix0+1 ; iy1=iy0+1 ; iz1=iz0+1 ; it1=it0+1 + xd = (x-cx(ix0))/(cx(ix1)-cx(ix0)) + yd = (y-cy(iy0))/(cy(iy1)-cy(iy0)) + zd = (z-cz(iz0))/(cz(iz1)-cz(iz0)) + td = (t-ct(it0))/(ct(it1)-ct(it0)) + + f000 = cv(ix0,iy0,iz0,it0)*(1d0-xd)+cv(ix1,iy0,iz0,it0)*xd + f100 = cv(ix0,iy1,iz0,it0)*(1d0-xd)+cv(ix1,iy1,iz0,it0)*xd + f010 = cv(ix0,iy0,iz1,it0)*(1d0-xd)+cv(ix1,iy0,iz1,it0)*xd + f110 = cv(ix0,iy1,iz1,it0)*(1d0-xd)+cv(ix1,iy1,iz1,it0)*xd + f001 = cv(ix0,iy0,iz0,it1)*(1d0-xd)+cv(ix1,iy0,iz0,it1)*xd + f101 = cv(ix0,iy1,iz0,it1)*(1d0-xd)+cv(ix1,iy1,iz0,it1)*xd + f011 = cv(ix0,iy0,iz1,it1)*(1d0-xd)+cv(ix1,iy0,iz1,it1)*xd + f111 = cv(ix0,iy1,iz1,it1)*(1d0-xd)+cv(ix1,iy1,iz1,it1)*xd + + f00 = f000*(1d0-yd)+f100*yd + f10 = f010*(1d0-yd)+f110*yd + f01 = f001*(1d0-yd)+f101*yd + f11 = f011*(1d0-yd)+f111*yd + + f0 = f00 *(1d0-zd)+f10*zd + f1 = f01 *(1d0-zd)+f11*zd + + res = f0*(1d0-td)+f1*td + ret = .true. + END FUNCTION hdcdl4d_gen_sc + + FUNCTION hdcdl5d_gen_sc(x,y,z,t,w,cx,cy,cz,ct,cw,cv,locator,res) RESULT(ret) + !! Hard-coded 5D linear interpolation (scalar) + !! + !! @warning + !! On error, __res__ output value is undefined. + REAL(kind=wp), INTENT(in) :: x !! X coordinate of the point to interpolate + REAL(kind=wp), INTENT(in) :: y !! Y coordinate of the point to interpolate + REAL(kind=wp), INTENT(in) :: z !! Z coordinate of the point to interpolate + REAL(kind=wp), INTENT(in) :: t !! T coordinate of the point to interpolate + REAL(kind=wp), INTENT(in) :: w !! W coordinate of the point to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cx !! Tabulated function X coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cy !! Tabulated function Y coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cz !! Tabulated function Z coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:) :: ct !! Tabulated function T coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cw !! Tabulated function W coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:,:,:,:,:) :: cv !! Tabulated function values + REAL(kind=wp), INTENT(out) :: res !! Interpolated value + PROCEDURE(locate) :: locator !! Locator function + LOGICAL :: ret !! .true. on success, .false. otherwise + REAL(kind=wp) :: xd,yd,zd,td,wd + REAL(kind=wp) :: f0000,f1000,f0100,f1100,f0010,f1010,f0110,f1110, & + f0001,f1001,f0101,f1101,f0011,f1011,f0111,f1111, & + f000,f100,f010,f110,f001,f101,f011,f111, & + f00,f10,f01,f11,f0,f1 + INTEGER :: ix0,iy0,iz0,it0,iw0,ix1,iy1,iz1,it1,iw1 + ret = .false. + ix0 = locator(x,cx) ; IF (ix0 == 0) RETURN + iy0 = locator(y,cy) ; IF (iy0 == 0) RETURN + iz0 = locator(z,cz) ; IF (iz0 == 0) RETURN + it0 = locator(t,ct) ; IF (it0 == 0) RETURN + iw0 = locator(w,cw) ; IF (iw0 == 0) RETURN + + ix1=ix0+1 ; iy1=iy0+1 ; iz1=iz0+1 ; it1=it0+1 ; iw1=iw0+1 + xd = (x-cx(ix0))/(cx(ix1)-cx(ix0)) + yd = (y-cy(iy0))/(cy(iy1)-cy(iy0)) + zd = (z-cz(iz0))/(cz(iz1)-cz(iz0)) + td = (t-ct(it0))/(ct(it1)-ct(it0)) + wd = (w-cw(iw0))/(cw(iw1)-cw(iw0)) + + f0000 = cv(ix0,iy0,iz0,it0,iw0)*(1d0-xd)+cv(ix1,iy0,iz0,it0,iw0)*xd + f1000 = cv(ix0,iy1,iz0,it0,iw0)*(1d0-xd)+cv(ix0,iy1,iz0,it0,iw0)*xd + f0100 = cv(ix0,iy0,iz1,it0,iw0)*(1d0-xd)+cv(ix1,iy0,iz1,it0,iw0)*xd + f1100 = cv(ix0,iy1,iz1,it0,iw0)*(1d0-xd)+cv(ix1,iy1,iz1,it0,iw0)*xd + f0010 = cv(ix0,iy0,iz0,it1,iw0)*(1d0-xd)+cv(ix1,iy0,iz0,it1,iw0)*xd + f1010 = cv(ix0,iy1,iz0,it1,iw0)*(1d0-xd)+cv(ix1,iy1,iz0,it1,iw0)*xd + f0110 = cv(ix0,iy0,iz1,it1,iw0)*(1d0-xd)+cv(ix1,iy0,iz1,it1,iw0)*xd + f1110 = cv(ix0,iy1,iz1,it1,iw0)*(1d0-xd)+cv(ix1,iy1,iz1,it1,iw0)*xd + f0001 = cv(ix0,iy0,iz0,it0,iw1)*(1d0-xd)+cv(ix1,iy0,iz0,it0,iw1)*xd + f1001 = cv(ix0,iy1,iz0,it0,iw1)*(1d0-xd)+cv(ix0,iy1,iz0,it0,iw1)*xd + f0101 = cv(ix0,iy0,iz1,it0,iw1)*(1d0-xd)+cv(ix1,iy0,iz1,it0,iw1)*xd + f1101 = cv(ix0,iy1,iz1,it0,iw1)*(1d0-xd)+cv(ix1,iy1,iz1,it0,iw1)*xd + f0011 = cv(ix0,iy0,iz0,it1,iw1)*(1d0-xd)+cv(ix1,iy0,iz0,it1,iw1)*xd + f1011 = cv(ix0,iy1,iz0,it1,iw1)*(1d0-xd)+cv(ix1,iy1,iz0,it1,iw1)*xd + f0111 = cv(ix0,iy0,iz1,it1,iw1)*(1d0-xd)+cv(ix1,iy0,iz1,it1,iw1)*xd + f1111 = cv(ix0,iy1,iz1,it1,iw1)*(1d0-xd)+cv(ix1,iy1,iz1,it1,iw1)*xd + + f000 = f0000*(1d0-yd) + f1000*yd + f100 = f0100*(1d0-yd) + f1100*yd + f010 = f0010*(1d0-yd) + f1010*yd + f110 = f0110*(1d0-yd) + f1110*yd + f101 = f0101*(1d0-yd) + f1101*yd + f011 = f0011*(1d0-yd) + f1011*yd + f111 = f0111*(1d0-yd) + f1111*yd + + f00 = f000*(1d0-zd)+f100*zd + f10 = f010*(1d0-zd)+f110*zd + f01 = f001*(1d0-zd)+f101*zd + f11 = f011*(1d0-zd)+f111*zd + + f0 = f00 *(1d0-td)+f10*td + f1 = f01 *(1d0-td)+f11*td + + res = f0*(1d0-wd)+f1*wd + ret = .true. + END FUNCTION hdcdl5d_gen_sc + + !-------------------- + ! VECTORIZED VERSIONS + !-------------------- + + ! GENERIC versions + ! ---------------- + + FUNCTION l1d_gen_ve(x,cx,cv,locator,res) RESULT(ret) + !! Wrapper interface for 1D linear interpolation (vector) + !! + !! @warning + !! On error, __res__ output vector is undefined (i.e. not allocated). + REAL(kind=wp), INTENT(in), DIMENSION(:) :: x !! X coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cx !! Tabulated function X coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cv !! Tabulated function values + REAL(kind=wp), INTENT(out), DIMENSION(:), ALLOCATABLE :: res !! Interpolated values + PROCEDURE(locate) :: locator !! Locator function + LOGICAL :: ret !! .true. on success, .false. otherwise + REAL(kind=wp), DIMENSION(2,2) :: g1d + INTEGER :: n,j,i,ix + ret = .false. + n = SIZE(x) ; ALLOCATE(res(n)) + DO j=1,n + ix = locator(x(j),cx) + IF (ix == 0) THEN + DEALLOCATE(res) ; RETURN + ENDIF + DO i=0,1 + g1d(i+1,1) = cx(ix+i) + g1d(i+1,2) = cv(ix+i) + ENDDO + res(j) = lintc_((/x(j)/),g1d) + ENDDO + ret = .true. + END FUNCTION l1d_gen_ve + + FUNCTION l2d_gen_ve(x,y,cx,cy,cv,locator,res) RESULT(ret) + !! Wrapper interface for 2D linear interpolation (vector) + !! + !! @warning + !! On error, __res__ output vector is undefined (i.e. not allocated). + REAL(kind=wp), INTENT(in), DIMENSION(:) :: x !! X coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: y !! Y coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cx !! Tabulated function X coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cy !! Tabulated function Y coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:,:) :: cv !! Tabulated function values + REAL(kind=wp), INTENT(out), DIMENSION(:), ALLOCATABLE :: res !! Interpolated values + PROCEDURE(locate) :: locator !! Locator function + LOGICAL :: ret !! .true. on success, .false. otherwise + REAL(kind=wp), DIMENSION(4,3) :: g2d + INTEGER :: n,j,ix0,iy0,i,a,b + ret = .false. + n = SIZE(x) ; ALLOCATE(res(n)) + DO j=1,n + ix0 = locator(x(j),cx) + iy0 = locator(y(j),cy) + IF (ix0 == 0 .OR. iy0 == 0) THEN + DEALLOCATE(res) ; RETURN + ENDIF + DO i=1,4 + a=ix0+MOD((i-1),2) ; g2d(i,1) = cx(a) + b=iy0+MOD((i-1)/2,2) ; g2d(i,2) = cy(b) + g2d(i,3) = cv(a,b) + ENDDO + res(j) = lintc_((/x(j),y(j)/),g2d) + ENDDO + ret = .true. + END FUNCTION l2d_gen_ve + + FUNCTION l3d_gen_ve(x,y,z,cx,cy,cz,cv,locator,res) RESULT(ret) + !! Wrapper interface for 3D linear interpolation (vector) + !! + !! @warning + !! On error, __res__ output vector is undefined (i.e. not allocated). + REAL(kind=wp), INTENT(in), DIMENSION(:) :: x !! X coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: y !! Y coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: z !! Z coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cx !! Tabulated function X coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cy !! Tabulated function Y coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cz !! Tabulated function Z coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:,:,:) :: cv !! Tabulated function values + REAL(kind=wp), INTENT(out), DIMENSION(:), ALLOCATABLE :: res !! Interpolated values + PROCEDURE(locate) :: locator !! Locator function + LOGICAL :: ret !! .true. on success, .false. otherwise + REAL(kind=wp), DIMENSION(8,4) :: g3d + INTEGER :: ix0,iy0,iz0 + INTEGER :: n,j,i,a,b,c + ret = .false. + n = SIZE(x) ; ALLOCATE(res(n)) + DO j=1,n + ix0 = locator(x(j),cx) + iy0 = locator(y(j),cy) + iz0 = locator(z(j),cz) + IF (ix0 == 0 .OR. iy0 == 0 .OR. iz0 == 0) THEN + DEALLOCATE(res) ; RETURN + ENDIF + DO i=1,8 + a=ix0+MOD((i-1),2) ; g3d(i,1) = cx(a) + b=iy0+MOD((i-1)/2,2) ; g3d(i,2) = cy(b) + c=iz0+MOD((i-1)/4,2) ; g3d(i,3) = cz(c) + g3d(i,4) = cv(a,b,c) + ENDDO + res(j) = lintc_((/x(j),y(j),z(j)/),g3d) + ENDDO + ret = .true. + END FUNCTION l3d_gen_ve + + FUNCTION l4d_gen_ve(x,y,z,t,cx,cy,cz,ct,cv,locator,res) RESULT(ret) + !! Wrapper interface for 4D linear interpolation (vector) + !! + !! @warning + !! On error, __res__ output vector is undefined (i.e. not allocated). + REAL(kind=wp), INTENT(in), DIMENSION(:) :: x !! X coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: y !! Y coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: z !! Z coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: t !! T coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cx !! Tabulated function X coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cy !! Tabulated function Y coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cz !! Tabulated function Z coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:) :: ct !! Tabulated function T coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:,:,:,:) :: cv !! Tabulated function values + REAL(kind=wp), INTENT(out), DIMENSION(:), ALLOCATABLE :: res !! Interpolated values + PROCEDURE(locate) :: locator !! Locator function + LOGICAL :: ret !! .true. on success, .false. otherwise + REAL(kind=wp), DIMENSION(16,5) :: g4d + INTEGER :: ix0,iy0,iz0,it0 + INTEGER :: n,j,i,a,b,c,d + ret = .false. + n = SIZE(x) ; ALLOCATE(res(n)) + DO j=1,n + ix0 = locator(x(j),cx) + iy0 = locator(y(j),cy) + iz0 = locator(z(j),cz) + it0 = locator(t(j),ct) + IF (ix0 == 0 .OR. iy0 == 0 .OR. iz0 == 0 .OR. it0 == 0) THEN + DEALLOCATE(res) ; RETURN + ENDIF + DO i=1,16 + a=ix0+MOD((i-1),2) ; g4d(i,1) = cx(a) + b=iy0+MOD((i-1)/2,2) ; g4d(i,2) = cy(b) + c=iz0+MOD((i-1)/4,2) ; g4d(i,3) = cz(c) + d=it0+MOD((i-1)/8,2) ; g4d(i,4) = ct(d) + g4d(i,5) = cv(a,b,c,d) + ENDDO + res(j) = lintc_((/x(j),y(j),z(j),t(j)/),g4d) + ENDDO + ret = .true. + END FUNCTION l4d_gen_ve + + FUNCTION l5d_gen_ve(x,y,z,t,w,cx,cy,cz,ct,cw,cv,locator,res) RESULT(ret) + !! Wrapper interface for 5D linear interpolation (vector) + !! + !! @warning + !! On error, __res__ output vector is undefined (i.e. not allocated). + REAL(kind=wp), INTENT(in), DIMENSION(:) :: x !! X coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: y !! Y coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: z !! Z coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: t !! T coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: w !! W coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cx !! Tabulated function X coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cy !! Tabulated function Y coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cz !! Tabulated function Z coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:) :: ct !! Tabulated function T coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cw !! Tabulated function W coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:,:,:,:,:) :: cv !! Tabulated function values + REAL(kind=wp), INTENT(out), DIMENSION(:), ALLOCATABLE :: res !! Interpolated values + PROCEDURE(locate) :: locator !! Locator function + LOGICAL :: ret !! .true. on success, .false. otherwise + REAL(kind=wp), DIMENSION(32,6) :: g5d + INTEGER :: ix0,iy0,iz0,it0,iw0 + INTEGER :: n,j,i,a,b,c,d,e + ret = .false. + n = SIZE(x) ; ALLOCATE(res(n)) + DO j=1,n + ix0 = locator(x(j),cx) + iy0 = locator(y(j),cy) + iz0 = locator(z(j),cz) + it0 = locator(t(j),ct) + iw0 = locator(w(j),cw) + IF (ix0 == 0 .OR. iy0 == 0 .OR. iz0 == 0 .OR. it0 == 0 .OR. iw0 == 0) THEN + DEALLOCATE(res) ; RETURN + ENDIF + DO i=1,32 + a=ix0+MOD((i-1),2) ; g5d(i,1) = cx(a) + b=iy0+MOD((i-1)/2,2) ; g5d(i,2) = cy(b) + c=iz0+MOD((i-1)/4,2) ; g5d(i,3) = cz(c) + d=it0+MOD((i-1)/8,2) ; g5d(i,4) = ct(d) + e=iw0+MOD((i-1)/16,2) ; g5d(i,5) = cw(e) + g5d(i,6) = cv(a,b,c,d,e) + ENDDO + res(j) = lintc_((/x,y,z,t,w/),g5d) + ENDDO + ret = .true. + END FUNCTION l5d_gen_ve + + ! HARD-CODED versions + ! ------------------- + + FUNCTION hdcdl1d_gen_ve(x,cx,cv,locator,res) RESULT(ret) + !! Hard-coded 1D linear interpolation (vector) + !! + !! @warning + !! On error, __res__ output vector is undefined (i.e. not allocated). + REAL(kind=wp), INTENT(in), DIMENSION(:) :: x !! X coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cx !! Tabulated function X coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cv !! Tabulated function values + REAL(kind=wp), INTENT(out), DIMENSION(:), ALLOCATABLE :: res !! Interpolated values + PROCEDURE(locate) :: locator !! Locator function + LOGICAL :: ret !! .true. on success, .false. otherwise + REAL(kind=wp) :: xd + INTEGER :: ix0,ix1 + INTEGER :: n,j + ret = .false. + n = SIZE(x) ; ALLOCATE(res(n)) + DO j=1,n + ix0 = locator(x(j),cx) + IF (ix0 == 0) THEN + DEALLOCATE(res) ; RETURN + ENDIF + ix1 = ix0+1 + xd = (x(j)-cx(ix0))/(cx(ix1)-cx(ix0)) + res(j) = cv(ix0)*(1d0-xd)+cv(ix1)*xd + ENDDO + ret = .true. + END FUNCTION hdcdl1d_gen_ve + + FUNCTION hdcdl2d_gen_ve(x,y,cx,cy,cv,locator,res) RESULT(ret) + !! Hard-coded 2D linear interpolation (vector) + !! + !! @warning + !! On error, __res__ output vector is undefined (i.e. not allocated). + REAL(kind=wp), INTENT(in), DIMENSION(:) :: x !! X coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: y !! Y coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cx !! Tabulated function X coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cy !! Tabulated function Y coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:,:) :: cv !! Tabulated function values + REAL(kind=wp), INTENT(out), DIMENSION(:), ALLOCATABLE :: res !! Interpolated values + PROCEDURE(locate) :: locator !! Locator function + LOGICAL :: ret !! .true. on success, .false. otherwise + REAL(kind=wp) :: xd,yd + REAL(kind=wp) :: f0,f1 + INTEGER :: ix0,iy0,ix1,iy1 + INTEGER :: n,j + ret = .false. + n = SIZE(x) ; ALLOCATE(res(n)) + DO j=1,n + ix0 = locator(x(j),cx) + iy0 = locator(y(j),cy) + IF (ix0 == 0 .OR. iy0 == 0) THEN + DEALLOCATE(res) ; RETURN + ENDIF + ix1 = ix0 + 1 ; iy1 = iy0 + 1 + xd = (x(j)-cx(ix0))/(cx(ix1)-cx(ix0)) + yd = (y(j)-cy(iy0))/(cy(iy1)-cy(iy0)) + f0 = cv(ix0,iy0)*(1d0-xd)+cv(ix1,iy0)*xd + f1 = cv(ix0,iy1)*(1d0-xd)+cv(ix1,iy1)*xd + res(j) = f0*(1d0-yd)+f1*yd + ENDDO + ret = .true. + END FUNCTION hdcdl2d_gen_ve + + FUNCTION hdcdl3d_gen_ve(x,y,z,cx,cy,cz,cv,locator,res) RESULT(ret) + !! Hard-coded 3D linear interpolation (vector) + !! + !! @warning + !! On error, __res__ output vector is undefined (i.e. not allocated). + REAL(kind=wp), INTENT(in), DIMENSION(:) :: x !! X coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: y !! Y coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: z !! Z coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cx !! Tabulated function X coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cy !! Tabulated function Y coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cz !! Tabulated function Z coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:,:,:) :: cv !! Tabulated function values + REAL(kind=wp), INTENT(out), DIMENSION(:), ALLOCATABLE :: res !! Interpolated values + PROCEDURE(locate) :: locator !! Locator function + LOGICAL :: ret !! .true. on success, .false. otherwise + REAL(kind=wp) :: xd,yd,zd + REAL(kind=wp) :: f00,f10,f01,f11,f0,f1 + INTEGER :: ix0,iy0,iz0,ix1,iy1,iz1 + INTEGER :: n,j + ret = .false. + n = SIZE(x) ; ALLOCATE(res(n)) + DO j=1,n + ix0 = locator(x(j),cx) + iy0 = locator(y(j),cy) + iz0 = locator(z(j),cz) + IF (ix0 == 0 .OR. iy0 == 0 .OR. iz0 == 0) THEN + DEALLOCATE(res) ; RETURN + ENDIF + ix1=ix0+1 ; iy1=iy0+1 ; iz1=iz0+1 + xd = (x(j)-cx(ix0))/(cx(ix1)-cx(ix0)) + yd = (y(j)-cy(iy0))/(cy(iy1)-cy(iy0)) + zd = (z(j)-cz(iz0))/(cz(iz1)-cz(iz0)) + + f00 = cv(ix0,iy0,iz0)*(1d0-xd)+cv(ix1,iy0,iz0)*xd + f10 = cv(ix0,iy1,iz0)*(1d0-xd)+cv(ix1,iy1,iz0)*xd + f01 = cv(ix0,iy0,iz1)*(1d0-xd)+cv(ix1,iy0,iz1)*xd + f11 = cv(ix0,iy1,iz1)*(1d0-xd)+cv(ix1,iy1,iz1)*xd + + f0 = f00 *(1d0-yd)+f10*yd + f1 = f00 *(1d0-yd)+f10*yd + + res(j) = f0*(1d0-zd)+f1*zd + ENDDO + ret = .true. + END FUNCTION hdcdl3d_gen_ve + + FUNCTION hdcdl4d_gen_ve(x,y,z,t,cx,cy,cz,ct,cv,locator,res) RESULT(ret) + !! Hard-coded 4D linear interpolation (vector) + !! + !! @warning + !! On error, __res__ output vector is undefined (i.e. not allocated). + REAL(kind=wp), INTENT(in), DIMENSION(:) :: x !! X coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: y !! Y coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: z !! Z coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: t !! T coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cx !! Tabulated function X coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cy !! Tabulated function Y coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cz !! Tabulated function Z coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:) :: ct !! Tabulated function T coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:,:,:,:) :: cv !! Tabulated function values + REAL(kind=wp), INTENT(out), DIMENSION(:), ALLOCATABLE :: res !! Interpolated values + PROCEDURE(locate) :: locator !! Locator function + LOGICAL :: ret !! .true. on success, .false. otherwise + REAL(kind=wp) :: xd,yd,zd,td + REAL(kind=wp) :: f000,f100,f010,f110,f001,f101,f011,f111, & + f00,f10,f01,f11,f0,f1 + INTEGER :: ix0,iy0,iz0,it0,ix1,iy1,iz1,it1 + INTEGER :: n,j + ret = .false. + n = SIZE(x) ; ALLOCATE(res(n)) + DO j=1,n + ix0 = locator(x(j),cx) + iy0 = locator(y(j),cy) + iz0 = locator(z(j),cz) + it0 = locator(t(j),ct) + IF (ix0 == 0 .OR. iy0 == 0 .OR. iz0 == 0 .OR. it0 == 0) THEN + DEALLOCATE(res) ; RETURN + ENDIF + ix1=ix0+1 ; iy1=iy0+1 ; iz1=iz0+1 ; it1=it0+1 + xd = (x(j)-cx(ix0))/(cx(ix1)-cx(ix0)) + yd = (y(j)-cy(iy0))/(cy(iy1)-cy(iy0)) + zd = (z(j)-cz(iz0))/(cz(iz1)-cz(iz0)) + td = (t(j)-ct(it0))/(ct(it1)-ct(it0)) + + f000 = cv(ix0,iy0,iz0,it0)*(1d0-xd)+cv(ix1,iy0,iz0,it0)*xd + f100 = cv(ix0,iy1,iz0,it0)*(1d0-xd)+cv(ix1,iy1,iz0,it0)*xd + f010 = cv(ix0,iy0,iz1,it0)*(1d0-xd)+cv(ix1,iy0,iz1,it0)*xd + f110 = cv(ix0,iy1,iz1,it0)*(1d0-xd)+cv(ix1,iy1,iz1,it0)*xd + f001 = cv(ix0,iy0,iz0,it1)*(1d0-xd)+cv(ix1,iy0,iz0,it1)*xd + f101 = cv(ix0,iy1,iz0,it1)*(1d0-xd)+cv(ix1,iy1,iz0,it1)*xd + f011 = cv(ix0,iy0,iz1,it1)*(1d0-xd)+cv(ix1,iy0,iz1,it1)*xd + f111 = cv(ix0,iy1,iz1,it1)*(1d0-xd)+cv(ix1,iy1,iz1,it1)*xd + + f00 = f000*(1d0-yd)+f100*yd + f10 = f010*(1d0-yd)+f110*yd + f01 = f001*(1d0-yd)+f101*yd + f11 = f011*(1d0-yd)+f111*yd + + f0 = f00 *(1d0-zd)+f10*zd + f1 = f01 *(1d0-zd)+f11*zd + + res(j) = f0*(1d0-td)+f1*td + ENDDO + ret = .true. + END FUNCTION hdcdl4d_gen_ve + + FUNCTION hdcdl5d_gen_ve(x,y,z,t,w,cx,cy,cz,ct,cw,cv,locator,res) RESULT(ret) + !! Hard-coded 5D linear interpolation (vector) + !! + !! @warning + !! On error, __res__ output vector is undefined (i.e. not allocated). + REAL(kind=wp), INTENT(in), DIMENSION(:) :: x !! X coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: y !! Y coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: z !! Z coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: t !! T coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: w !! W coordinate of the points to interpolate + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cx !! Tabulated function X coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cy !! Tabulated function Y coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cz !! Tabulated function Z coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:) :: ct !! Tabulated function T coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:) :: cw !! Tabulated function W coordinates + REAL(kind=wp), INTENT(in), DIMENSION(:,:,:,:,:) :: cv !! Tabulated function values + REAL(kind=wp), INTENT(out), DIMENSION(:), ALLOCATABLE :: res !! Interpolated values + PROCEDURE(locate) :: locator !! Locator function + LOGICAL :: ret !! .true. on success, .false. otherwise + REAL(kind=wp) :: xd,yd,zd,td,wd + REAL(kind=wp) :: f0000,f1000,f0100,f1100,f0010,f1010,f0110,f1110, & + f0001,f1001,f0101,f1101,f0011,f1011,f0111,f1111, & + f000,f100,f010,f110,f001,f101,f011,f111, & + f00,f10,f01,f11,f0,f1 + INTEGER :: ix0,iy0,iz0,it0,iw0,ix1,iy1,iz1,it1,iw1 + INTEGER :: n,j + ret = .false. + n = SIZE(x) ; ALLOCATE(res(n)) + DO j=1,n + ix0 = locator(x(j),cx) + iy0 = locator(y(j),cy) + iz0 = locator(z(j),cz) + it0 = locator(t(j),ct) + iw0 = locator(w(j),cw) + IF (ix0 == 0 .OR. iy0 == 0 .OR. iz0 == 0 .OR. it0 == 0 .OR. iw0 == 0) THEN + DEALLOCATE(res) ; RETURN + ENDIF + ix1=ix0+1 ; iy1=iy0+1 ; iz1=iz0+1 ; + xd = (x(j)-cx(ix0))/(cx(ix1)-cx(ix0)) + yd = (y(j)-cy(iy0))/(cy(iy1)-cy(iy0)) + zd = (z(j)-cz(iz0))/(cz(iz1)-cz(iz0)) + td = (t(j)-ct(it0))/(ct(it1)-ct(it0)) + wd = (w(j)-cw(it0))/(cw(it1)-cw(it0)) + + f0000 = cv(ix0,iy0,iz0,it0,iw0)*(1d0-xd)+cv(ix1,iy0,iz0,it0,iw0)*xd + f1000 = cv(ix0,iy1,iz0,it0,iw0)*(1d0-xd)+cv(ix0,iy1,iz0,it0,iw0)*xd + f0100 = cv(ix0,iy0,iz1,it0,iw0)*(1d0-xd)+cv(ix1,iy0,iz1,it0,iw0)*xd + f1100 = cv(ix0,iy1,iz1,it0,iw0)*(1d0-xd)+cv(ix1,iy1,iz1,it0,iw0)*xd + f0010 = cv(ix0,iy0,iz0,it1,iw0)*(1d0-xd)+cv(ix1,iy0,iz0,it1,iw0)*xd + f1010 = cv(ix0,iy1,iz0,it1,iw0)*(1d0-xd)+cv(ix1,iy1,iz0,it1,iw0)*xd + f0110 = cv(ix0,iy0,iz1,it1,iw0)*(1d0-xd)+cv(ix1,iy0,iz1,it1,iw0)*xd + f1110 = cv(ix0,iy1,iz1,it1,iw0)*(1d0-xd)+cv(ix1,iy1,iz1,it1,iw0)*xd + f0001 = cv(ix0,iy0,iz0,it0,iw1)*(1d0-xd)+cv(ix1,iy0,iz0,it0,iw1)*xd + f1001 = cv(ix0,iy1,iz0,it0,iw1)*(1d0-xd)+cv(ix0,iy1,iz0,it0,iw1)*xd + f0101 = cv(ix0,iy0,iz1,it0,iw1)*(1d0-xd)+cv(ix1,iy0,iz1,it0,iw1)*xd + f1101 = cv(ix0,iy1,iz1,it0,iw1)*(1d0-xd)+cv(ix1,iy1,iz1,it0,iw1)*xd + f0011 = cv(ix0,iy0,iz0,it1,iw1)*(1d0-xd)+cv(ix1,iy0,iz0,it1,iw1)*xd + f1011 = cv(ix0,iy1,iz0,it1,iw1)*(1d0-xd)+cv(ix1,iy1,iz0,it1,iw1)*xd + f0111 = cv(ix0,iy0,iz1,it1,iw1)*(1d0-xd)+cv(ix1,iy0,iz1,it1,iw1)*xd + f1111 = cv(ix0,iy1,iz1,it1,iw1)*(1d0-xd)+cv(ix1,iy1,iz1,it1,iw1)*xd + + f000 = f0000*(1d0-yd) + f1000*yd + f100 = f0100*(1d0-yd) + f1100*yd + f010 = f0010*(1d0-yd) + f1010*yd + f110 = f0110*(1d0-yd) + f1110*yd + f101 = f0101*(1d0-yd) + f1101*yd + f011 = f0011*(1d0-yd) + f1011*yd + f111 = f0111*(1d0-yd) + f1111*yd + + f00 = f000*(1d0-zd)+f100*zd + f10 = f010*(1d0-zd)+f110*zd + f01 = f001*(1d0-zd)+f101*zd + f11 = f011*(1d0-zd)+f111*zd + + f0 = f00 *(1d0-td)+f10*td + f1 = f01 *(1d0-td)+f11*td + + res(j) = f0*(1d0-wd)+f1*wd + ENDDO + ret = .true. + END FUNCTION hdcdl5d_gen_ve + +END MODULE LINTGEN Index: trunk/LMDZ.TITAN/libf/muphytitan/locators.f90 =================================================================== --- trunk/LMDZ.TITAN/libf/muphytitan/locators.f90 (revision 1793) +++ trunk/LMDZ.TITAN/libf/muphytitan/locators.f90 (revision 1793) @@ -0,0 +1,161 @@ +! Copyright Université Reims Champagnne-Ardenne (2010-2015) +! contributor: Jérémie Burgalat +! +! jeremie.burgalat@univ-reims.fr +! +! This software is a computer program whose purpose is to compute multi-variate +! linear interpolation. +! +! This software is governed by the CeCILL-B license under French law and +! abiding by the rules of distribution of free software. You can use, +! modify and/ or redistribute the software under the terms of the CeCILL-B +! license as circulated by CEA, CNRS and INRIA at the following URL +! "http://www.cecill.info". +! +! As a counterpart to the access to the source code and rights to copy, +! modify and redistribute granted by the license, users are provided only +! with a limited warranty and the software's author, the holder of the +! economic rights, and the successive licensors have only limited +! liability. +! +! In this respect, the user's attention is drawn to the risks associated +! with loading, using, modifying and/or developing or reproducing the +! software by the user in light of its specific status of free software, +! that may mean that it is complicated to manipulate, and that also +! therefore means that it is reserved for developers and experienced +! professionals having in-depth computer knowledge. Users are therefore +! encouraged to load and test the software's suitability as regards their +! requirements in conditions enabling the security of their systems and/or +! data to be ensured and, more generally, to use and operate it in the +! same conditions as regards security. +! +! The fact that you are presently reading this means that you have had +! knowledge of the CeCILL-B license and that you accept its terms. + +!! file: locators.f90 +!! summary: Locator functions definition file +!! author: burgalat +!! date: 2010-2014 + + +MODULE LOCATORS + !! Locator functions definition module. + !! + !! This module defines some locator functions which search value in ordered vectors (with no + !! duplicates). Two algorithms are provided : + !! + !! - The binary search algorithm. + !! - A simple algorithm for direct access assuming searched vector is regularly + !! spaced. + !! + !! All these functions satisfy the interface required for the __locator__ argument of linear + !! interpolation functions. + USE LINT_PREC + IMPLICIT NONE + + PRIVATE :: wp ! from LINT_PREC + + CONTAINS + + FUNCTION locate(value,vector) RESULT(res) + !! Basic binary search algorithm + REAL(kind=wp), INTENT(in) :: value !! Value to search + REAL(kind=wp), INTENT(in), DIMENSION(:) :: vector !! Input vector to search in + INTEGER :: res + !! Lowest subscript of the nearest value or __0__ if value is out of range. + REAL(kind=wp) :: l,u + INTEGER :: jl,jm,ju, nv + res = 0 ; nv = SIZE(vector) ; l = vector(1) ; u = vector(nv) + ! Check for out of range value + IF ((value>l.AND.value>u).OR.(value 1) + res=(ju+jl)/2 + IF (res == 0) RETURN ! should never happen + IF((u>=l).EQV.(value >= vector(res))) THEN + jl=res + ELSE + ju=res + ENDIF + ENDDO + res = jl + RETURN + END FUNCTION locate + + FUNCTION locate_ext(value,vector) RESULT(res) + !! Basic binary search algorithm with extrapolation + !! + !! The function performs the same computation than [[locators(module):locate(function)]] except + !! that if __value__ is out of range, __1__ or __SIZE(vector)-1__ is returned with respect + !! to the nearest __vector__'s extremum. + REAL(kind=wp), INTENT(in) :: value !! Value to search + REAL(kind=wp), INTENT(in), DIMENSION(:) :: vector !! Input vector to search in + INTEGER :: res !! Lowest subscript of the nearest value + REAL(kind=wp) :: l,u + INTEGER :: jl,jm,ju, nv + nv = SIZE(vector) ; l = vector(1) ; u= vector(nv) + ! Check for out of range value + IF ((value>l.AND.value>u).OR.(value ABS(u-value)) res=nv-1 + RETURN + ENDIF + ! Search in the array + jl=0 ; ju=nv+1 + DO WHILE (ju-jl > 1) + res=(ju+jl)/2 + IF (res == 0) RETURN ! should never happen + IF((u>=l).EQV.(value >= vector(res))) THEN + jl=res + ELSE + ju=res + ENDIF + ENDDO + res = jl + RETURN + END FUNCTION locate_ext + + FUNCTION locate_reg(value,vector) RESULT(res) + !! Direct subscript access locator method + !! + !! The function assumes __vector__ is regularly spaced and computes directly + !! the lowest subscript using __vector__ step increment. + REAL(kind=wp), INTENT(in) :: value !! Value to search + REAL(kind=wp), INTENT(in), DIMENSION(:) :: vector !! Input vector to search in + INTEGER :: res + !! Lowest subscript of the nearest value or __0__ if value is out of range. + INTEGER :: nv + REAL(kind=wp) :: step,l,u + res = 0 + nv = SIZE(vector) + l = vector(1) ; u= vector(nv) + IF ((value>l.AND.value>u).OR.(valuel.AND.value>u).OR.(value ABS(u-value)) res = nv -1 + RETURN + ENDIF + step = (vector(nv)-vector(1))/(nv-1.) + res = MIN(1+FLOOR((value-l)/step),nv-1) + RETURN + END FUNCTION locate_reg_ext + +END MODULE LOCATORS Index: trunk/LMDZ.TITAN/libf/muphytitan/mm_clouds.f90 =================================================================== --- trunk/LMDZ.TITAN/libf/muphytitan/mm_clouds.f90 (revision 1793) +++ trunk/LMDZ.TITAN/libf/muphytitan/mm_clouds.f90 (revision 1793) @@ -0,0 +1,737 @@ +! Copyright 2013-2015 Université de Reims Champagne-Ardenne +! Contributor: J. Burgalat (GSMA, URCA) +! email of the author : jeremie.burgalat@univ-reims.fr +! +! This software is a computer program whose purpose is to compute +! microphysics processes using a two-moments scheme. +! +! This library is governed by the CeCILL-B license under French law and +! abiding by the rules of distribution of free software. You can use, +! modify and/ or redistribute the software under the terms of the CeCILL-B +! license as circulated by CEA, CNRS and INRIA at the following URL +! "http://www.cecill.info". +! +! As a counterpart to the access to the source code and rights to copy, +! modify and redistribute granted by the license, users are provided only +! with a limited warranty and the software's author, the holder of the +! economic rights, and the successive licensors have only limited +! liability. +! +! In this respect, the user's attention is drawn to the risks associated +! with loading, using, modifying and/or developing or reproducing the +! software by the user in light of its specific status of free software, +! that may mean that it is complicated to manipulate, and that also +! therefore means that it is reserved for developers and experienced +! professionals having in-depth computer knowledge. Users are therefore +! encouraged to load and test the software's suitability as regards their +! requirements in conditions enabling the security of their systems and/or +! data to be ensured and, more generally, to use and operate it in the +! same conditions as regards security. +! +! The fact that you are presently reading this means that you have had +! knowledge of the CeCILL-B license and that you accept its terms. + +!! file: mm_clouds.f90 +!! summary: Clouds microphysics module +!! author: J. Burgalat +!! date: 2013-2015 + +MODULE MM_CLOUDS + !! Clouds microphysics module. + !! + !! The module contains all definitions of the microphysics processes related to clouds: + !! + !! - [nucleation](page/clouds.html#nucleation) + !! - [condensation](page/clouds.html#condensation) + !! - [sedimentation](page/clouds.html#sedimentation) + !! + !! + !! The interface methods always use the global variables defined in [[mm_globals(module)]] when values + !! (any kind, temperature, pressure, moments...) over the vertical grid are required. + !! Consequently, all these functions only deals with output argument which are most of the time the + !! tendencies of relevant variables on the atmospheric column. + !! + !! @note + !! Tendencies returned by public methods are always defined from __TOP__ of the atmosphere to the + !! __GROUND__. + USE MM_MPREC + USE MM_GLOBALS + USE MM_METHODS + IMPLICIT NONE + + PRIVATE + + PUBLIC :: mm_cloud_microphysics, mm_cloud_sedimentation, mm_cloud_nucond + + CONTAINS + + !============================================================================ + ! CLOUDS MICROPHYSICS INTERFACE SUBROUTINE + !============================================================================ + + SUBROUTINE mm_cloud_microphysics(dm0a,dm3a,dm0n,dm3n,dm3i,dgazs) + !! Get the evolution of moments tracers through clouds microphysics processes. + !! + !! The subroutine is a wrapper to the clouds microphysics methods. It computes the tendencies of moments + !! tracers for nucleation, condensation and sedimentation processes for the atmospheric column. + !! + !! @note + !! Both __dm3i__ and __dgazs__ are 2D-array with the vertical layers in first dimension and the number + !! of ice components in the second. + REAL(kind=mm_wp), DIMENSION(:), INTENT(out) :: dm0a + !! Tendency of the 0th order moment of the aerosols (fractal mode) (\(m^{-3}\)). + REAL(kind=mm_wp), DIMENSION(:), INTENT(out) :: dm3a + !! Tendency of the 3rd order moment of the aerosols distribution (fractal mode) (\(m^{3}.m^{-3}\)) . + REAL(kind=mm_wp), DIMENSION(:), INTENT(out) :: dm0n + !! Tendency of the 0th order moment of the aerosols distribution (fractal mode) (\(m^{-3}\)). + REAL(kind=mm_wp), DIMENSION(:), INTENT(out) :: dm3n + !! Tendency of the 3rd order moment of the ccn distribution (\(m^{3}.m^{-3}\)). + REAL(kind=mm_wp), DIMENSION(:,:), INTENT(out) :: dm3i + !! Tendencies of the 3rd order moments of each ice components (\(m^{3}.m^{-3}\)). + REAL(kind=mm_wp), DIMENSION(:,:), INTENT(out) :: dgazs + !! Tendencies of each condensible gaz species (\(mol.mol^{-1}\)). + REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE :: zdm0n,zdm3n + REAL(kind=mm_wp), DIMENSION(:,:), ALLOCATABLE :: zdm3i + INTEGER :: i + dm0a = 0._mm_wp ; dm3a = 0._mm_wp + dm0n = 0._mm_wp ; dm3n = 0._mm_wp + dm3i = 0._mm_wp ; dgazs = 0._mm_wp + + IF (mm_w_cloud_nucond) THEN + ! Calls condensation/nucleation (and update saturation ratio diagnostic) + call mm_cloud_nucond(dm0a,dm3a,dm0n,dm3n,dm3i,dgazs,mm_gazs_sat) + ENDIF + + IF (mm_w_cloud_sed) THEN + ! Calls sedimentation + ALLOCATE(zdm0n(mm_nla),zdm3n(mm_nla),zdm3i(mm_nla,mm_nesp)) + call mm_cloud_sedimentation(zdm0n,zdm3n,zdm3i) + + ! computes precipitations / ice fluxes + mm_ccn_prec = SUM(zdm3n*mm_dzlev) + mm_ccn_flux(:) = get_mass_flux(mm_rhoaer,mm_m3ccn(:)) + + DO i=1, mm_nesp + mm_ice_prec(i) = SUM(zdm3i(:,i)*mm_dzlev) + mm_ice_fluxes(:,i) = get_mass_flux(mm_xESPS(i)%rho,mm_m3ice(:,i)) + ENDDO + ! updates tendencies + dm0n = dm0n + zdm0n + dm3n = dm3n + zdm3n + dm3i = dm3i + zdm3i + ENDIF + + END SUBROUTINE mm_cloud_microphysics + + !----------------------------------------------------------------------------- + ! NUCLEATION/CONDENSATION PROCESS RELATED METHODS + !----------------------------------------------------------------------------- + + SUBROUTINE mm_cloud_nucond(dm0a,dm3a,dm0n,dm3n,dm3i,dgazs,gazsat) + !! Get moments tendencies through nucleation/condensation/evaporation. + !! + !! The method is a wrapper of [[mm_clouds(module):nc_esp(subroutine)]] which computes the + !! tendencies of tracers for all the condensible species given in the vector __xESPS__. + !! + !! @warning + !! __xESPS__, __m3i__ and __gazes__ must share the same indexing. For example if __xESPS(IDX)__ + !! corresponds to \(CH_{4}\) properties then __m3i(IDX)__ must be the total volume of solid + !! \(CH_{4}\) (ice) and __gazs(IDX)__ its vapor mole fraction. + REAL(kind=mm_wp), DIMENSION(:), INTENT(out) :: dm0a + !! Tendency of the 0th order moment of the aerosols (fractal mode) (\(m^{-3}\)). + REAL(kind=mm_wp), DIMENSION(:), INTENT(out) :: dm3a + !! Tendency of the 3rd order moment of the aerosols distribution (fractal mode) (\(m^{3}.m^{-3}\)). + REAL(kind=mm_wp), DIMENSION(:), INTENT(out) :: dm0n + !! Tendency of the 0th order moment of the aerosols distribution (fractal mode) (\(m^{-3}\)). + REAL(kind=mm_wp), DIMENSION(:), INTENT(out) :: dm3n + !! Tendency of the 3rd order moment of the ccn distribution (\(m^{3}.m^{-3}\)). + REAL(kind=mm_wp), DIMENSION(:,:), INTENT(out) :: dm3i + !! Tendencies of the 3rd order moments of each ice components (\(m^{3}.m^{-3}\)). + REAL(kind=mm_wp), DIMENSION(:,:), INTENT(out) :: dgazs + !! Tendencies of each condensible gaz species (\(mol.mol^{-1}\)) . + REAL(kind=mm_wp), DIMENSION(:,:), INTENT(out) :: gazsat + !! Saturation ratio of each condensible specie. + INTEGER :: i,idx,ng + TYPE(mm_esp) :: xESP + REAL(kind=mm_wp), DIMENSION(:,:), ALLOCATABLE :: zdm0a,zdm3a,zdm0n,zdm3n + ALLOCATE(zdm0a(mm_nla,mm_nesp),zdm3a(mm_nla,mm_nesp), & + zdm0n(mm_nla,mm_nesp),zdm3n(mm_nla,mm_nesp)) + zdm0a(:,:) = 0._mm_wp ; zdm3a(:,:) = 0._mm_wp + zdm0n(:,:) = 0._mm_wp ; zdm3n(:,:) = 0._mm_wp + DO i = 1, mm_nesp + call nc_esp(mm_xESPS(i),mm_gazs(:,i),mm_m3ice(:,i),dgazs(:,i),dm3i(:,i), & + zdm0a(:,i),zdm3a(:,i),zdm0n(:,i),zdm3n(:,i),gazsat(:,i)) + ENDDO + + ! Computes balance : + ! Each ice components has been treated independently from the others, and + ! their tendencies are returned as is (just converted in input units). + ! + ! Aerosols and CCN distribution evolution depends on the ice components: + ! - For nucleation only creation of CCN can occur. + ! - For condensation only loss of CCN can occur. + ! We use the simple following rule : + ! The global variation of CCN (and thus aerosols) is determined from the + ! most intense activity of the ice components. + ! that is the maximum value of the CCN tendencies regardless of its sign. + DO i=1, mm_nla + idx = MAXLOC(zdm0n(i,:),DIM=1) ! WARNING this is not the definition above (should be in ABS() func) + dm0n(i) = zdm0n(i,idx) + dm3n(i) = zdm3n(i,idx) + dm0a(i) = zdm0a(i,idx) + dm3a(i) = zdm3a(i,idx) + ! all ice are returned but we must convert their units + dm3i(i,:) = dm3i(i,:) + ENDDO + END SUBROUTINE mm_cloud_nucond + + SUBROUTINE nc_esp(xESP,vapX,m3iX,dvapX,dm3iX,dm0aer,dm3aer,dm0ccn,dm3ccn,Xsat) + !! Get moments tendencies through nucleation/condensation/evaporation of a given condensible specie. + !! + !! The method computes the global tendencies of the aerosols, ccn and "ice" moments through cloud + !! microphysics processes (nucleation & condensation). + !! + !! @warning + !! Input quantities __m3iX__,__m3iO__, __m0aer__,__m3aer__, __m0ccn__,__m3ccn__ are assumed to be in + !! \(X.kg^{-1}\) (where X is the unit of the moment that is, a number for M0 and a volume - \(m^3\) + !! for M3) ; __vapX__ must be expressed in term of molar fraction. + TYPE(mm_esp), INTENT(in) :: xESP + !! Condensate specie properties. + REAL(kind=mm_wp),INTENT(in), DIMENSION(:) :: vapX + !! Gas specie molar fraction on the vertical grid from __TOP__ to __GROUND__ (\(mol.mol^{-1}\)). + REAL(kind=mm_wp),INTENT(in), DIMENSION(:) :: m3iX + !! 3rd order moment of the ice component (\(m^{3}.m^{-3}\)). + REAL(kind=mm_wp),INTENT(out), DIMENSION(:) :: dvapX + !! Tendency of gas specie (\(mol.mol^{-1}\)). + REAL(kind=mm_wp),INTENT(out), DIMENSION(:) :: dm3iX + !! Tendency of the 3rd order moment of the ice component (\(m^{3}.m^{-3}\)). + REAL(kind=mm_wp),INTENT(out), DIMENSION(:) :: dm0aer + !! Tendency of the 0th order moment of the fractal mode distribution (\(m^{-3}\)). + REAL(kind=mm_wp),INTENT(out), DIMENSION(:) :: dm3aer + !! Tendency of the 3rd order moment of the fractal mode distribution (\(m^{3}.m^{-3}\)). + REAL(kind=mm_wp),INTENT(out), DIMENSION(:) :: dm0ccn + !! Tendency of the 0th order moment of the ccn distribution (\(m^{-3}\)). + REAL(kind=mm_wp),INTENT(out), DIMENSION(:) :: dm3ccn + !! Tendency of the 3rd order moment of the ccn distribution (\(m^{3}.m^{-3}\)). + REAL(kind=mm_wp),INTENT(out), DIMENSION(:) :: Xsat + !! Saturation ratio values on the vertical grid (--). + INTEGER :: i + REAL(kind=mm_wp) :: bef,aft + REAL(kind=mm_wp), DIMENSION(SIZE(vapX)) :: sm0a,sm3a,sm0n,sm3n,sm3iX + REAL(kind=mm_wp), DIMENSION(SIZE(vapX)) :: zm0a,zm3a,zm0n,zm3n,zm3iX,zvapX + REAL(kind=mm_wp), DIMENSION(SIZE(vapX)) :: pX,sig,qsat,lheat,seq,up,down, & + ctot,newvap,nucr,grate,cm0,cm3 + ! Initialization : + ! Copy input argument and convert units X.m-3 -> X.kg-1) + ! sXXX is the initial converted value saved + sm3iX = m3iX/mm_rhoair + sm0a = mm_m0aer_f/mm_rhoair ; sm3a = mm_m3aer_f/mm_rhoair + sm0n = mm_m0ccn/mm_rhoair ; sm3n = mm_m3ccn/mm_rhoair + ! zXXX is our working copy + zm3ix = sm3ix ; zm0a = sm0a ; zm3a = sm3a ; zm0n = sm0n ; zm3n = sm3n + + ! Molar fraction of X specie is set in mass mixing ratio + zvapX = vapX * xESP%fmol2fmas + ! Surface tension + sig = mm_sigX(mm_temp,xESP) + ! X specie mass mixing ratio at saturation + qsat = mm_qsatX(mm_temp,mm_play,xESP) + ! partial pressure of X specie + pX = vapX * mm_play + ! Saturation ratio + Xsat = zvapX / qsat + ! Equilibrium saturation near the drop + seq = dexp(2._mm_wp*sig*xESP%masmol/(xESP%rho*mm_rgas*mm_temp*mm_drad)) + ! Latent heat released + lheat = mm_lheatX(mm_temp,xESP) + ! Gets nucleation rate (ccn radius is the monomer !) + call nuc_rate((/(mm_rm, i=1,mm_nla)/),mm_temp,xESP,pX,Xsat,nucr) + ! Gets growth rate + call growth_rate(mm_temp,mm_play,pX/Xsat,xESP,seq,mm_drad,grate) + ctot = zvapx + xESP%rho * m3iX + up = vapx + mm_dt * grate * 4._mm_wp * mm_pi * xESP%rho * mm_drad * seq * zm0n + down = 1._mm_wp + mm_dt * grate * 4._mm_wp * mm_pi * xESP%rho * mm_drad / qsat * zm0n + ! gets new vapor X specie mass mixing ratio : cannot be greater than the + ! total gas + ice and lower than nothing :) + newvap = max(min(up/down,ctot),0._mm_wp) + ! gets "true" growth rate + grate = grate * (newvap/qsat - seq) + + ! computes tendencies through condensation + ! 1) check for the specific case : NO ICE and SUBLIMATION + WHERE (zm3iX <= 0._mm_wp .AND. grate <= 0._mm_wp) + ! no ice and sublimation : reset ice to 0 + zm3iX = 0._mm_wp + ELSEWHERE + ! update ice volume ... + zm3iX = zm3iX + mm_dt*grate*4._mm_wp*mm_pi*mm_drad*zm0n + ! ... and check if there ice left in the ccn + WHERE (zm3ix <= 0._mm_wp) + zm3ix = 0._mm_wp + zm0a = zm0a + zm0n ; zm0n = 0._mm_wp + zm3a = zm3a + zm3n ; zm3n = 0._mm_wp + ENDWHERE + ENDWHERE + + ! computes tendencies + ! all of these tendencies are in X.kg-1 + dm0aer = zm0a - sm0a + dm3aer = zm3a - sm3a + dm0ccn = zm0n - sm0n + dm3ccn = zm3n - sm3n + dm3ix = zm3ix - sm3ix + ! and this one is in mol.mol-1 + dvapx = -xESP%rho * dm3ix / xESP%fmol2fmas + + ! reset temporary arrays to initial values + zm3ix = sm3ix ; zm0a = sm0a ; zm3a = sm3a ; zm0n = sm0n ; zm3n = sm3n + + ! Computes global tendencies (nucleation && condensation) + ! + ! for nucleation we have the following equations: + ! dMaer_(k)/dt = - dMccn_(k)/dt (conservation of aerosols+ccn) (1) + ! dMaer_(k)/dt = - 4*PI*nucr/rm * Maer_(k+3) (2) + ! = - 4*PI*nucr/rm * alpha(k+3)/alpha(k) * Maer_(k) + ! where alpha(k+3) = Maer_(k+3)/Maer_(0) / rc**(k+3) + ! We solve (implicit scheme) : + ! CONST_M(k) = 4*PI*nucr/rm * alpha(k+3)/alpha(k)*rc**3 * dt + ! Maer_(k)[t+dt] = 1/(1+CONST_M(k)) * Maer_(k)[t] (3) + ! Then, from eq. 2: + ! Mccn_(k)[t+dt] = Mccn_(k)[t] + CONST_M(k)/(1+CONST_M(k))*Maer_(k)[t] (4) + ! + cm0 = 4._mm_wp*mm_pi*nucr/mm_rm*mm_alpha_f(3._mm_wp)*mm_rcf**3*mm_dt + cm3 = 4._mm_wp*mm_pi*nucr/mm_rm*mm_alpha_f(6._mm_wp)/mm_alpha_f(3._mm_wp)*mm_rcf**3*mm_dt + zm0a = 1._mm_wp/(1._mm_wp+cm0) * zm0a + zm3a = 1._mm_wp/(1._mm_wp+cm0) * zm3a + WHERE (zm0a <= 0._mm_wp .OR. zm3a <= 0._mm_wp) + zm0a=0._mm_wp + zm3a=0._mm_wp + zm0n = zm0n + sm0a + zm3n = zm3n + sm3a + ELSEWHERE + zm0n = zm0n + cm0/(1.+cm0)*zm0a + zm3n = zm3n + cm3/(1.+cm3)*zm3a + ENDWHERE + + ! Adds condensation tendencies + zm0a = zm0a + dm0aer + zm3a = zm3a + dm3aer + zm0n = zm0n + dm0ccn + zm3n = zm3n + dm3ccn + + ! Computes balance + IF (mm_debug) THEN + WRITE(*,'(a)') "Condensation/nucleation balance :" + DO i=1,mm_nla + bef = sm0a(i) + sm0n(i) + aft = zm0a(i) + zm0n(i) + IF (ABS(bef-aft)/bef > 1e-10_mm_wp) WRITE(*,'((a),I2.2,(a))') & + "[WARNING] nc_esp speaking: Total number not conserved (z=",i,")" + bef = sm3a(i) + sm3n(i) + aft = zm3a(i) + zm3n(i) + IF (ABS(bef-aft)/bef > 1e-10_mm_wp) WRITE(*,'((a),I2.2,(a))') & + "[WARNING] nc_esp speaking: Total volume not conserved (z=",i,")" + ENDDO + ENDIF + + ! Now updates tendencies + dm0aer = (zm0a-sm0a)*mm_rhoair + dm3aer = (zm3a-sm3a)*mm_rhoair + dm0ccn = (zm0n-sm0n)*mm_rhoair + dm3ccn = (zm3n-sm3n)*mm_rhoair + + END SUBROUTINE nc_esp + + SUBROUTINE nuc_rate(rccn,temp,xESP,pvp,sat,rate) + !! Get nucleation rate. + !! + !! The method computes the heterogeneous nucleation rate for the given specie on a fractal particle + !! of size __rccn__. + !! Except __xESP__, all arguments are vectors of the same size (vertical grid). + REAL(kind=mm_wp), INTENT(in), DIMENSION(:) :: rccn !! Radius of the cloud condensation nuclei (m). + REAL(kind=mm_wp), INTENT(in), DIMENSION(:) :: temp !! Temperature (K). + REAL(kind=mm_wp), INTENT(in), DIMENSION(:) :: pvp !! Partial vapor pressure of X specie (Pa). + REAL(kind=mm_wp), INTENT(in), DIMENSION(:) :: sat !! Saturation ratio of given specie (--). + TYPE(mm_esp), INTENT(in) :: xESP !! X specie properties (--). + REAL(kind=mm_wp), INTENT(out), DIMENSION(:) :: rate !! The nucleation rate (\(m^-{2}.s^{-1}\)). + INTEGER :: nv + REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE :: nX,rstar,gstar,x,zeldov,deltaf, & + fsh,fstar,sig + nv = SIZE(rccn) + ALLOCATE(nX(nv), rstar(nv), gstar(nv), x(nv), zeldov(nv), & + deltaf(nv), fsh(nv), fstar(nv)) + ! Activation condition + WHERE (sat > 1._mm_wp) + sig = mm_sigX(temp,xESP) + nX = pvp/mm_kboltz/temp + rstar = 2._mm_wp*sig*xESP%vol/(mm_kboltz*temp*dlog(sat)) + ! curvature radius + x = rccn/rstar + fsh = mm_fshape(xESP%mteta,x) + fstar = (4._mm_wp/3._mm_wp*mm_pi)*sig*(rstar**2.)*fsh + deltaf=MIN(MAX((2.*mm_fdes-mm_fdif-fstar)/(mm_kboltz*temp),-100._mm_wp),100._mm_wp) + WHERE (deltaf == -100._mm_wp) + rate = 0._mm_wp + ELSEWHERE + gstar = 4._mm_wp*mm_pi*(rstar**3)/(3._mm_wp*xESP%vol) + zeldov = dsqrt(fstar/(3._mm_wp*mm_pi*mm_kboltz*temp*(gstar**2))) + rate = zeldov*mm_kboltz*temp*(nX*rstar)**2._mm_wp*dexp(deltaf)/ & + (fsh*mm_nus*xESP%mas) + ENDWHERE + ELSEWHERE + rate = 0._mm_wp + ENDWHERE + DEALLOCATE(nX,rstar,gstar,x,zeldov,deltaf,fsh,fstar) + RETURN + END SUBROUTINE nuc_rate + + SUBROUTINE growth_rate(temp,pres,pXsat,xESP,seq,drad,rate) + !! Get growth rate through condensation/evaporation process. + !! + !! The method computes the growth rate a drop through condensation/evaporation processes: + !! + !! $$ r \times \frac{dr}{dt} = g_{rate} \times (S - S_{eq}) $$ + !! + !! Except __xESP__ which is a scalar, all arguments are vectors of the same size (vertical grid). + REAL(kind=mm_wp), INTENT(in), DIMENSION(:) :: temp !! Temperature (K). + REAL(kind=mm_wp), INTENT(in), DIMENSION(:) :: pres !! Pressure level (Pa). + REAL(kind=mm_wp), INTENT(in), DIMENSION(:) :: seq !! Saturation vapor pressure of specie (Pa). + REAL(kind=mm_wp), INTENT(in), DIMENSION(:) :: drad !! Specie properties. + REAL(kind=mm_wp), INTENT(in), DIMENSION(:) :: pXsat !! Equilibrium saturation near the drop. + TYPE(mm_esp), INTENT(in) :: xESP !! Drop radius (m). + REAL(kind=mm_wp), INTENT(out), DIMENSION(:) :: rate !! Growth rate (\(m^{2}.s^{-1}\)). + REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE :: k,knu,slf,rkc,rdc,l,dv + INTEGER :: n + n = SIZE(temp) + ALLOCATE(k(n),knu(n),slf(n),rkc(n),rdc(n),l(n),dv(n)) + + ! N2 (air) Thermal conductivity (where does it come from ?) + k(:) = ( 2.857e-2_mm_wp*temp-0.5428_mm_wp)*4.184e-3_mm_wp + ! Gas mean free path + l(:) = mm_lambda_g(temp,pres) + ! Diffusion coefficient of X gas + Dv(:) = 1._mm_wp/3._mm_wp*dsqrt(8._mm_wp*mm_rgas*temp(:)/(mm_pi*xESP%masmol))*mm_kboltz*temp(:) / & + (mm_pi*pres(:)*(mm_air_rad+xESP%ray)**2* dsqrt(1._mm_wp+xESP%fmol2fmas)) + knu(:) = l(:)/drad(:) ! The knudsen number of the drop + slf(:) = (1.333_mm_wp+0.71_mm_wp/knu(:))/(1._mm_wp+1._mm_wp/knu(:)) ! Slip flow correction + Dv(:) = Dv(:)/(1._mm_wp+slf(:)*knu(:)) + ! latent heat resistance coefficient + rkc(:) = mm_lheatX(temp(:),xESP)**2 * xESP%rho * xESP%masmol / (k(:)*mm_rgas*temp(:)**2) + ! Diffusion resistance coefficient + rdc(:) = mm_rgas * temp(:) * xESP%rho / (Dv(:)*pXsat(:)*xESP%masmol) + ! Growth rate: rdr/dt = rate * (S-Seq) ; rate is returned + rate(:) = 1._mm_wp / (seq(:)*rkc(:)+rdc(:)) + RETURN + END SUBROUTINE growth_rate + + + !----------------------------------------------------------------------------- + ! SEDIMENTATION PROCESS RELATED METHODS + !----------------------------------------------------------------------------- + + SUBROUTINE mm_cloud_sedimentation(dm0n,dm3n,dm3i) + !! Compute the tendency of _clouds_ related moments through sedimentation process. + !! + !! The method computes the tendencies of moments related to cloud microphysics through + !! sedimentation process. The algorithm used here differs from + !! [[mm_haze(module):mm_haze_sedimentation(subroutine)]] as all moments settle with the same + !! terminal velocity which is computed with the average drop radius of the size distribution. + !! We simply compute an _exchange matrix_ that stores the new positions of each cells through + !! sedimentation process and then computes the matrix + !! product with input moments values to get final tendencies. + REAL(kind=mm_wp), INTENT(out), DIMENSION(:) :: dm0n + !! Tendency of the 0th order moment of the ccn distribution (\(m^{-3}\)). + REAL(kind=mm_wp), INTENT(out), DIMENSION(:) :: dm3n + !! Tendency of the 3rd order moment of the ccn distribution (\(m^{3}.m^{-3}\)). + REAL(kind=mm_wp), INTENT(out), DIMENSION(:,:) :: dm3i + !! Tendencies of the 3rd order moment of each ice component of the cloud (\(m^{3}m^{-3}\)). + INTEGER :: im,nm + REAL(kind=mm_wp), DIMENSION(:,:), ALLOCATABLE :: moms, momsf,chg_matrix + nm = 2 + mm_nesp + ALLOCATE(moms(mm_nla,nm),momsf(mm_nla,nm),chg_matrix(mm_nla,mm_nla)) + ! Initializes moms + moms(:,1) = mm_m0ccn * mm_dzlev + moms(:,2) = mm_m3ccn * mm_dzlev + DO im=1,mm_nesp + moms(:,2+im) = mm_m3ice(:,im) * mm_dzlev + ENDDO + ! Computes exchange matrix + CALL exchange(mm_drad,mm_drho,mm_dt,chg_matrix) + ! Computes final moments values + DO im=1,nm ; momsf(:,im) = MATMUL(chg_matrix,moms(:,im)) ; ENDDO + ! Computes tendencies (converted in X.m-3) + dm0n = (momsf(:,1)-moms(:,1))/mm_dzlev + dm3n = (momsf(:,2)-moms(:,2))/mm_dzlev + DO im=1,mm_nesp + dm3i(:,im) = (momsf(:,2+im)-moms(:,2+im))/mm_dzlev + ENDDO + RETURN + END SUBROUTINE mm_cloud_sedimentation + + SUBROUTINE exchange(rad,rhog,dt,matrix) + !! Compute the exchange matrix. + !! + !! The subroutine computes the matrix exchange used by + !! [[mm_clouds(module):mm_cloud_sedimentation(subroutine)]] to compute moments tendencies + !! through sedimentation process. Both __rad__ and __rhog__ must be vector with relevant + !! values over the atmospheric vertical structure. __matrix__ is square 2D-array with same + !! dimension size than __rad__. + REAL(kind=mm_wp), INTENT(in), DIMENSION(:) :: rad + !! Cloud drop radius over the atmospheric vertical structure (m). + REAL(kind=mm_wp), INTENT(in), DIMENSION(:) :: rhog + !! Cloud drop density over the atmospheric vertical structure (\(kg.m^{-3}\)). + REAL(kind=mm_wp), INTENT(in) :: dt + !! Timestep (s). + REAL(kind=mm_wp), INTENT(out) :: matrix(:,:) + !! The output _exchange matrix_. + INTEGER :: nz,i,j,jj,jinf,jsup + REAL(kind=mm_wp) :: zni,znip1,xf,xft,xcnt + REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE :: puit + REAL(kind=mm_wp) :: cpte,cpte2 + INTEGER, PARAMETER :: ichx = 1 + matrix = 0._mm_wp ; nz = SIZE(rad) ; ALLOCATE(puit(nz)) + ! compute exchange matrix + DO i=1,nz + puit(i) = 0._mm_wp + xcnt = 0._mm_wp + ! computes drop move (i.e. its new positions) + CALL getnzs(ichx,i,rad,rhog,dt,zni,znip1) + + ! Peculiar case : Ground level precipitation [znip1<0 && (zni<0 || zni>0)] + ! Complete precipitation [ znip1 <= 0 && zni <= 0 ] : + IF(zni<=0._mm_wp.and.znip1<=0._mm_wp) THEN + xft=0._mm_wp + xf=1._mm_wp + xcnt=xcnt+xf + puit(i)=puit(i)+xf + ENDIF + ! partial precipitation [ znip1 <= 0 && zni > 0 ] : + IF (zni>0._mm_wp .and. znip1 <= 0._mm_wp) THEN + xft=zni/(zni-znip1) + xf=(1.-xft) + xcnt=xcnt+xf + puit(i)=puit(i)+xf + ENDIF + ! General case: no ground precipitation [ znip1 > 0 && zni > 0 ] + IF (zni>0._mm_wp.and.znip1>0._mm_wp) THEN + xft = 1._mm_wp ! on a la totalite de la case + xf = 0._mm_wp + xcnt=xcnt+xf + puit(i)=puit(i)+xf + ENDIF + ! Fix minimum level to the ground + znip1 = MAX(znip1,0.) + zni = MAX(zni,0.) + ! Locate new "drop" position in the verical grid + jsup=nz+1 + jinf=nz+1 + DO j=1,nz + IF (zni<=mm_zlev(j).and.zni>=mm_zlev(j+1)) jsup=j + IF (znip1<=mm_zlev(j).and.znip1>=mm_zlev(j+1)) jinf=j + ENDDO + ! Volume is out of range: (all drops have touched the ground!) + ! Note: can happen here,it has been treated previously :) + IF (jsup>=nz+1.and.jinf==jsup) THEN + WRITE(*,'(a)') "[EXCHANGE] speaking: The impossible happened !" + call EXIT(666) + ENDIF + ! Volume inside a single level + IF (jsup==jinf.and.jsup<=nz) THEN + xf=1._mm_wp + xcnt=xcnt+xft*xf + matrix(jinf,i)=matrix(jinf,i)+xft*xf + ENDIF + + ! Volume over 2 levels + IF (jinf==jsup+1) THEN + xf=(zni-mm_zlev(jinf))/(zni-znip1) + xcnt=xcnt+xf*xft + IF(jsup<=nz) THEN + matrix(jsup,i)=matrix(jsup,i)+xft*xf + ENDIF + xf=(mm_zlev(jinf)-znip1)/(zni-znip1) + xcnt=xcnt+xf*xft + IF (jinf<=nz) THEN + matrix(jinf,i)=matrix(jinf,i)+xft*xf + ENDIF + ENDIF + + ! Volume over 3 or more levels + IF (jinf > jsup+1) THEN + ! first cell + xf=(zni-mm_zlev(jsup+1))/(zni-znip1) + xcnt=xcnt+xf*xft + matrix(jsup,i)=matrix(jsup,i)+xft*xf + ! last cell + xf=(mm_zlev(jinf)-znip1)/(zni-znip1) + xcnt=xcnt+xf*xft + matrix(jinf,i)=matrix(jinf,i)+xft*xf + ! other :) + DO jj=jsup+1,jinf-1 + xf=(mm_zlev(jj)-mm_zlev(jj+1))/(zni-znip1) + xcnt=xcnt+xf*xft + matrix(jj,i)=matrix(jj,i)+xft*xf + ENDDO + ENDIF + ENDDO + ! checking if everything is alright if debug enabled... + IF (mm_debug) THEN + cpte=0._mm_wp ; cpte2=0._mm_wp + DO j=1,nz + DO jj=1,nz + cpte=cpte+matrix(jj,j) + ENDDO + cpte2=cpte+puit(j) + ENDDO + IF (abs(cpte2-nz)>1.e-4_mm_wp) THEN + WRITE(*,'(a)')"[EXCHANGE] speaking :" + WRITE(*,'("tx expl (/nz):",2(2X,ES10.3))') cpte,cpte2 + ENDIF + ENDIF + RETURN + END SUBROUTINE exchange + + SUBROUTINE getnzs(ichx,idx,rad,rho,dt,zni,zns) + !! Compute displacement of a cell under sedimentation process. + !! + !! The method computes the new position of a _drop cell_ through sedimentation process as + !! descibed in the following scheme: + !! + !! ![Cloud sedimentation scheme](|media|/cloud_sed_scheme.svg) + !! + !! New positions are returned in __zni__ and __zns__ ouptut arguments. + !! + !! @note + !! The method uses directly [[mm_globals(module):mm_play(variable)]], [[mm_globals(module):mm_plev(variable)]], + !! [[mm_globals(module):mm_temp(variable)]],[[mm_globals(module):mm_btemp(variable)]], + !! [[mm_globals(module):mm_zlay(variable)]] and [[mm_globals(module):mm_zlev(variable)]] and uses __idx__ to + !! get the relevant value to use on the vertical grid. + INTEGER, INTENT(in) :: ichx + !! Velocity extrapolation control flag (0 for linear, 1 for exponential -preferred -). + INTEGER, INTENT(in) :: idx + !! Initial position of the drop (subscript of vertical layers vectors). + REAL(kind=mm_wp), INTENT(in), DIMENSION(:) :: rad + !! Cloud drop radius over the atmospheric vertical structure (m). + REAL(kind=mm_wp), INTENT(in), DIMENSION(:) :: rho + !! Cloud drop density over the atmospheric vertical structure (\(kg.m^{-3}\)). + REAL(kind=mm_wp), INTENT(in) :: dt + !! Timestep (s). + REAL(kind=mm_wp), INTENT(out) :: zni + !! Final layer center position (m). + REAL(kind=mm_wp), INTENT(out) :: zns + !! Final layer upper boundary position (m). + REAL(kind=mm_wp) :: ws,wi,w,zi,zs + REAL(kind=mm_wp) :: alpha,argexp,v0,arg1,arg2 + INTEGER :: i,nz + REAL(kind=mm_wp), PARAMETER :: es = 30._mm_wp + nz = SIZE(rad) + ! Linear extrapolation of velocity + IF (ichx==0) THEN + ! velocity upper interface + ws = wsettle(mm_plev(idx),mm_btemp(idx),mm_zlev(idx),rho(idx),rad(idx)) + IF (idx==nz) THEN + ! veloctity center layer + wi = wsettle(mm_play(idx),mm_temp(idx),mm_zlay(idx),rho(idx),rad(idx)) + ELSEIF(idx ws + ! -es < argexp < es + argexp=MAX(MIN(alpha*zs,es),-es) + v0 = ws/dexp(argexp) + arg1=1._mm_wp+v0*alpha*dexp(argexp)*dt + argexp=MAX(MIN(alpha*(mm_zlev(idx)-mm_dzlev(idx)),es),-es) + arg2=1._mm_wp+v0*alpha*dexp(argexp)*dt + IF (arg1<=0._mm_wp.OR.arg2<=0._mm_wp) THEN + ! correct velocity + ! divides the velocity argument in arg1 and arg2 : + ! argX=1+alpha*v0*exp(alpha*z)*dt <==> argX-1=alpha*v0*exp(alpha*z)*dt + ! ==> argX' = 1 + (argX-1)/2 <==> argX' = (1+argX)/2. + DO i=1,25 + IF (arg1<=0._mm_wp.OR.arg2<=0._mm_wp) THEN + IF (mm_debug) & + WRITE(*,'((a),I2.2,(a))') "[getnzs] must adjust velocity (",i,"/25)" + arg1=(arg1+1._mm_wp)/2._mm_wp ; arg2=(arg2+1._mm_wp)/2._mm_wp + ELSE + EXIT + ENDIF + ENDDO + ! sh** we have to stop + IF (i>25) THEN + WRITE(*,'(a)')"[getnzs] speaking:" + WRITE(*,'(a)') "Cannot adjust velocities" + call EXIT(111) + ENDIF + ENDIF + zni = mm_zlev(idx)-dlog(arg1)/alpha + zns = mm_zlev(idx)-mm_dzlev(idx)-dlog(arg2)/alpha + RETURN + ENDIF + END SUBROUTINE getnzs + + ELEMENTAL FUNCTION wsettle(p,t,z,rho,rad) RESULT(w) + !! Compute the settling velocity of a spherical particle. + !! + !! The method computes the effective settling velocity of spherical particle of + !! radius __rad__. It accounts for the slip-flow transition (no approximation). + REAL(kind=mm_wp), INTENT(in) :: p !! The pressure level (Pa). + REAL(kind=mm_wp), INTENT(in) :: t !! The temperature (K). + REAL(kind=mm_wp), INTENT(in) :: z !! The altitude level (m). + REAL(kind=mm_wp), INTENT(in) :: rho !! Density of the particle (\(kg.m^{-3}\)). + REAL(kind=mm_wp), INTENT(in) :: rad !! Radius of the particle (m). + REAL(kind=mm_wp) :: w !! Settling velocity (\(m.s^{-1}\)). + REAL(kind=mm_wp) :: g,a,kn,nu + REAL(kind=mm_wp), PARAMETER :: ra = 1.75e-10_mm_wp, nu0 = 1.74e-4_mm_wp, c = 109._mm_wp + ! Computes corrected gravity + g = mm_effg(z) + ! Knudsen number + kn = mm_kboltz*t/(p*4._mm_wp*sqrt(2._mm_wp)*mm_pi*ra**2)/rad + ! Air viscosity + nu=nu0*sqrt(t/293._mm_wp)*(1._mm_wp+c/293._mm_wp)/(1._mm_wp+c/t) + ! Computes settling velocity + w = 2._mm_wp/9._mm_wp * rad**2*g*rho/nu + ! apply slip-flow correction + w = w*(1._mm_wp+1.2517_mm_wp*kn+0.4_mm_wp*kn*dexp(-1.1_mm_wp/kn)) + END FUNCTION wsettle + + FUNCTION get_mass_flux(rho,m3) RESULT(flx) + !> Get the mass flux of (clouds related) moment through sedimention. + !! + !! @warning + !! The method is __only__ valid for cloud moments (i.e. ice or ccn). It calls + !! [[mm_clouds(module):wsettle(function)]] that compute the _mean_ settling velocity of a + !! cloud drop. + !! + !! @note + !! The computed flux is always positive. + REAL(kind=mm_wp), INTENT(in) :: rho + !! Tracer density (\(kg.m^{-3}\)). + REAL(kind=mm_wp), INTENT(in), DIMENSION(:) :: m3 + !! Vertical profile of the total volume of tracer (i.e. M3) from __TOP__ to __GROUND__ (\(m^{3}.m^{-3}\)). + REAL(kind=mm_wp), DIMENSION(SIZE(m3)) :: flx + !! Mass sedimentation fluxes at each layer from __TOP__ to __GROUND__ (\(kg.m^{-2}.s^{-1}\)). + REAL(kind=mm_wp), SAVE :: fac = 4._mm_wp/3._mm_wp * mm_pi + flx = fac * rho * m3 * wsettle(mm_play,mm_temp,mm_zlay,mm_drho,mm_drad) + RETURN + END FUNCTION get_mass_flux + +END MODULE MM_CLOUDS Index: trunk/LMDZ.TITAN/libf/muphytitan/mm_globals.f90 =================================================================== --- trunk/LMDZ.TITAN/libf/muphytitan/mm_globals.f90 (revision 1793) +++ trunk/LMDZ.TITAN/libf/muphytitan/mm_globals.f90 (revision 1793) @@ -0,0 +1,1440 @@ +! Copyright 2013-2015 Université de Reims Champagne-Ardenne +! Contributor: J. Burgalat (GSMA, URCA) +! email of the author : jeremie.burgalat@univ-reims.fr +! +! This software is a computer program whose purpose is to compute +! microphysics processes using a two-moments scheme. +! +! This library is governed by the CeCILL-B license under French law and +! abiding by the rules of distribution of free software. You can use, +! modify and/ or redistribute the software under the terms of the CeCILL-B +! license as circulated by CEA, CNRS and INRIA at the following URL +! "http://www.cecill.info". +! +! As a counterpart to the access to the source code and rights to copy, +! modify and redistribute granted by the license, users are provided only +! with a limited warranty and the software's author, the holder of the +! economic rights, and the successive licensors have only limited +! liability. +! +! In this respect, the user's attention is drawn to the risks associated +! with loading, using, modifying and/or developing or reproducing the +! software by the user in light of its specific status of free software, +! that may mean that it is complicated to manipulate, and that also +! therefore means that it is reserved for developers and experienced +! professionals having in-depth computer knowledge. Users are therefore +! encouraged to load and test the software's suitability as regards their +! requirements in conditions enabling the security of their systems and/or +! data to be ensured and, more generally, to use and operate it in the +! same conditions as regards security. +! +! The fact that you are presently reading this means that you have had +! knowledge of the CeCILL-B license and that you accept its terms. + +!! file: mm_globals.f90 +!! summary: Parameters and global variables module. +!! author: J. Burgalat +!! date: 2013-2015 + +MODULE MM_GLOBALS + !! Parameters and global variables module. + !! + !! # Module overview + !! + !! The module defines all the parameters and global variables that are common + !! to all other modules of the library. + !! + !! It is separated in two parts : + !! + !! - Main parameters and global saved variables. Most of these variables should + !! be initialized once and should hold the same value during run-time. These + !! variables are completly public and initialized by [[mm_globals(module):mm_global_init(interface)]] + !! method. + !! - The second part defines a set of vectors that defines the vertical structure of the atmosphere. + !! Each time a new atmospheric column has to be computed (either on a new timestep or on a new couple + !! of longitude/latitude), these vectors should be intialized with new values by calling + !! [[mm_globals(module):mm_column_init(function)]] method. + !! This part is separated in two sets : + !! + !! - The atmospheric structure with temperature, pressure levels and altitude definitions. + !! - The vertical profiles of tracers with the moments of the two aerosols modes (both \(M_{0}\) + !! and \(M_{3}\) for a total of 4 vectors), the _clouds_ microphysics moments tracers (i.e. + !! \(M_{0}\) and \(M_{3}\) for the ccn and \(M_{3}\) for the ice components). + !! Additionally, the module also stores intermediates variables of interest such as the + !! characteristic radii of the aerosols modes, the mean drop radius and the drop density, + !! the molar fraction of each condensible species (related to ice components) and some + !! scalar variables that holds arrays sizes. + !! + !! @note + !! All the vectors that represent the vertical structure of the atmosphere (altitude, pressure and + !! temperature...) are oriented from the __TOP__ of the atmosphere to the __GROUND__. + !! + !! @note + !! The module also imports errors module from __FCCP__ library to get definitions of the error object + !! everywhere in the library ([[mm_globals(module)]] is always imported, except in [[mm_mprec(module)]]). + !! + !! # Global variables + !! + !! [[mm_globals(module)]] module contains the declaration of all global/common variable that are shared + !! by all other modules of the model. Except for few physical constant which are declared as parameters, + !! these variables are onlu SAVEd. They are initialized by [[mm_globals(module):mm_global_init(interface)]] + !! methods. + !! the following sections list all the global variables by category. + !! + !! ## Control flags + !! + !! | Name | Description + !! | :----------------- | :----------------- + !! | mm_log | Enable log mode (verbose) + !! | mm_w_haze_prod | Enable/Disable haze production + !! | mm_w_haze_sed | Enable/Disable haze sedimentation + !! | mm_w_haze_coag | Enable/Disable haze coagulation + !! | mm_w_clouds   | Enable/Disable clouds microphysics + !! | mm_w_clouds_sed  | Enable/Disable clouds microphysics sedimentation + !! | mm_w_clouds_nucond | Enable/Disable clouds microphysics nucleation/condensation + !! | mm_wsed_m0 | Force all aerosols moments to fall at M0 settling velocity + !! | mm_wsed_m3 | Force all aerosols moments to fall at M3 settling velocity + !! | mm_no_fiadero_w | Enable/Disable __Fiadero__ correction + !! + !! ### Related free parameters: + !! + !! | Name | Description + !! | :-------------- | :----------------- + !! | mm_fiadero_min | Minimum ratio for __Fiadero__'s correction + !! | mm_fiadero_max | Maximum ratio for __Fiadero__'s correction + !! | mm_coag_choice | Coagulation interaction activation flag. It should be a combination of [[mm_globals(module):mm_coag_no(variable)]], [[mm_globals(module):mm_coag_ss(variable)]], [[mm_globals(module):mm_coag_sf(variable)]] and [[mm_globals(module):mm_coag_ff(variable)]]. + !! + !! ## Physical constants + !! + !! | Name | Description + !! | :-------- | :----------------- + !! | mm_pi | Pi number + !! | mm_navo | Avogadro number + !! | mm_kboltz | Boltzmann constant (\(J.K^{-1}\)) + !! | mm_rgas | Perfect gas constant (\(J.mol^{-1}.K^{-1}\)) + !! | mm_fdes | Desorption energy (\(J\)) (nucleation) + !! | mm_fdif | Surface diffusion energy (\(J\)) (nucleation) + !! | mm_fnus | Jump frequency (\(s^{-1}\)) (nucleation) + !! | mm_akn | Approximated slip-flow correction coefficient ( + !! + !! ## Free parameters + !! + !! | Name | Description + !! | :---------- | :----------------- + !! | mm_rhoaer | Aerosol density (in \(kg.m^{-3}\)) + !! | mm_df | Fractal dimension + !! | mm_rm | Monomer radius (in m) + !! | mm_p_prod | Spherical aerosols production pressure level (Pa) + !! | mm_p_rcprod | Spherical aerosols equivalent radius production (m) + !! | mm_tx_prod | Production rate of spherical aerosols (\(kg.m^{-2}.s^{-1}\)) + !! | mm_d_prod | Time-dependent sine wve pre-factor. + !! | mm_w_prod | Angular frequency of the time-dependent production rate. + !! | mm_ne | Electric charging of aerosols (\(e^{-}.m^{-1}\)) (unused) + !! | mm_rb2ra  | Bulk to apparent radius conversion pre-factor (\(m^X\)) + !! | mm_rpla | Planet radius (m) + !! | mm_g0 | Planet acceleration due to gravity constant (ground) (\(m.s^{-2}\)) + !! | mm_air_rad | Air molecules mean radius (m) + !! | mm_air_mmol | Air molecules molar mass (\(kg.mol^{-1}\)) + !! | mm_dt | Microphysic time step (s) + USE MM_MPREC + USE MM_INTERFACES + ! from swift + USE CFGPARSE + USE STRINGS + USE ERRORS + IMPLICIT NONE + + PUBLIC + + PRIVATE :: cldprop_sc,cldprop_ve,read_esp,check_r1,check_i1,check_l1,check_s1 + + ! Protected variables + ! the following variables are read-only outside this module. + ! One must call the afferent subroutine to update them. + + ! initialization control flags (cannot be updated) + PROTECTED :: mm_ini,mm_ini_col,mm_ini_aer,mm_ini_cld + ! model parameters (mm_global_init) + PROTECTED :: mm_dt,mm_rhoaer,mm_df,mm_rm,mm_p_prod,mm_rc_prod,mm_tx_prod,mm_rpla,mm_g0,mm_rb2ra + ! atmospheric vertical structure (mm_column_init) + PROTECTED :: mm_nla,mm_nle,mm_zlay,mm_zlev,mm_play,mm_plev,mm_temp,mm_rhoair,mm_btemp,mm_dzlev,mm_dzlay + ! Condensible species parameters (mm_global_init) + PROTECTED :: mm_nesp,mm_spcname,mm_xESPS + ! Moments parameters (mm_aerosols_init / mm_clouds_init) + PROTECTED :: mm_m0aer_s, mm_m3aer_s, mm_m0aer_f, mm_m3aer_f, mm_m0ccn, mm_m3ccn, mm_m3ice + ! Moments parameters (derived, are updated with moments parameters) + PROTECTED :: mm_rcs, mm_rcf, mm_drad, mm_drho + + LOGICAL, SAVE :: mm_debug = .true. !! Enable QnD debug mode. + LOGICAL, SAVE :: mm_log = .false. !! Enable log mode. + + LOGICAL, SAVE :: mm_w_haze_prod = .true. !! Enable/Disable haze production. + LOGICAL, SAVE :: mm_w_haze_sed = .true. !! Enable/Disable haze sedimentation. + LOGICAL, SAVE :: mm_w_haze_coag = .true. !! Activate haze coagulation. + + LOGICAL, SAVE :: mm_wsed_m0 = .false. !! Force all aerosols moments to fall at M0 settling velocity. + LOGICAL, SAVE :: mm_wsed_m3 = .false. !! Force all aerosols moments to fall at M3 settling velocity. + + LOGICAL, SAVE :: mm_var_prod = .false. !! Time variation of production rate control flag. + + !> Enable/Disable __Fiadero__'s correction. + !! + !! This flag enables/disables the __Fiadero__ correction alogrithm for fractal mode settling velocity + !! computation. + !! + !! @bug + !! Currently, the Fiadero correction creates instatibilities on the vertical structure. It seems to be + !! related to the coupling between the two moments. In order to reduce the instabilities, settling + !! velocity of moments are forced to be the same, see [[mm_globals(module):mm_wsed_m0(variable)]] and + !! [[mm_globals(module):mm_wsed_m3(variable)]]). + LOGICAL, SAVE :: mm_no_fiadero_w = .false. + + !> Minimum ratio for __Fiadero__ correction. + !! + !! When [[mm_globals(module):mm_no_fiadero_w(variable)]] is disabled, this variable defines the minimum + !! value of the moment's ratio between two adjacents vertical cells to be used within the correction. + REAL(kind=mm_wp), SAVE :: mm_fiadero_min = 0.1_mm_wp + + !> Maximum ratio for __Fiadero__ correction. + !! + !! When [[mm_globals(module):mm_no_fiadero_w(variable)]] is disabled, this variable defines the maximum + !! value of the moment's ratio between two adjacents vertical cells to be used within the correction. + REAL(kind=mm_wp), SAVE :: mm_fiadero_max = 10._mm_wp + + LOGICAL, SAVE :: mm_w_clouds = .true. !! Enable/Disable clouds microphysics. + LOGICAL, SAVE :: mm_w_cloud_sed = .true. !! Enable/Disable cloud sedimentation. + LOGICAL, SAVE :: mm_w_cloud_nucond = .true. !! Activate cloud nucleation/condensation. + + INTEGER, PARAMETER :: mm_coag_no = 0 !! no mode interaction for coagulation (i.e. no coagulation at all). + INTEGER, PARAMETER :: mm_coag_ss = 1 !! SS mode interaction for coagulation. + INTEGER, PARAMETER :: mm_coag_sf = 2 !! SF mode interaction for coagulation. + INTEGER, PARAMETER :: mm_coag_ff = 4 !! FF mode interaction for coagulation. + !> Default interactions to activate (all by default). + INTEGER, SAVE :: mm_coag_choice = mm_coag_ss+mm_coag_sf+mm_coag_ff + + !> Pi number. + REAL(kind=mm_wp), PARAMETER :: mm_pi = 4._mm_wp*atan(1._mm_wp) + !> Avogadro number. + REAL(kind=mm_wp), PARAMETER :: mm_navo = 6.0221367e23_mm_wp + !> Boltzmann constant (\(J.K^{-1}\)). + REAL(kind=mm_wp), PARAMETER :: mm_kboltz = 1.3806488e-23_mm_wp + !> Perfect gas constant (\(J.mol^{-1}.K^{-1}\)). + REAL(kind=mm_wp), PARAMETER :: mm_rgas = mm_kboltz * mm_navo + !> Desorption energy (\(J\)) (nucleation). + REAL(kind=mm_wp), PARAMETER :: mm_fdes = 0.288e-19_mm_wp + !> Surface diffusion energy (\(J\)) (nucleation). + REAL(kind=mm_wp), PARAMETER :: mm_fdif = 0.288e-20_mm_wp + !> Jump frequency (\(s^{-1}\)) (nucleation). + REAL(kind=mm_wp), PARAMETER :: mm_nus = 1.e+13_mm_wp + !> Approximated slip-flow correction coefficient. + REAL(kind=mm_wp), PARAMETER :: mm_akn = 1.591_mm_wp + + !> Aerosols density (\(kg.m^{-3}\)). + REAL(kind=mm_wp), SAVE :: mm_rhoaer = 1.e3_mm_wp + + !> Fractal dimension of fractal aerosols. + REAL(kind=mm_wp), SAVE :: mm_df = 3._mm_wp + + !> Monomer radius (m). + REAL(kind=mm_wp), SAVE :: mm_rm = 6.66e-8_mm_wp + + !> Spherical aerosols production pressure level (Pa). + REAL(kind=mm_wp), SAVE :: mm_p_prod = 1._mm_wp + + !> Spherical aerosols equivalent radius production (m) + REAL(kind=mm_wp), SAVE :: mm_rc_prod = 1.3101721857598102e-9_mm_wp + + !> Production rate of spherical aerosols (\(kg.m^{-2}.s^{-1}\)). + REAL(kind=mm_wp), SAVE :: mm_tx_prod = 3.5e-13_mm_wp + + !> Aerosol production delta if time variations is enabled (fraction). + REAL(kind=mm_wp), SAVE :: mm_d_prod = 0.25_mm_wp + + !> Aerosol production variations angular frequency if time variations is enabled (\(rad.s^{-1}\)). + REAL(kind=mm_wp), SAVE :: mm_w_prod = 2.*mm_pi / (86400.*16.) + + + !> Electric charging of aerosols (\(e^{-}.m^{-1}\)). + REAL(kind=mm_wp), SAVE :: mm_ne = -15.e6_mm_wp + + !> Bulk to apparent radius conversion pre-factor (\(m^{X}\)). + !! + !! It is initialized using [[mm_globals(module):mm_rm(variable)]] in + !! [[mm_globals(module):mm_global_init(interface)]] from the following equation: + !! + !! $$ r_{a} = r_{b}^{3/D_{f}}\times r_{m}^{\frac{D_{f}-3}{D_{f}}} $$ + !! + !! Where \(r_{a}\) is the apparent radius, \(r_{b}\) the bulk radius and + !! \(rb2ra = r_{m}^{\frac{D_{f}-3}{D_{f}}}\) is the returned pre-factor + REAL(kind=mm_wp), SAVE :: mm_rb2ra = 1._mm_wp + + !> Characteristic radius threshold. + REAL(kind=mm_wp), SAVE :: mm_rc_min = 1.e-200_mm_wp + + !> Name of condensible species. + CHARACTER(len=30), DIMENSION(:), ALLOCATABLE, SAVE :: mm_spcname + + TYPE, PUBLIC :: mm_esp + !! Cloud related chemical specie properties. + !! + !! This derived type is used in thermodynamic methods related to cloud microphysics. + !! Most of its fields represent parameters of equations from \cite{reid1986}. + CHARACTER(LEN=10) :: name !! Specie name. + REAL(kind=mm_wp) :: mas !! Molecular weight (kg). + REAL(kind=mm_wp) :: vol !! Molecular volume (\(m^{3}\)). + REAL(kind=mm_wp) :: ray !! Molecular radius (m). + REAL(kind=mm_wp) :: masmol !! Molar mass (\(kg.mol^{-1}\)). + REAL(kind=mm_wp) :: rho !! density (liquid) (\(kg.m^{-3}\)). + REAL(kind=mm_wp) :: tc !! Critical temperature (K). + REAL(kind=mm_wp) :: pc !! Critical pressure (Bar). + REAL(kind=mm_wp) :: tb !! Boiling point temperature (K). + REAL(kind=mm_wp) :: w !! Acentric factor (--). + REAL(kind=mm_wp) :: a_sat !! Saturation equation A coefficient. + REAL(kind=mm_wp) :: b_sat !! Saturation equation B coefficient. + REAL(kind=mm_wp) :: c_sat !! saturation equation C coefficient. + REAL(kind=mm_wp) :: d_sat !! Saturation equation D coefficient. + REAL(kind=mm_wp) :: mteta !! Wettability. + REAL(kind=mm_wp) :: tx_prod !! Production rate. + REAL(kind=mm_wp) :: fmol2fmas !! molar fraction to mass fraction coefficient. + ! = masmol(X)/masmol(AIR) + END TYPE mm_esp + + !> Planet radius (m). + REAL(kind=mm_wp), SAVE :: mm_rpla = 2575000._mm_wp + !> Planet acceleration due to gravity constant (ground) (\(m.s^{-2}\)). + REAL(kind=mm_wp), SAVE :: mm_g0 = 1.35_mm_wp + !> Air molecules mean radius (m). + REAL(kind=mm_wp), SAVE :: mm_air_rad = 1.75e-10_mm_wp + !> Air molecules molar mass (\(kg.mol^{-1}\)). + REAL(kind=mm_wp), SAVE :: mm_air_mmol = 28e-3_mm_wp + !> Microphysic time step (s). + REAL(kind=mm_wp), SAVE :: mm_dt = 5529.6_mm_wp + !> Model current time tracer (s). + REAL(kind=mm_wp), SAVE :: mm_ct = 0.0 + !> Total number of clouds condensible species. + INTEGER, SAVE :: mm_nesp = -1 + !> Clouds chemical species properties. + TYPE(mm_esp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_xESPS + + !------------------------ + ! Vertical structure part + !------------------------ + + !> Number of vertical layers. + INTEGER, SAVE :: mm_nla = -1 + !> Number of vertical levels. + INTEGER, SAVE :: mm_nle = -1 + + !> Altitude layers (m). + REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_zlay + !> Altitude levels (m). + REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_zlev + !> Pressure layers (Pa). + REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_play + !> Pressure levels (Pa). + REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_plev + !> Temperature vertical profile (K). + REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_temp + !> Air density vertical profile (\(kg.m^{-3}\)). + REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_rhoair + !> Temperature vertical profil at interfaces (K). + REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_btemp + + !> Atmospheric levels thickness (m). + !! + !! Atmospheric thickness between two adjacent levels (\(m\)) from the + !! __TOP__ to the __GROUND__. + !! @note __mm_dzlev__ is defined on the total number of layers and actually + !! corresponds to the thickness of a given layer. + REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_dzlev + + !> Atmospheric layers "thickness" (m). + !! + !! Atmospheric thickness between the center of two adjacent layers (\(m\)) + !! from the __TOP__ to the __GROUND__. + !! @note + !! __mm_dzlay__ is defined on the total number of layers. The last + !! value of __mm_dzlay__ is set to twice the altitude of the ground layer. + !! @note This value corresponds to the thickness between the center of the + !! __GROUND__ layer and below the surface. It is arbitrary and not used. + REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_dzlay + + !> Spherical mode \(0^{th}\) order moment (\(m^{-3}\)). + REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_m0aer_s + !> Spherical mode \(3^{rd}\) order moment (\(m^{3}.m^{-3}\)). + REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_m3aer_s + !> Fractal mode \(0^{th}\) order moment (\(m^{-3}\)). + REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_m0aer_f + !> Fractal mode \(3^{rd}\) order moment (\(m^{3}.m^{-3}\)). + REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_m3aer_f + !> CCN \(0^{th}\) order moment (\(m^{-3}\)). + REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_m0ccn + !> CCN \(3^{rd}\) order moment (\(m^{3}.m^{-3}\)). + REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_m3ccn + + !> Ice components 3rd order moments (\(m^{3}.m^{-3}\)). + !! + !! It is a 2D array with the vertical layers in first dimension, and the number of ice + !! components in the second. + !! @note + !! Both [[mm_globals(module):mm_m3ice(variable)]] and [[mm_globals(module):mm_gazs(variable)]] + !! share the same indexing (related to species order). + REAL(kind=mm_wp), DIMENSION(:,:), ALLOCATABLE, SAVE :: mm_m3ice + + !> Condensible species molar fraction (\(mol.mol^{-1}\)). + !! + !! It is a 2D array with the vertical layers in first dimension, and + !! the number of condensible species in the second. + !! @note + !! Both [[mm_globals(module):mm_m3ice(variable)]] and [[mm_globals(module):mm_gazs(variable)]] + !! share the same indexing (related to species order). + REAL(kind=mm_wp), DIMENSION(:,:), ALLOCATABLE, SAVE :: mm_gazs + + !> Spherical mode characteristic radius (m). + REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_rcs + !> Fractal mode characteristic radius (m). + REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_rcf + !> Mean Drop radius (m). + REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_drad + !> Mean Drop density (\(kg.m^{-3}\)). + REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_drho + + !> Aerosols precipitations (m). + !! + !! Aerosols precipitations take into account both spherical and fractal modes. + !! It is updated in [[mm_haze(module):mm_haze_microphysics(subroutine)]]. + REAL(kind=mm_wp), SAVE :: mm_aer_prec = 0._mm_wp + + !> Spherical mode \(M_{0}\) settling velocity (\(m.s^{-1}\)). + !! + !! It is a vector with the vertical layers that contains the settling velocity for + !! the \(0^{th}\) order moment of the spherical mode. + !! It is updated in [[mm_haze(module):mm_haze_sedimentation(subroutine)]]. + !! @note + !! This variable is always negative. + REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_m0as_vsed + + !> Spherical mode \(M_{3}\) settling velocity (\(m.s^{-1}\)). + !! + !! It is a vector with the vertical layers that contains the settling velocity for the + !! \(3^{rd}\) order moment of the spherical mode. + !! It is updated in [[mm_haze(module):mm_haze_sedimentation(subroutine)]]. + !! @note + !! This variable is always negative. + REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_m3as_vsed + + !> Fractal mode \(M_{0}\) settling velocity (\(m.s^{-1}\)). + !! + !! It is a vector with the vertical layers that contains the settling velocity for the + !! \(0^{th}\) order moment of the fractal mode. + !! It is updated in [[mm_haze(module):mm_haze_sedimentation(subroutine)]]. + !! @note + !! This variable is always negative. + REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_m0af_vsed + + !> Fractal mode \(M_{3}\) settling velocity (\(m.s^{-1}\)). + !! + !! It is a vector with the vertical layers that contains the settling velocity for the + !! \(3^{rd}\) order moment of the fractal mode. + !! It is updated in [[mm_haze(module):mm_haze_sedimentation(subroutine)]]. + !! @note + !! This variable is always negative. + REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_m3af_vsed + + !> Spherical aerosol mass fluxes (\(kg.m^{-2}.s^{-1}\)). + !! + !! It is a vector with the vertical layers that contains the mass fluxes for spherical aerosols. + !! It is updated in [[mm_haze(module):mm_haze_sedimentation(subroutine)]]. + !! @note + !! This variable is always negative. + REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_aer_s_flux + + !> Fractal aerosol mass fluxes (\(kg.m^{-2}.s^{-1}\)). + !! + !! It is a vector with the vertical layers that contains the mass fluxes for fractal aerosols + !! It is updated in [[mm_haze(module):mm_haze_sedimentation(subroutine)]]. + !! @note + !! This variable is always negative. + REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_aer_f_flux + + !> CCN precipitations (m). + !! It is updated in [[mm_clouds(module):mm_cloud_microphysics(subroutine)]]. + REAL(kind=mm_wp), SAVE :: mm_ccn_prec = 0._mm_wp + + !> CCN mass fluxes (\(kg.m^{-2}.s^{-1}\)). + !! + !! It is a vector with the vertical layers that contains the + !! mass fluxes for CCN. + !! It is updated in [[mm_clouds(module):mm_cloud_microphysics(subroutine)]]. + !! @note + !! This variable is always negative. + REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_ccn_flux + + !> Ice components precipitations (m). + !! + !! It is a vector of [[mm_globals(module):mm_nesp(variable)]] values which share the same indexing + !! than [[mm_globals(module):mm_m3ice(variable)]] and [[mm_globals(module):mm_gazs(variable)]]. + !! It is updated in [[mm_clouds(module):mm_cloud_microphysics(subroutine)]]. + !! @note + !! This variable is always negative. + REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_ice_prec + + !> Ice components sedimentation fluxes (\(kg.m^{-2}.s-1\)). + !! + !! It is a 2D-array with the vertical layers in first dimension and the number of ice components + !! in the second. It is updated in [[mm_clouds(module):mm_cloud_microphysics(subroutine)]]. + !! @note + !! This variable is always negative. + REAL(kind=mm_wp), DIMENSION(:,:), ALLOCATABLE, SAVE :: mm_ice_fluxes + + !> Condensible species saturation ratio (--). + !! + !! It is a 2D-array with the vertical layers in first dimension and the number of condensible + !! species in the second. + !! It is updated in [[mm_clouds(module):mm_cloud_microphysics(subroutine)]]. + REAL(kind=mm_wp), DIMENSION(:,:), ALLOCATABLE, SAVE :: mm_gazs_sat + + !> [[mm_globals(module):mm_global_init(interface)]] initialization control flag. + LOGICAL, PUBLIC, SAVE :: mm_ini = .false. + + !> [[mm_globals(module):mm_column_init(function)]] initialization control flag. + LOGICAL, PUBLIC, SAVE :: mm_ini_col = .false. + + !> [[mm_globals(module):mm_aerosols_init(function)]] initialization control flag. + LOGICAL, PUBLIC, SAVE :: mm_ini_aer = .false. + + !> [[mm_globals(module):mm_clouds_init(function)]] initialization control flag. + LOGICAL, PUBLIC, SAVE :: mm_ini_cld = .false. + + !> Interface to cloud properties methods. + !! + !! The method computes clouds properties (mean drop radius and denstity) from their afferent + !! moments. It is overloaded to compute properties at a single level or over all the vertical + !! atmospheric structure. + INTERFACE mm_cloud_properties + MODULE PROCEDURE cldprop_sc,cldprop_ve + END INTERFACE + + !> Interface to global initialization. + !! + !! The method performs the global initialization of the model. + !! @warning + !! If OpenMP is activated, this subroutine must be called in an $OMP SINGLE statement as it + !! initializes global variable that are not thread private. + !! + !! ''' + !! !$OMP SINGLE + !! call mm_global_init(...) + !! !$OMP END SINGLE + INTERFACE mm_global_init + MODULE PROCEDURE mm_global_init_0,mm_global_init_1 + END INTERFACE + + !> Check an option from the configuration system. + !! + !! The method checks for an option in the configuration system and optionally + !! set a default value if the option is not found. This is an overloaded method + !! that can take in input either a floating point, integer, logical or string + !! option value. + INTERFACE mm_check_opt + MODULE PROCEDURE check_r1,check_i1,check_l1,check_s1 + END INTERFACE + + ! --- OPENMP --------------- + ! All variable related to column computations should be private to each thread + ! + !$OMP THREADPRIVATE(mm_ini_col,mm_ini_aer,mm_ini_cld) + !$OMP THREADPRIVATE(mm_zlay,mm_zlev,mm_play,mm_plev,mm_temp,mm_rhoair,mm_btemp,mm_dzlev,mm_dzlay) + !$OMP THREADPRIVATE(mm_m0aer_s,mm_m3aer_s,mm_m0aer_f,mm_m3aer_f) + !$OMP THREADPRIVATE(mm_m0ccn,mm_m3ccn,mm_m3ice,mm_gazs) + !$OMP THREADPRIVATE(mm_rcs,mm_rcf,mm_drad,mm_drho) + !$OMP THREADPRIVATE(mm_aer_s_flux,mm_aer_f_flux,mm_ccn_flux,mm_ice_prec,mm_ice_fluxes,mm_gazs_sat) + !$OMP THREADPRIVATE(mm_m0as_vsed,mm_m3as_vsed,mm_m0af_vsed,mm_m3af_vsed) + + !$OMP THREADPRIVATE(mm_nla,mm_nle) + + ! -------------------------- + + + CONTAINS + + FUNCTION mm_global_init_0(dt,df,rm,rho_aer,p_prod,tx_prod,rc_prod,rplanet,g0, & + air_rad,air_mmol,coag_interactions,clouds,spcfile, & + w_haze_prod,w_haze_sed,w_haze_coag,w_cloud_nucond, & + w_cloud_sed,force_wsed_to_m0,force_wsed_to_m3, & + no_fiadero,fiadero_min,fiadero_max) RESULT(err) + !! Initialize global parameters of the model. + !! + !! The function initializes all the global parameters of the model from direct input. + !! Boolean (and Fiadero) parameters are optional as they are rather testing parameters. Their + !! default values are suitable for production runs. + !! @note + !! If the method fails to initialize parameters (i.e. returned error is not 0). Then the model + !! should probably be aborted as the global variables of the model will not be correctly setup. + !! @warning + !! If OpenMP is activated, this subroutine must be called in an $OMP SINGLE statement as it + !! initializes global variable that are not thread private. + !! + !! ''' + !! !$OMP SINGLE + !! call mm_global_init_0(...) + !! !$OMP END SINGLE + REAL(kind=mm_wp), INTENT(in) :: dt + !! Microphysics timestep in seconds. + REAL(kind=mm_wp), INTENT(in) :: df + !! Fractal dimension of fractal aerosol. + REAL(kind=mm_wp), INTENT(in) :: rm + !! Monomer radius in meter. + REAL(kind=mm_wp), INTENT(in) :: rho_aer + !! Aerosol density in \(kg.m^{-3}\). + REAL(kind=mm_wp), INTENT(in) :: p_prod + !! Aerosol production pressure level in Pa. + REAL(kind=mm_wp), INTENT(in) :: tx_prod + !! Spherical aerosol mode production rate in \(kg.m^{-2}.s^{-1}\). + REAL(kind=mm_wp), INTENT(in) :: rc_prod + !! Spherical mode characteristic radius for production in meter. + REAL(kind=mm_wp), INTENT(in) :: rplanet + !! Planet radius in meter + REAL(kind=mm_wp), INTENT(in) :: g0 + !! Planet gravity acceleration at ground level in \(m.s^{-2}\). + REAL(kind=mm_wp), INTENT(in) :: air_rad + !! Air molecules mean radius in meter. + REAL(kind=mm_wp), INTENT(in) :: air_mmol + !! Air molecules mean molar mass in \(kg.mol^{-1}\). + INTEGER, INTENT(in) :: coag_interactions + !! Coagulation interactions process control flag. + LOGICAL, INTENT(in) :: clouds + !! Clouds microphysics control flag. + CHARACTER(len=*), INTENT(in) :: spcfile + !! Clouds microphysics condensible species properties file. + REAL(kind=mm_wp), INTENT(in), OPTIONAL :: fiadero_max + !! Maximum moment ratio threshold for Fiadero correction (default: 10.) . + REAL(kind=mm_wp), INTENT(in), OPTIONAL :: fiadero_min + !! Minimum moment ratio threshold for Fiadero correction (default: 0.1). + LOGICAL, INTENT(in), OPTIONAL :: w_haze_prod + !! Haze microphysics production process control flag (default: T). + LOGICAL, INTENT(in), OPTIONAL :: w_haze_sed + !! Haze microphysics sedimentation process control flag (default: T). + LOGICAL, INTENT(in), OPTIONAL :: w_haze_coag + !! Haze microphysics coagulation process control flag (default: T). + LOGICAL, INTENT(in), OPTIONAL :: w_cloud_sed + !! Cloud microphysics nucleation/conensation process control flag (default: __clouds__ value). + LOGICAL, INTENT(in), OPTIONAL :: w_cloud_nucond + !! Cloud microphysics production process control flag (default: __clouds__ value). + LOGICAL, INTENT(in), OPTIONAL :: no_fiadero + !! Disable Fiadero correction for haze sedimentation process (default: F). + LOGICAL, INTENT(in), OPTIONAL :: force_wsed_to_m0 + !! force __all__ aerosols moments to fall at M0 settling velocity (default: T). + LOGICAL, INTENT(in), OPTIONAL :: force_wsed_to_m3 + !! Force __all__ aerosols moments to fall at M3 settling velocity (default: F). + TYPE(error) :: err + !! Error status of the function. + INTEGER :: i + TYPE(cfgparser) :: cp + CHARACTER(len=st_slen) :: spcpath + CHARACTER(len=:), ALLOCATABLE :: defmsg + CHARACTER(len=st_slen), DIMENSION(:), ALLOCATABLE :: species + REAL(kind=mm_wp) :: zfiamin,zfiamax + LOGICAL :: zwhp,zwhs,zwhc,zwcs,zwcn,znofia, & + zwstom0,zwstom3 + + zwhp = .true. ; zwhs = .true. ; zwhc = .true. + zwcs = clouds ; zwcn = clouds + znofia = .false. ; zfiamin = 0.1_mm_wp ; zfiamax = 10._mm_wp + zwstom0 = .true. ; zwstom3 = .false. + err = noerror + IF (mm_ini) THEN + err = error("mm_global_init: YAMMS global initialization already performed !",-1) + RETURN + ENDIF + + ! Store options values in global variables... + mm_df = df + mm_rm = rm + mm_rb2ra = mm_rm**((mm_df-3._mm_wp)/mm_df) ! conversion factor for bulk -> fractal radius + mm_rhoaer = rho_aer + mm_p_prod = p_prod + mm_tx_prod = tx_prod + mm_rc_prod = rc_prod + mm_rpla = rplanet + mm_g0 = g0 + mm_dt = dt + mm_air_rad = mm_air_rad + mm_air_mmol = air_mmol + mm_coag_choice = coag_interactions + ! check coagulation interactions choice + IF (mm_coag_choice < 0 .OR. mm_coag_choice > 7) THEN + err = error("mm_global_init: Invalid choice for coagulation interactions activation",-1) + RETURN + ENDIF + + mm_w_clouds = clouds + + ! Check clouds microphysics species file + ! (only if clouds is activated) + IF (mm_w_clouds) THEN + IF (LEN_TRIM(spcfile) == 0) THEN + err = error("mm_global_init: No species properties file given",-1) + RETURN + ENDIF + ! Reads species properties configuration file + err = cfg_read_config(cp,TRIM(spcfile)) ; IF (err /= 0) RETURN + err = cfg_get_value(cp,"used_species",species) + IF (err /= 0) THEN + err = error("mm_global_init: cannot retrieve 'used_species' values",-1) + RETURN + ENDIF + ! Now attempts to find species properties !!! + mm_nesp = SIZE(species) + ALLOCATE(mm_spcname(mm_nesp),mm_xESPS(mm_nesp)) + DO i=1,mm_nesp + mm_spcname(i) = str_to_lower(species(i)) + IF(.NOT.cfg_has_section(cp,TRIM(mm_spcname(i)))) THEN + err = error("mm_global_init: Cannot find "//TRIM(mm_spcname(i))//" properties",-1) + RETURN + ELSE + err = read_esp(cp,TRIM(mm_spcname(i)),mm_xESPS(i)) + ! compute conversion factor: mol.mol-1 => kg.kg-1 + mm_xESPS(i)%fmol2fmas = mm_xESPS(i)%masmol / mm_air_mmol + IF (err/=0) THEN + err = error("mm_global_init: "//TRIM(mm_spcname(i))//": "//TRIM(err%msg),-1) + RETURN + ENDIF + ENDIF + ENDDO + ENDIF + + ! optional flags + ! haze control flags + IF (PRESENT(w_haze_prod)) THEN + mm_w_haze_prod = w_haze_prod + ELSE + mm_w_haze_prod = zwhp + call printw("mm_haze_production",to_string(mm_w_haze_prod)) + ENDIF + IF (PRESENT(w_haze_sed)) THEN + mm_w_haze_sed = w_haze_sed + ELSE + mm_w_haze_sed = zwhs + call printw("mm_haze_sedimentation",to_string(mm_w_haze_sed)) + ENDIF + IF (PRESENT(w_haze_coag)) THEN + mm_w_haze_coag = w_haze_coag + ELSE + mm_w_haze_coag = zwhc + call printw("mm_haze_coagulation",to_string(mm_w_haze_coag)) + ENDIF + IF (PRESENT(force_wsed_to_m0)) THEN + mm_wsed_m0 = force_wsed_to_m0 + ELSE + mm_wsed_m0 = zwstom0 + call printw("mm_wsed_m0",to_string(mm_wsed_m0)) + ENDIF + IF (PRESENT(force_wsed_to_m3)) THEN + mm_wsed_m3 = force_wsed_to_m3 + ELSE + mm_wsed_m3 = zwstom3 + call printw("mm_wsed_m3",to_string(mm_wsed_m3)) + ENDIF + IF (PRESENT(no_fiadero)) THEN + mm_no_fiadero_w = no_fiadero + ELSE + mm_no_fiadero_w = znofia + call printw("mm_no_fiadero",to_string(mm_no_fiadero_w)) + ENDIF + IF (PRESENT(fiadero_min)) THEN + mm_fiadero_min = fiadero_min + ELSE + mm_fiadero_min = zfiamin + call printw("mm_fiadero_min",to_string(mm_fiadero_min)) + ENDIF + IF (PRESENT(fiadero_max)) THEN + mm_fiadero_max = fiadero_max + ELSE + mm_fiadero_max = zfiamax + call printw("mm_fiadero_max",to_string(mm_fiadero_max)) + ENDIF + ! clouds control flags + IF (mm_w_clouds) THEN + IF (PRESENT(w_cloud_sed)) THEN + mm_w_cloud_sed = w_cloud_sed + ELSE + mm_w_cloud_sed = zwcs + call printw("mm_cloud_sed",to_string(mm_w_cloud_sed)) + ENDIF + IF (PRESENT(w_cloud_nucond)) THEN + mm_w_cloud_nucond = w_cloud_nucond + ELSE + mm_w_cloud_nucond = zwcs + call printw("mm_cloud_nucond",to_string(mm_w_cloud_nucond)) + ENDIF + ENDIF + + ! check w sed flags + err = noerror + ! special check for settling velocity + IF (mm_wsed_m0 .AND. mm_wsed_m3) THEN + err = error("'wsed_m0' and 'wsed_m3' options are mutually exclusive",-1) + ENDIF + mm_ini = err == noerror + + CONTAINS + + SUBROUTINE printw(string,value) + !! Print a warning message. + CHARACTER(len=*), INTENT(in) :: string !! Name of the option. + CHARACTER(len=*), INTENT(in) :: value !! (string) Value of the option. + IF (mm_log) & + WRITE(*,'(a,a,a)') "warning: Parameter "//string//"not given... Using default value: "//value + END SUBROUTINE printw + END FUNCTION mm_global_init_0 + + FUNCTION mm_global_init_1(cfg) RESULT(err) + !! Set global configuration from a configuration file. + !! + !! See [[mm_globals(module):mm_global_init_0(function)]]. + TYPE(cfgparser), INTENT(in) :: cfg !! Configuration file path. + TYPE(error) :: err !! Error status of the function. + INTEGER :: i + TYPE(cfgparser) :: spccfg + CHARACTER(len=st_slen) :: spcpath + CHARACTER(len=:), ALLOCATABLE :: defmsg + CHARACTER(len=st_slen), DIMENSION(:), ALLOCATABLE :: species + REAL(kind=mm_wp) :: zfiamin,zfiamax + LOGICAL :: zwhp,zwhs,zwhc,zwcs,zwcn,znofia, & + zwstom0,zwstom3 + + err = noerror + + IF (mm_ini) THEN + err = error("mm_global_init: YAMMS global initialization already performed !",-1) + RETURN + ENDIF + + ! MP2M mandatory parameters + err = mm_check_opt(cfg_get_value(cfg,"df",mm_df),mm_df,wlog=mm_log) + IF (err/=0) RETURN + err = mm_check_opt(cfg_get_value(cfg,"rm",mm_rm),mm_rm,wlog=mm_log) + IF (err/=0) RETURN + err = mm_check_opt(cfg_get_value(cfg,"rho_aer",mm_rhoaer),mm_rhoaer,wlog=mm_log) + IF (err/=0) RETURN + err = mm_check_opt(cfg_get_value(cfg,"p_prod",mm_p_prod),mm_p_prod,wlog=mm_log) + IF (err/=0) RETURN + err = mm_check_opt(cfg_get_value(cfg,"tx_prod",mm_tx_prod),mm_tx_prod,wlog=mm_log) + IF (err/=0) RETURN + err = mm_check_opt(cfg_get_value(cfg,"rc_prod",mm_rc_prod),mm_rc_prod,wlog=mm_log) + IF (err/=0) RETURN + err = mm_check_opt(cfg_get_value(cfg,"planet_radius",mm_rpla),mm_rpla,wlog=mm_log) + IF (err/=0) RETURN + err = mm_check_opt(cfg_get_value(cfg,"g0",mm_g0),mm_g0,wlog=mm_log) + IF (err/=0) RETURN + err = mm_check_opt(cfg_get_value(cfg,"timestep",mm_dt),mm_dt,wlog=mm_log) + IF (err/=0) RETURN + err = mm_check_opt(cfg_get_value(cfg,"air_radius",mm_air_rad),mm_air_rad,wlog=mm_log) + IF (err/=0) RETURN + err = mm_check_opt(cfg_get_value(cfg,"air_molarmass",mm_air_mmol),mm_air_mmol,wlog=mm_log) + IF (err/=0) RETURN + err = mm_check_opt(cfg_get_value(cfg,"haze_coag_interactions",mm_coag_choice),mm_coag_choice,wlog=mm_log) + IF (err/=0) RETURN + err = mm_check_opt(cfg_get_value(cfg,"clouds_microphysics",mm_w_clouds),mm_w_clouds,wlog=mm_log) + IF (err/=0) RETURN + + ! computes the conversion factor for bulk -> fractal radius + mm_rb2ra = mm_rm**((mm_df-3._mm_wp)/mm_df) + + ! Check coagulation interactions choice + IF (mm_coag_choice < 0 .OR. mm_coag_choice > 7) THEN + err = error("mm_global_init: Invalid choice for coagulation interactions activation",-1) + RETURN + ENDIF + + ! Check clouds microphysics input + ! it is read only if clouds is activated. We must to check if it is self-consistent... + IF (mm_w_clouds) THEN + ! Gets species property file path + err = cfg_get_value(cfg,'specie_cfg',spcpath) ; IF (err /= 0) RETURN + ! Reads species properties configuration file + err = cfg_read_config(spccfg,trim(spcpath)) ; IF (err /= 0) RETURN + err = cfg_get_value(spccfg,"used_species",species) + IF (err /= 0) THEN + err = error("mm_global_init: cannot retrieve 'used_species' values",-1) + RETURN + ENDIF + ! Now attempts to find specides properties !!! + mm_nesp = SIZE(species) + ALLOCATE(mm_spcname(mm_nesp),mm_xESPS(mm_nesp)) + !mm_spcname(1:mm_nesp) = species(:) + DO i=1,mm_nesp + mm_spcname(i) = str_to_lower(species(i)) + IF (.NOT.cfg_has_section(spccfg,TRIM(mm_spcname(i)))) THEN + err = error("mm_global_init: Cannot find "//TRIM(mm_spcname(i))//" properties",-1) + RETURN + ELSE + err = read_esp(spccfg,TRIM(mm_spcname(i)),mm_xESPS(i)) + ! compute conversion factor: mol.mol-1 => kg.kg-1 + mm_xESPS(i)%fmol2fmas = mm_xESPS(i)%masmol / mm_air_mmol + IF (err/=0) THEN + err = error(TRIM(mm_spcname(i))//": "//TRIM(err%msg),-2) + RETURN + ENDIF + ENDIF + ENDDO + ENDIF + + zwhp = .true. ; zwhs = .true. ; zwhc = .true. + zwcs = mm_w_clouds ; zwcn = mm_w_clouds + znofia = .false. ; zfiamin = 0.1_mm_wp ; zfiamax = 10._mm_wp + zwstom0 = .true. ; zwstom3 = .false. + + ! MP2M Optional parameters + err = mm_check_opt(cfg_get_value(cfg,"haze_production",mm_w_haze_prod),mm_w_haze_prod,zwhp,wlog=mm_log) + err = mm_check_opt(cfg_get_value(cfg,"haze_sedimentation",mm_w_haze_sed),mm_w_haze_sed,zwhs,wlog=mm_log) + err = mm_check_opt(cfg_get_value(cfg,"haze_coagulation",mm_w_haze_coag),mm_w_haze_coag,zwhc,wlog=mm_log) + err = mm_check_opt(cfg_get_value(cfg,"clouds_sedimentation",mm_w_cloud_sed),mm_w_cloud_sed,zwcs,wlog=mm_log) + err = mm_check_opt(cfg_get_value(cfg,"clouds_nucl_cond",mm_w_cloud_nucond),mm_w_cloud_nucond,zwcn,wlog=mm_log) + err = mm_check_opt(cfg_get_value(cfg,"wsed_m0",mm_wsed_m0),mm_wsed_m0,zwstom0,wlog=mm_log) + err = mm_check_opt(cfg_get_value(cfg,"wsed_m3",mm_wsed_m3),mm_wsed_m3,zwstom3,wlog=mm_log) + err = mm_check_opt(cfg_get_value(cfg,"no_fiadero",mm_no_fiadero_w),mm_no_fiadero_w,znofia,wlog=mm_log) + err = mm_check_opt(cfg_get_value(cfg,"fiadero_min_ratio",mm_fiadero_min),mm_fiadero_min,zfiamin,wlog=mm_log) + err = mm_check_opt(cfg_get_value(cfg,"fiadero_max_ratio",mm_fiadero_max),mm_fiadero_max,zfiamax,wlog=mm_log) + + err = noerror + ! special check for settling velocity + IF (mm_wsed_m0 .AND. mm_wsed_m3) THEN + err = error("'wsed_m0' and 'wsed_m3' options are mutually exclusive",-1) + ENDIF + mm_ini = err == noerror + END FUNCTION mm_global_init_1 + + FUNCTION mm_column_init(plev,zlev,play,zlay,temp) RESULT(err) + !! Initialize vertical atmospheric fields. + !! + !! This subroutine initializes vertical fields needed by the microphysics: + !! + !! 1. Save reversed input field into "local" array + !! 2. Compute thicknesses layers and levels + !! 3. Interpolate temperature at levels + !! + !! The method should be called whenever the vertical structure of the atmosphere changes. + !! + !! @attention + !! All the input vectors should be defined from __GROUND__ to __TOP__ of the atmosphere, + !! otherwise nasty things will occur in computations. + REAL(kind=mm_wp), DIMENSION(:), INTENT(in) :: plev !! Pressure levels (Pa). + REAL(kind=mm_wp), DIMENSION(:), INTENT(in) :: zlev !! Altitude levels (m). + REAL(kind=mm_wp), DIMENSION(:), INTENT(in) :: play !! Pressure layers (Pa). + REAL(kind=mm_wp), DIMENSION(:), INTENT(in) :: zlay !! Altitude at the center of each layer (m). + REAL(kind=mm_wp), DIMENSION(:), INTENT(in) :: temp !! Temperature at the center of each layer (K). + TYPE(error) :: err !! Error status of the function. + INTEGER :: i + mm_ini_col = .false. + err = noerror + IF (.NOT.mm_ini) THEN + err = error("mm_column_init: Global initialization not done yet",-1) + RETURN + ENDIF + IF (mm_nla < 0) THEN + mm_nla = SIZE(play) + ELSE + IF (mm_nla /= SIZE(play)) THEN + err = error("mm_column_init: mm_nla cannot be modified dynamically within the run",-1) + RETURN + ENDIF + ENDIF + IF (mm_nle < 0) THEN + mm_nle = SIZE(plev) + ELSE + IF (mm_nle /= SIZE(plev)) THEN + err = error("mm_column_init: mm_nle cannot be modified dynamically within the run",-1) + RETURN + ENDIF + ENDIF + ! should be trashed soon or later + IF (mm_nla+1 /= mm_nle) THEN + err = error("mm_column_init: Inconsistent number of layers/levels",-1) + RETURN + ENDIF + ! Allocates if required + IF (.NOT.ALLOCATED(mm_plev)) ALLOCATE(mm_plev(mm_nle)) + IF (.NOT.ALLOCATED(mm_zlev)) ALLOCATE(mm_zlev(mm_nle)) + IF (.NOT.ALLOCATED(mm_play)) ALLOCATE(mm_play(mm_nla)) + IF (.NOT.ALLOCATED(mm_zlay)) ALLOCATE(mm_zlay(mm_nla)) + IF (.NOT.ALLOCATED(mm_temp)) ALLOCATE(mm_temp(mm_nla)) + IF (.NOT.ALLOCATED(mm_btemp)) ALLOCATE(mm_btemp(mm_nle)) + IF (.NOT.ALLOCATED(mm_dzlev)) ALLOCATE(mm_dzlev(mm_nla)) + IF (.NOT.ALLOCATED(mm_dzlay)) ALLOCATE(mm_dzlay(mm_nla)) + IF (.NOT.ALLOCATED(mm_rhoair)) ALLOCATE(mm_rhoair(mm_nla)) + ! Saves reversed input vectors + mm_zlay = zlay(mm_nla:1:-1) ; mm_zlev = zlev(mm_nle:1:-1) + mm_play = play(mm_nla:1:-1) ; mm_plev = plev(mm_nle:1:-1) + mm_temp = temp(mm_nla:1:-1) + ! Computes others vectors + mm_dzlay(1:mm_nla-1) = mm_zlay(1:mm_nla-1)-mm_zlay(2:mm_nla) + mm_dzlay(mm_nla) = mm_dzlay(mm_nla-1) ! actually arbitrary + mm_dzlev(1:mm_nla) = mm_zlev(1:mm_nle-1)-mm_zlev(2:mm_nle) + mm_btemp(2:mm_nla) = (mm_temp(1:mm_nla-1)+mm_temp(2:mm_nla))/2._mm_wp + mm_btemp(1) = mm_temp(1) + mm_btemp(mm_nle) = mm_temp(mm_nla)+(mm_temp(mm_nla)-mm_temp(mm_nla-1))/2._mm_wp + ! Hydrostatic equilibrium + mm_rhoair(1:mm_nla) = (mm_plev(2:mm_nle)-mm_plev(1:mm_nla)) / & + (mm_effg(mm_zlay)*mm_dzlev) + mm_ini_col = .true. + ! write out profiles (only if BOTH debug and log are enabled). + IF (mm_log.AND.mm_debug) THEN + WRITE(*,'(a)') '# TEMP PLAY ZLAY DZLAY RHOAIR' + DO i=1,mm_nla + WRITE(*,'(5(ES15.7,2X))') mm_temp(i),mm_play(i),mm_zlay(i),mm_dzlay(i), mm_rhoair(i) + ENDDO + WRITE(*,'(a)') '# TEMP PLEV ZLEV DZLEV' + DO i=1,mm_nle + IF (i /= mm_nle) THEN + WRITE(*,'(4(ES15.7,2X))') mm_btemp(i),mm_plev(i),mm_zlev(i),mm_dzlev(i) + ELSE + WRITE(*,'(3(ES15.7,2X))') mm_btemp(i),mm_plev(i),mm_zlev(i) + ENDIF + ENDDO + ENDIF + + RETURN + END FUNCTION mm_column_init + + FUNCTION mm_aerosols_init(m0aer_s,m3aer_s,m0aer_f,m3aer_f) RESULT(err) + !! Initialize clouds tracers vertical grid. + !! + !! The subroutine initializes aerosols microphysics tracers columns. It allocates variables if + !! required and stores input vectors in reversed order. It also computes the characteristic radii + !! of each mode. + !! @note + !! All the input arguments should be defined from ground to top. + !! + !! @attention + !! [[mm_globals(module):mm_global_init(interface)]] and [[mm_globals(module):mm_column_init(function)]] + !! must have been called at least once before this method is called. Moreover, this method should be + !! after each call of [[mm_globals(module):mm_column_init(function)]] to reflect changes in the + !! vertical atmospheric structure. + REAL(kind=mm_wp), DIMENSION(:), INTENT(in) :: m0aer_s !! \(0^{th}\) order moment of the spherical mode (\(m^{-2}\)). + REAL(kind=mm_wp), DIMENSION(:), INTENT(in) :: m3aer_s !! \(3^{rd}\) order moment of the spherical mode (\(m^{3}.m^{-2}\)). + REAL(kind=mm_wp), DIMENSION(:), INTENT(in) :: m0aer_f !! \(0^{th}\) order moment of the fractal mode (\(m^{-2}\)). + REAL(kind=mm_wp), DIMENSION(:), INTENT(in) :: m3aer_f !! \(3^{rd}\) order moment of the fractal mode (\(m^{3}.m^{-2}\)). + TYPE(error) :: err !! Error status of the function. + err = noerror + IF (.NOT.mm_ini) THEN + err = error("mm_aerosols_init: Global initialization not done yet",-1) ; RETURN + ENDIF + IF (.NOT.mm_ini_col) THEN + err = error("mm_aerosols_init: Column initialization not done yet",-1) ; RETURN + ENDIF + ! Check input size ??? + IF (SIZE(m0aer_s) /= mm_nla) THEN + err = error("mm_aerosols_init: Invalid size for input arrays",-1) ; RETURN + ENDIF + + ! Allocate variable if required + IF (.NOT.ALLOCATED(mm_m0aer_s)) ALLOCATE(mm_m0aer_s(mm_nla)) + IF (.NOT.ALLOCATED(mm_m3aer_s)) ALLOCATE(mm_m3aer_s(mm_nla)) + IF (.NOT.ALLOCATED(mm_m0aer_f)) ALLOCATE(mm_m0aer_f(mm_nla)) + IF (.NOT.ALLOCATED(mm_m3aer_f)) ALLOCATE(mm_m3aer_f(mm_nla)) + IF (.NOT.ALLOCATED(mm_rcs)) ALLOCATE(mm_rcs(mm_nla)) + IF (.NOT.ALLOCATED(mm_rcf)) ALLOCATE(mm_rcf(mm_nla)) + ! Allocate memory for diagnostics + IF (.NOT.ALLOCATED(mm_aer_s_flux)) THEN + ALLOCATE(mm_aer_s_flux(mm_nla)) ; mm_aer_s_flux(:) = 0._mm_wp + ENDIF + IF (.NOT.ALLOCATED(mm_aer_f_flux)) THEN + ALLOCATE(mm_aer_f_flux(mm_nla)) ; mm_aer_f_flux(:) = 0._mm_wp + ENDIF + IF (.NOT.ALLOCATED(mm_m0as_vsed)) THEN + ALLOCATE(mm_m0as_vsed(mm_nla)) ; mm_m0as_vsed(:) = 0._mm_wp + ENDIF + IF (.NOT.ALLOCATED(mm_m3as_vsed)) THEN + ALLOCATE(mm_m3as_vsed(mm_nla)) ; mm_m3as_vsed(:) = 0._mm_wp + ENDIF + IF (.NOT.ALLOCATED(mm_m0af_vsed)) THEN + ALLOCATE(mm_m0af_vsed(mm_nla)) ; mm_m0af_vsed(:) = 0._mm_wp + ENDIF + IF (.NOT.ALLOCATED(mm_m3af_vsed)) THEN + ALLOCATE(mm_m3af_vsed(mm_nla)) ; mm_m3af_vsed(:) = 0._mm_wp + ENDIF + ! note : mm_dzlev is already from top to ground + mm_m0aer_s = m0aer_s(mm_nla:1:-1)/mm_dzlev(:) + mm_m3aer_s = m3aer_s(mm_nla:1:-1)/mm_dzlev(:) + mm_m0aer_f = m0aer_f(mm_nla:1:-1)/mm_dzlev(:) + mm_m3aer_f = m3aer_f(mm_nla:1:-1)/mm_dzlev(:) + ! aerosols characteristic radii + ! il faudrait peut etre revoir la gestion des zeros ici et la + ! remplacer par une valeur seuil des moments. + WHERE(mm_m3aer_s > 0._mm_wp .AND. mm_m0aer_s > 0._mm_wp) + mm_rcs = mm_get_rcs(mm_m0aer_s,mm_m3aer_s) + ELSEWHERE + mm_rcs = 0._mm_wp + ENDWHERE + WHERE(mm_m3aer_f > 0._mm_wp .AND. mm_m0aer_f > 0._mm_wp) + mm_rcf = mm_get_rcf(mm_m0aer_f,mm_m3aer_f) + ELSEWHERE + mm_rcf = 0._mm_wp + ENDWHERE + mm_ini_aer = .true. + END FUNCTION mm_aerosols_init + + FUNCTION mm_clouds_init(m0ccn,m3ccn,m3ice,gazs) RESULT(err) + !! Initialize clouds tracers vertical grid. + !! + !! The subroutine initializes cloud microphysics tracers columns. It allocates variables if + !! required and stores input vectors in reversed order. It also computes the mean drop radius + !! and density and allocates diagnostic vectors. + !! @note + !! All the input arguments should be defined from ground to top. + !! + !! @attention + !! [[mm_globals(module):mm_global_init(interface)]] and [[mm_globals(module):mm_column_init(function)]] + !! must have been called at least once before this method is called. Moreover, this method should be + !! after each call of [[mm_globals(module):mm_column_init(function)]] to reflect changes in the + !! vertical atmospheric structure. + REAL(kind=mm_wp), DIMENSION(:), INTENT(in) :: m0ccn !! 0th order moment of the CCN distribution (\(m^{-2}\)). + REAL(kind=mm_wp), DIMENSION(:), INTENT(in) :: m3ccn !! 3rd order moment of the CCN distribution (\(m^{3}.m^{-2}\)). + REAL(kind=mm_wp), DIMENSION(:,:), INTENT(in) :: m3ice !! 3rd order moments of the ice components (\(m^{3}.m^{-2}\)). + REAL(kind=mm_wp), DIMENSION(:,:), INTENT(in) :: gazs !! Condensible species gazs molar fraction (\(mol.mol^{-1}\)). + TYPE(error) :: err !! Error status of the function. + INTEGER :: i + err = noerror + IF (.NOT.mm_ini) THEN + err = error("Global initialization not done yet",-8) + RETURN + ENDIF + + IF (.NOT.mm_w_clouds) THEN + IF (mm_debug) WRITE(*,'(a)') "WARNING: Cloud microphysic is not enabled..." + RETURN + ENDIF + + ! Note: + ! Here we could check that mm_nla is the same size of gazs(DIM=1) + ! Actually, mm_nla should always initialized the first time mm_column_init is called, NOT HERE. + IF (mm_nla < 0) mm_nla = SIZE(gazs,DIM=1) + ! Note: + ! here we could check that mm_nesp is the same size of gazs(DIM=2) + ! Actually, mm_nesp should be always initialized in mm_global_init, NOT HERE. + IF (mm_nesp < 0) mm_nesp = SIZE(gazs,DIM=2) + + ! Allocate variable if required + IF (.NOT.ALLOCATED(mm_m0ccn)) ALLOCATE(mm_m0ccn(mm_nla)) + IF (.NOT.ALLOCATED(mm_m3ccn)) ALLOCATE(mm_m3ccn(mm_nla)) + IF (.NOT.ALLOCATED(mm_m3ice)) ALLOCATE(mm_m3ice(mm_nla,mm_nesp)) + IF (.NOT.ALLOCATED(mm_gazs)) ALLOCATE(mm_gazs(mm_nla,mm_nesp)) + IF (.NOT.ALLOCATED(mm_drad)) ALLOCATE(mm_drad(mm_nla)) + IF (.NOT.ALLOCATED(mm_drho)) ALLOCATE(mm_drho(mm_nla)) + ! Allocate memory for diagnostics + IF (.NOT.ALLOCATED(mm_ccn_flux)) THEN + ALLOCATE(mm_ccn_flux(mm_nla)) ; mm_ccn_flux(:) = 0._mm_wp + ENDIF + IF (.NOT.ALLOCATED(mm_ice_prec)) THEN + ALLOCATE(mm_ice_prec(mm_nesp)) ; mm_ice_prec(:) = 0._mm_wp + ENDIF + IF (.NOT.ALLOCATED(mm_ice_fluxes)) THEN + ALLOCATE(mm_ice_fluxes(mm_nla,mm_nesp)) ; mm_ice_fluxes(:,:) = 0._mm_wp + ENDIF + IF (.NOT.ALLOCATED(mm_gazs_sat)) THEN + ALLOCATE(mm_gazs_sat(mm_nla,mm_nesp)) ; mm_gazs_sat(:,:) = 0._mm_wp + ENDIF + + ! note mm_dzlev already from top to ground + mm_m0ccn = m0ccn(mm_nla:1:-1)/mm_dzlev(:) + mm_m3ccn = m3ccn(mm_nla:1:-1)/mm_dzlev(:) + DO i=1,mm_nesp + mm_m3ice(:,i) = m3ice(mm_nla:1:-1,i)/mm_dzlev(:) + mm_gazs(:,i) = gazs(mm_nla:1:-1,i) + ENDDO + ! drop mean radius + call mm_cloud_properties(mm_m0ccn,mm_m3ccn,mm_m3ice,mm_drad,mm_drho) + mm_ini_cld = .true. + END FUNCTION mm_clouds_init + + SUBROUTINE mm_dump_parameters() + !! Dump model global parameters on stdout. + WRITE(*,'(a)') "========= YAMMS PARAMETERS ============" + WRITE(*,'(a,L2)') "mm_w_haze_prod : ", mm_w_haze_prod + WRITE(*,'(a,ES14.7)') " mm_p_prod : ", mm_p_prod + WRITE(*,'(a,ES14.7)') " mm_tx_prod : ", mm_tx_prod + WRITE(*,'(a,ES14.7)') " mm_rc_prod : ", mm_rc_prod + WRITE(*,'(a,L2)') "mm_w_haze_coag : ", mm_w_haze_coag + WRITE(*,'(a,I2.2)') " mm_coag_interactions: ", mm_coag_choice + WRITE(*,'(a,L2)') "mm_w_haze_sed : ", mm_w_haze_sed + WRITE(*,'(a,L2)') " mm_wsed_m0 : ", mm_wsed_m0 + WRITE(*,'(a,L2)') " mm_wsed_m3 : ", mm_wsed_m3 + WRITE(*,'(a,L2)') " mm_no_fiadero_w : ", mm_no_fiadero_w + WRITE(*,'(a,ES14.7)') " mm_fiadero_min : ", mm_fiadero_min + WRITE(*,'(a,ES14.7)') " mm_fiadero_max : ", mm_fiadero_max + WRITE(*,'(a,L2)') "mm_w_clouds : ", mm_w_clouds + WRITE(*,'(a,L2)') " mm_w_cloud_sed : ", mm_w_cloud_sed + WRITE(*,'(a,L2)') " mm_w_cloud_nucond : ", mm_w_cloud_nucond + WRITE(*,'(a)') "---------------------------------------" + WRITE(*,'(a,ES14.7)') "mm_dt : ", mm_dt + IF (mm_nla > -1) THEN + WRITE(*,'(a,I3.3)') "mm_nla : ", mm_nla + ELSE + WRITE(*,'(a)') "mm_nla : not initialized yet" + ENDIF + WRITE(*,'(a,ES14.7)') "mm_df : ", mm_df + WRITE(*,'(a,ES14.7)') "mm_rm : ", mm_rm + WRITE(*,'(a,ES14.7)') "mm_rpla : ", mm_rpla + WRITE(*,'(a,ES14.7)') "mm_g0 : ", mm_g0 + WRITE(*,'(a)') "=======================================" + END SUBROUTINE mm_dump_parameters + + ELEMENTAL FUNCTION mm_get_rcs(m0,m3) RESULT(res) + !! Get the characteristic radius for the spherical aerosols size distribution. + !! + !! The method computes the characteristic radius of the size distribution law + !! of the spherical aerosols mode according to its moments and its inter-moments + !! relation. + REAL(kind=mm_wp), INTENT(in) :: m0 !! \(0^{th}\) order moment + REAL(kind=mm_wp), INTENT(in) :: m3 !! \(3^{rd}\) order moment + REAL(kind=mm_wp) :: res !! Radius + ! arbitrary: if there is no way to compute radius + IF (m3 <= 0._mm_wp .OR. m0 <= 0._mm_wp) res = 1._mm_wp + res = (m3/m0/mm_alpha_s(3._mm_wp))**(1._mm_wp/3._mm_wp) + END FUNCTION mm_get_rcs + + ELEMENTAL FUNCTION mm_get_rcf(m0,m3) RESULT(res) + !! Get the characteristic radius for the fractal aerosols size distribution. + !! + !! The method computes the characteristic radius of the size distribution law + !! of the fractal aerosols mode according to its moments and its inter-moments + !! relation. + REAL(kind=mm_wp), INTENT(in) :: m0 !! \(0^{th}\) order moment + REAL(kind=mm_wp), INTENT(in) :: m3 !! \(3^{rd}\) order moment + REAL(kind=mm_wp) :: res !! Radius + ! arbitrary: if there is no way to compute radius + IF (m3 <= 0._mm_wp .OR. m0 <= 0._mm_wp) res = 1._mm_wp + res = (m3/m0/mm_alpha_f(3._mm_wp))**(1._mm_wp/3._mm_wp) + END FUNCTION mm_get_rcf + + ELEMENTAL FUNCTION mm_effg(z) RESULT(effg) + !! Compute effective gravitational acceleration. + REAL(kind=mm_wp), INTENT(in) :: z !! Altitude in meters + REAL(kind=mm_wp) :: effg !! Effective gravitational acceleration in \(m.s^{-2}\) + effg = mm_g0 * (mm_rpla/(mm_rpla+z))**2 + RETURN + END FUNCTION mm_effg + + !================================== + ! --- private methods ------------- + !================================== + + SUBROUTINE cldprop_sc(m0ccn,m3ccn,m3ice,drad,drho) + !! Get cloud drop properties (scalar). + !! + !! The method computes the mean radius and mean density of cloud drops. + !! + !! @bug + !! A possible bug can happen because of threshold snippet. If __drad__ is greater than + !! __drmax__ (== 100 microns) it is automatically set to __drmax__, but computation of + !! __drho__ remains unmodified. So __drho__ is not correct in that case. + !! + !! @todo + !! Fix the bug of the subroutine, but it is rather minor, since theoretically we do not + !! need the density of the drop. + !! + !! @todo + !! Think about a better implementation of thresholds, and get sure of their consequences in + !! the other parts of the model. + REAL(kind=mm_wp), INTENT(in) :: m0ccn !! \(0^{th}\) order moment of the ccn + REAL(kind=mm_wp), INTENT(in) :: m3ccn !! \(3^{rd}\) order moment of the ccn + REAL(kind=mm_wp), INTENT(in), DIMENSION(:) :: m3ice !! \(3^{rd}\) order moments of each ice component + REAL(kind=mm_wp), INTENT(out) :: drad !! Output mean drop radius + REAL(kind=mm_wp), INTENT(out), OPTIONAL :: drho !! Optional output mean drop density + REAL(kind=mm_wp) :: vtot, wtot, ntot + REAL(kind=mm_wp), PARAMETER :: threshold = 1.e-25_mm_wp, & + drmin = 1.e-10_mm_wp, & + drmax = 1.e-4_mm_wp, & + athird = 1._mm_wp/3._mm_wp, & + pifac = 4._mm_wp/3._mm_wp*mm_pi + drad = 0._mm_wp + ntot = m0ccn + vtot = pifac*m3ccn+SUM(m3ice) + wtot = pifac*m3ccn*mm_rhoaer+SUM(m3ice*mm_xESPS(:)%rho) + IF (ntot <= threshold .OR. vtot <= 0._mm_wp) THEN + drad = drmin + IF (PRESENT(drho)) drho = mm_rhoaer + ELSE + drad = (vtot/ntot/pifac)**athird + drad = MAX(MIN(drad,drmax),drmin) + IF (PRESENT(drho)) drho = wtot/vtot + ENDIF + RETURN + END SUBROUTINE cldprop_sc + + SUBROUTINE cldprop_ve(m0ccn,m3ccn,m3ice,drad,drho) + !! Get cloud drop properties (vector). + !! + !! The method performs the same computations than [[mm_globals(module):cldprop_sc(subroutine)]] + !! but for the entire vertical atmospheric structure. + !! Same remarks apply here. + REAL(kind=mm_wp), INTENT(in), DIMENSION(:) :: m0ccn !! 0th order moment of the ccn. + REAL(kind=mm_wp), INTENT(in), DIMENSION(:) :: m3ccn !! 3rd order moment of the ccn. + REAL(kind=mm_wp), INTENT(in), DIMENSION(:,:) :: m3ice !! 3rd order moments of each ice component. + REAL(kind=mm_wp), INTENT(out), DIMENSION(:) :: drad !! Output mean drop radius. + REAL(kind=mm_wp), INTENT(out), DIMENSION(:), OPTIONAL :: drho !! Optional output mean drop density. + INTEGER :: i,ns + REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE :: vtot,wtot,ntot,rho + REAL(kind=mm_wp), PARAMETER :: threshold = 1.e-25_mm_wp, & + drmin = 1.e-10_mm_wp, & + drmax = 1.e-4_mm_wp, & + athird = 1._mm_wp/3._mm_wp, & + pifac = 4._mm_wp/3._mm_wp*mm_pi + + ns = SIZE(m0ccn) ; ALLOCATE(vtot(ns),wtot(ns),ntot(ns),rho(ns)) + drad = 0._mm_wp + ntot = m0ccn + vtot = pifac*m3ccn+SUM(m3ice,DIM=2) + wtot = pifac*m3ccn*mm_rhoaer + DO i=1,SIZE(m3ice,DIM=2) + wtot = wtot+m3ice(:,i)*mm_xESPS(i)%rho + ENDDO + WHERE(ntot <= threshold .OR. vtot <= 0._mm_wp) + drad = drmin + rho = mm_rhoaer + ELSEWHERE + drad = (vtot/ntot/pifac)**athird + drad = MAX(MIN(drad,drmax),drmin) + rho = wtot/vtot + END WHERE + IF (PRESENT(drho)) drho = rho + RETURN + END SUBROUTINE cldprop_ve + + ! For configuration file (requires fccp library). + + FUNCTION read_esp(parser,sec,pp) RESULT (err) + !! Read and store [[mm_globals(module):mm_esp(type)]] parameters. + TYPE(cfgparser), INTENT(in) :: parser !! Configuration parser. + CHARACTER(len=*), INTENT(in) :: sec !! Name of the specie (should match a section of the configuration. + TYPE(mm_esp), INTENT(out) :: pp !! [[mm_globals(module):mm_esp(type)]] object that stores the parameters. + TYPE(error) :: err !! Error status of the function. + err = cfg_get_value(parser,TRIM(sec)//'name',pp%name) ; IF (err /= 0) RETURN + err = cfg_get_value(parser,TRIM(sec)//'mas',pp%mas) ; IF (err /= 0) RETURN + err = cfg_get_value(parser,TRIM(sec)//'vol',pp%vol) ; IF (err /= 0) RETURN + err = cfg_get_value(parser,TRIM(sec)//'ray',pp%ray) ; IF (err /= 0) RETURN + err = cfg_get_value(parser,TRIM(sec)//'mas',pp%mas) ; IF (err /= 0) RETURN + err = cfg_get_value(parser,TRIM(sec)//'vol',pp%vol) ; IF (err /= 0) RETURN + err = cfg_get_value(parser,TRIM(sec)//'ray',pp%ray) ; IF (err /= 0) RETURN + err = cfg_get_value(parser,TRIM(sec)//'masmol',pp%masmol) ; IF (err /= 0) RETURN + err = cfg_get_value(parser,TRIM(sec)//'rho',pp%rho) ; IF (err /= 0) RETURN + err = cfg_get_value(parser,TRIM(sec)//'tc',pp%tc) ; IF (err /= 0) RETURN + err = cfg_get_value(parser,TRIM(sec)//'pc',pp%pc) ; IF (err /= 0) RETURN + err = cfg_get_value(parser,TRIM(sec)//'tb',pp%tb) ; IF (err /= 0) RETURN + err = cfg_get_value(parser,TRIM(sec)//'w',pp%w) ; IF (err /= 0) RETURN + err = cfg_get_value(parser,TRIM(sec)//'a_sat',pp%a_sat) ; IF (err /= 0) RETURN + err = cfg_get_value(parser,TRIM(sec)//'b_sat',pp%b_sat) ; IF (err /= 0) RETURN + err = cfg_get_value(parser,TRIM(sec)//'c_sat',pp%c_sat) ; IF (err /= 0) RETURN + err = cfg_get_value(parser,TRIM(sec)//'d_sat',pp%d_sat) ; IF (err /= 0) RETURN + err = cfg_get_value(parser,TRIM(sec)//'mteta',pp%mteta) ; IF (err /= 0) RETURN + err = cfg_get_value(parser,TRIM(sec)//'tx_prod',pp%tx_prod) ; IF (err /= 0) RETURN + RETURN + END FUNCTION read_esp + + ! ========================================================================= + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! CONFIGURATION PARSER checking methods + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! ========================================================================= + + FUNCTION check_r1(err,var,def,wlog) RESULT(ret) + !! Check an option value (float). + !! + !! The method checks an option value and optionally set a default value, __def__ to initialize + !! __var__ on error if given. + TYPE(error), INTENT(in) :: err !! Error object from value getter. + REAL(kind=mm_wp), INTENT(inout) :: var !! Input/output option value. + REAL(kind=mm_wp), INTENT(in), OPTIONAL :: def !! Default value to set. + LOGICAL, INTENT(in), OPTIONAL :: wlog !! .true. to print warning/error message. + TYPE(error) :: ret !! Input error. + CHARACTER(len=*), PARAMETER :: defmsg = '... Using default value: ' + LOGICAL :: zlog + ret = err + zlog = .false. ; IF (PRESENT(wlog)) zlog = wlog + IF (err == 0) RETURN + IF (PRESENT(def)) THEN + var = def + IF (zlog) WRITE(*,'(a,a,a)') error_to_string(err,'',.true.),defmsg,to_string(var) + ret = noerror + ELSE + IF (zlog) WRITE(*,'(a)') error_to_string(err,'',.true.) + ENDIF + END FUNCTION check_r1 + + FUNCTION check_l1(err,var,def,wlog) RESULT(ret) + !! Check an option value (logical). + !! + !! The method checks an option value and optionally set a default value, __def__ to initialize + !! __var__ on error if given. + TYPE(error), INTENT(in) :: err !! Error object from value getter. + LOGICAL, INTENT(inout) :: var !! Input/output option value. + LOGICAL, INTENT(in), OPTIONAL :: def !! Default value to set. + LOGICAL, INTENT(in), OPTIONAL :: wlog !! .true. to print warning/error message. + TYPE(error) :: ret !! Input error. + CHARACTER(len=*), PARAMETER :: defmsg = '... Using default value: ' + LOGICAL :: zlog + ret = err + zlog = .false. ; IF (PRESENT(wlog)) zlog = wlog + IF (err == 0) RETURN + IF (PRESENT(def)) THEN + var = def + IF (zlog) WRITE(*,'(a,a,a)') error_to_string(err,'',.true.),defmsg,to_string(var) + ret = noerror + ELSE + IF (zlog) WRITE(*,'(a)') error_to_string(err,'',.true.) + ENDIF + END FUNCTION check_l1 + + FUNCTION check_i1(err,var,def,wlog) RESULT(ret) + !! Check an option value (integer). + !! + !! The method checks an option value and optionally set a default value, __def__ to initialize + !! __var__ on error if given. + TYPE(error), INTENT(in) :: err !! Error object from value getter. + INTEGER, INTENT(inout) :: var !! Input/output option value. + INTEGER, INTENT(in), OPTIONAL :: def !! Default value to set. + LOGICAL, INTENT(in), OPTIONAL :: wlog !! .true. to print warning/error message. + TYPE(error) :: ret !! Input error. + CHARACTER(len=*), PARAMETER :: defmsg = '... Using default value: ' + LOGICAL :: zlog + ret = err + zlog = .false. ; IF (PRESENT(wlog)) zlog = wlog + IF (err == 0) RETURN + IF (PRESENT(def)) THEN + var = def + IF (zlog) WRITE(*,'(a,a,a)') error_to_string(err,'',.true.),defmsg,to_string(var) + ret = noerror + ELSE + IF (zlog) WRITE(*,'(a)') error_to_string(err,'',.true.) + ENDIF + END FUNCTION check_i1 + + FUNCTION check_s1(err,var,def,wlog) RESULT(ret) + !! Check an option value (string). + !! + !! The method checks an option value and optionally set a default value, __def__ to initialize + !! __var__ on error if given. + TYPE(error), INTENT(in) :: err !! Error object from value getter. + CHARACTER(len=*), INTENT(inout) :: var !! Input/output option value. + CHARACTER(len=*), INTENT(in), OPTIONAL :: def !! Default value to set. + LOGICAL, INTENT(in), OPTIONAL :: wlog !! .true. to print warning/error message. + TYPE(error) :: ret !! Input error. + CHARACTER(len=*), PARAMETER :: defmsg = '... Using default value: ' + LOGICAL :: zlog + ret = err + zlog = .false. ; IF (PRESENT(wlog)) zlog = wlog + IF (err == 0) RETURN + IF (PRESENT(def)) THEN + var = TRIM(def) + IF (zlog) WRITE(*,'(a,a,a)') error_to_string(err,'',.true.),defmsg,var + ret = noerror + ELSE + IF (zlog) WRITE(*,'(a)') error_to_string(err,'') + ENDIF + RETURN + END FUNCTION check_s1 + +END MODULE MM_GLOBALS + Index: trunk/LMDZ.TITAN/libf/muphytitan/mm_haze.f90 =================================================================== --- trunk/LMDZ.TITAN/libf/muphytitan/mm_haze.f90 (revision 1793) +++ trunk/LMDZ.TITAN/libf/muphytitan/mm_haze.f90 (revision 1793) @@ -0,0 +1,807 @@ +! Copyright 2013-2015 Université de Reims Champagne-Ardenne +! Contributor: J. Burgalat (GSMA, URCA) +! email of the author : jeremie.burgalat@univ-reims.fr +! +! This software is a computer program whose purpose is to compute +! microphysics processes using a two-moments scheme. +! +! This library is governed by the CeCILL-B license under French law and +! abiding by the rules of distribution of free software. You can use, +! modify and/ or redistribute the software under the terms of the CeCILL-B +! license as circulated by CEA, CNRS and INRIA at the following URL +! "http://www.cecill.info". +! +! As a counterpart to the access to the source code and rights to copy, +! modify and redistribute granted by the license, users are provided only +! with a limited warranty and the software's author, the holder of the +! economic rights, and the successive licensors have only limited +! liability. +! +! In this respect, the user's attention is drawn to the risks associated +! with loading, using, modifying and/or developing or reproducing the +! software by the user in light of its specific status of free software, +! that may mean that it is complicated to manipulate, and that also +! therefore means that it is reserved for developers and experienced +! professionals having in-depth computer knowledge. Users are therefore +! encouraged to load and test the software's suitability as regards their +! requirements in conditions enabling the security of their systems and/or +! data to be ensured and, more generally, to use and operate it in the +! same conditions as regards security. +! +! The fact that you are presently reading this means that you have had +! knowledge of the CeCILL-B license and that you accept its terms. + +!! file: mm_haze.f90 +!! summary: Haze microphysics module. +!! author: J. Burgalat +!! date: 2013-2015 + +MODULE MM_HAZE + !! Haze microphysics module. + !! + !! This module contains all definitions of the microphysics processes related to aerosols: + !! + !! - [coagulation](page/haze.html#coagulation) + !! - [sedimentation](page/haze.html#sedimentation) + !! - [production](page/haze.html#production) + !! + !! @note + !! The production function is specific to Titan, where aerosols are created above the detached + !! haze layer. No other source is taken into account. This process is controled by two parameters, + !! the pressure level of production and the production rate. Then both M0 and M3 of the aerosols + !! distribution are updated in the production zone by addition of the production rate along a + !! gaussian shape. + !! + !! @note + !! The interface methods always uses the global variables defined in [[mm_globals(module)]] when + !! values (any kind, temperature, pressure, moments...) over the vertical grid are required. + !! + !! @warning + !! The tendencies returned by the method are always defined over the vertical grid from __TOP__ + !! to __GROUND__. + !! + !! @todo + !! Modify tests on tendencies vectors to get sure that allocation is done: + !! Currently, we assume the compiler handles automatic allocation of arrays. + USE MM_MPREC + USE MM_GLOBALS + USE MM_INTERFACES + USE MM_METHODS + IMPLICIT NONE + + PRIVATE + + PUBLIC :: mm_haze_microphysics, mm_haze_coagulation, mm_haze_sedimentation, & + mm_haze_production + + CONTAINS + + !============================================================================ + ! HAZE MICROPHYSICS INTERFACE SUBROUTINE + !============================================================================ + + SUBROUTINE mm_haze_microphysics(dm0a_s,dm3a_s,dm0a_f,dm3a_f) + !! Get the evolution of moments tracers through haze microphysics processes. + !! + !! The subroutine is a wrapper to the haze microphysics methods. It computes the tendencies + !! of moments tracers for coagulation, sedimentation and production processes for the + !! atmospheric column. + REAL(kind=mm_wp), INTENT(out), DIMENSION(:) :: dm0a_s + !! Tendency of the 0th order moment of the spherical mode distribution (\(m^{-3}\)). + REAL(kind=mm_wp), INTENT(out), DIMENSION(:) :: dm3a_s + !! Tendency of the 3rd order moment of the spherical mode distribution (\(m^{3}.m^{-3}\)). + REAL(kind=mm_wp), INTENT(out), DIMENSION(:) :: dm0a_f + !! Tendency of the 0th order moment of the fractal mode distribution (\(m^{-3}\)). + REAL(kind=mm_wp), INTENT(out), DIMENSION(:) :: dm3a_f + !! Tendency of the 3rd order moment of the fractal mode distribution (\(m^{3}.m^{-3}\)). + REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE :: zdm0as + REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE :: zdm3as + REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE :: zdm0af + REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE :: zdm3af + + dm0a_s = 0._mm_wp ; dm3a_s = 0._mm_wp ; dm0a_f = 0._mm_wp ; dm3a_f = 0._mm_wp + + ALLOCATE(zdm0as(mm_nla),zdm3as(mm_nla),zdm0af(mm_nla),zdm3af(mm_nla)) + zdm0as(1:mm_nla) = 0._mm_wp + zdm3as(1:mm_nla) = 0._mm_wp + zdm0af(1:mm_nla) = 0._mm_wp + zdm3af(1:mm_nla) = 0._mm_wp + + IF (mm_w_haze_coag) THEN + ! Calls coagulation + call mm_haze_coagulation(dm0a_s,dm3a_s,dm0a_f,dm3a_f) + ENDIF + + IF (mm_w_haze_sed) THEN + ! Calls sedimentation + call mm_haze_sedimentation(zdm0as,zdm3as,zdm0af,zdm3af) + + ! Computes precipitations + mm_aer_prec = SUM(zdm3as*mm_dzlev) + SUM(zdm3af*mm_dzlev) + + ! Updates tendencies + dm0a_s=dm0a_s+zdm0as ; dm3a_s=dm3a_s+zdm3as + dm0a_f=dm0a_f+zdm0af ; dm3a_f=dm3a_f+zdm3af + ENDIF + + IF (mm_w_haze_prod) THEN + call mm_haze_production(zdm0as,zdm3as) + ! We only produce fractal aerosols + dm0a_s=dm0a_s+zdm0as ; dm3a_s=dm3a_s+zdm3as + ENDIF + + RETURN + END SUBROUTINE mm_haze_microphysics + + + !============================================================================ + ! COAGULATION PROCESS RELATED METHODS + !============================================================================ + + SUBROUTINE mm_haze_coagulation(dM0s,dM3s,dM0f,dM3f) + !! Get the evolution of the aerosols moments vertical column due to coagulation process. + !! + !! This is main method of the coagulation process: + !! + !! 1. Computes gamma pre-factor for each parts of the coagulation equation(s) + !! 2. Applies the electic correction on the gamma pre-factor + !! 3. Computes the specific flow regime "kernels" + !! 4. Computes the harmonic mean of the kernels + !! 5. Finally computes the tendencies of the moments. + !! + !! All arguments are assumed vectors of __N__ elements where __N__ is the total number of + !! vertical __layers__. + !! + !! @note + !! The method uses directly the global variables related to the vertical atmospheric structure + !! stored in [[mm_globals(module)]]. Consequently they must be updated before calling the subroutine. + !! + !! @bug + !! If the transfert probabilities are set to 1 for the two flow regimes (pco and pfm), + !! a floating point exception occured (i.e. a NaN) as we perform a division by zero + !! + !! @todo + !! Get rid of the fu\*\*\*\* STOP statement... + REAL(kind=mm_wp), INTENT(out), DIMENSION(:) :: dM0s + !! Tendency of the 0th order moment of the spherical size-distribution over a time step (\(m^{-3}\)). + REAL(kind=mm_wp), INTENT(out), DIMENSION(:) :: dM3s + !! Tendency of the 3rd order moment of the spherical size-distribution (\(m^{3}.m^{-3}\)). + REAL(kind=mm_wp), INTENT(out), DIMENSION(:) :: dM0f + !! Tendency of the 0th order moment of the fractal size-distribution over a time step (\(m^{-3}\)). + REAL(kind=mm_wp), INTENT(out), DIMENSION(:) :: dM3f + !! Tendency of the 3rd order moment of the fractal size-distribution over a time step (\(m^{3}.m^{-3}\)). + REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE :: c_kco,c_kfm,c_slf,tmp, & + kco,kfm,pco,pfm,mq + REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE :: a_ss,a_sf,b_ss,b_ff,c_ss,c_sf + INTEGER :: i + + IF (mm_coag_choice < 0 .OR. mm_coag_choice > mm_coag_ss+mm_coag_sf+mm_coag_ff) & + STOP "invalid choice for coagulation mode interaction activation" + + ! Alloctes local arrays + ALLOCATE(kco(mm_nla),kfm(mm_nla),c_slf(mm_nla), & + c_kco(mm_nla),c_kfm(mm_nla),mq(mm_nla), & + pco(mm_nla),pfm(mm_nla)) + ALLOCATE(a_ss(mm_nla),a_sf(mm_nla), & + b_ss(mm_nla),b_ff(mm_nla), & + c_ss(mm_nla),c_sf(mm_nla)) + + a_ss(:) = 0._mm_wp ; a_sf(:) = 0._mm_wp + b_ss(:) = 0._mm_wp ; b_ff(:) = 0._mm_wp + c_ss(:) = 0._mm_wp ; c_sf(:) = 0._mm_wp + + ! gets kco, kfm pre-factors + c_kco(:) = mm_get_kco(mm_temp) ; c_kfm(:) = mm_get_kfm(mm_temp) + ! get slf (slip-flow factor) + c_slf(:) = mm_akn * mm_lambda_g(mm_temp,mm_play) + + DO i=1,mm_nla + ! SS interactions + IF (mm_rcs(i) > mm_rc_min .AND. IAND(mm_coag_choice,mm_coag_ss) /= 0) THEN + ! compute probability for M0/CO and M0/FM (resp.) + pco(i) = mm_ps2s(mm_rcs(i),0,0,mm_temp(i),mm_play(i)) + pfm(i) = mm_ps2s(mm_rcs(i),0,1,mm_temp(i),mm_play(i)) + ! (A_SS_CO x A_SS_FM) / (A_SS_CO + A_SS_FM) + kco(i) = g0ssco(mm_rcs(i),c_slf(i),c_kco(i)) + kfm(i) = g0ssfm(mm_rcs(i),c_kfm(i)) + IF (kco(i)*(pco(i)-2._mm_wp)+kfm(i)*(pfm(i)-2._mm_wp) /=0) THEN + a_ss(i) = (kco(i)*(pco(i)-2._mm_wp)*kfm(i)*(pfm(i)-2._mm_wp))/(kco(i)*(pco(i)-2._mm_wp)+kfm(i)*(pfm(i)-2._mm_wp)) + ENDIF + ! (B_SS_CO x B_SS_FM) / (B_SS_CO + B_SS_FM) + kco(i) = kco(i) * (1._mm_wp-pco(i)) ; kfm(i) = kfm(i) * (1._mm_wp-pfm(i)) + IF (kco(i) + kfm(i) /= 0._mm_wp) THEN + b_ss(i) = kco(i)*kfm(i)/(kco(i)+kfm(i)) + ENDIF + ! compute and apply eletric charge correction for M0/SS interactions + mq(i) = mm_qmean(mm_rcs(i),mm_rcs(i),0,'SS',mm_temp(i),mm_play(i)) + + a_ss(i) = a_ss(i) * mq(i) + b_ss(i) = b_ss(i) * mq(i) + kco(i) = 0._mm_wp ; kfm(i) = 0._mm_wp ; mq(i) = 1._mm_wp + ! compute probability for M3/CO and M3/FM (resp.) + pco(i) = mm_ps2s(mm_rcs(i),3,0,mm_temp(i),mm_play(i)) + pfm(i) = mm_ps2s(mm_rcs(i),3,1,mm_temp(i),mm_play(i)) + ! (C_SS_CO x C_SS_FM) / (C_SS_CO + C_SS_FM) + kco(i) = g3ssco(mm_rcs(i),c_slf(i),c_kco(i))*(pco(i)-1._mm_wp) + kfm(i) = g3ssfm(mm_rcs(i),c_kfm(i))*(pfm(i)-1._mm_wp) + IF (kco(i) + kfm(i) /= 0._mm_wp) THEN + c_ss(i) = (kco(i)*kfm(i))/(kco(i)+kfm(i)) + ENDIF + IF (b_ss(i) <= 0._mm_wp) c_ss(i) = 0._mm_wp + ! compute and apply eletric charge correction for M3/SS interactions + mq(i) = mm_qmean(mm_rcs(i),mm_rcs(i),3,'SS',mm_temp(i),mm_play(i)) + c_ss(i) = c_ss(i) * mq(i) + ENDIF + kco(i) = 0._mm_wp ; kfm(i) = 0._mm_wp ; mq(i) = 1._mm_wp + + ! SF interactions + IF (mm_rcs(i) > mm_rc_min .AND. mm_rcf(i) > mm_rc_min .AND. IAND(mm_coag_choice,mm_coag_sf) /= 0) THEN + ! (A_SF_CO x A_SF_FM) / (A_SF_CO + A_SF_FM) + kco(i) = g0sfco(mm_rcs(i),mm_rcf(i),c_slf(i),c_kco(i)) + kfm(i) = g0sffm(mm_rcs(i),mm_rcf(i),c_kfm(i)) + IF(kco(i)+kfm(i) /= 0._mm_wp) THEN + a_sf(i) = (kco(i)*kfm(i))/(kco(i)+kfm(i)) + ENDIF + ! compute and apply eletric charge correction for M0/SF interactions + mq(i) = mm_qmean(mm_rcs(i),mm_rcf(i),0,'SF',mm_temp(i),mm_play(i)) + a_sf(i) = a_sf(i) * mq(i) + ! (C_SF_CO x C_SF_FM) / (C_SF_CO + C_SF_FM) + kco(i) = g3sfco(mm_rcs(i),mm_rcf(i),c_slf(i),c_kco(i)) + kfm(i) = g3sffm(mm_rcs(i),mm_rcf(i),c_kfm(i)) + IF (kco(i)+kfm(i) /= 0._mm_wp) THEN + c_sf(i) = (kco(i)*kfm(i))/(kco(i)+kfm(i)) + ENDIF + ! compute and apply eletric charge correction for M3/SF interactions + mq(i) = mm_qmean(mm_rcs(i),mm_rcf(i),3,'SF',mm_temp(i),mm_play(i)) + c_sf(i) = c_sf(i) * mq(i) + ENDIF + kco(i) = 0._mm_wp ; kfm(i) = 0._mm_wp ; mq(i) = 1._mm_wp + ! FF interactions + IF(mm_rcf(i) > mm_rc_min .AND. IAND(mm_coag_choice,mm_coag_sf) /= 0) THEN + ! (B_FF_CO x B_FF_FM) / (B_FF_CO + B_FF_FM) + kco(i) = g0ffco(mm_rcf(i),c_slf(i),c_kco(i)) + kfm(i) = g0fffm(mm_rcf(i),c_kfm(i)) + b_ff(i) = (kco(i)*kfm(i))/(kco(i)+kfm(i)) + ! compute and apply eletric charge correction for M0/FF interactions + mq(i) = mm_qmean(mm_rcf(i),mm_rcf(i),0,'FF',mm_temp(i),mm_play(i)) + b_ff(i) = b_ff(i) * mq(i) + ENDIF + ENDDO + + DEALLOCATE(kco,kfm,c_kco,c_kfm,pco,pfm,c_slf) + + ! Now we will use the kharm two by two to compute : + ! dm_0_S/mm_dt = kharm(1) * m_0_S^2 - kharm(2) * m_0_S * m_0_F + ! dm_0_F/mm_dt = kharm(3) * m_0_S^2 - kharm(4) * m_0_F^2 + ! dm_3_S/mm_dt = kharm(5) * m_3_S^2 - kharm(6) * m_3_S * m_3_F + ! ... and finally : + ! dm_3_F/mm_dt = - dm_3_S/mm_dt + ! + ! We use a (semi) implicit scheme : when X appears as square we set one X + ! at t+1, the other a t + ALLOCATE(tmp(mm_nla)) + ! --- dm0s + tmp(:) = mm_dt*(a_ss*mm_m0aer_s - a_sf*mm_m0aer_f) + dm0s(:) = mm_m0aer_s * (tmp/(1._mm_wp - tmp)) + ! --- dm0f + tmp(:) = b_ff*mm_dt*mm_m0aer_f + dm0f(:) = (b_ss*mm_dt*mm_m0aer_s**2 - tmp*mm_m0aer_f)/(1._mm_wp + tmp) + ! --- dm3s + tmp(:) = mm_dt*(c_ss*mm_m3aer_s - c_sf*mm_m3aer_f) + dm3s(:) = mm_m3aer_s * (tmp/(1._mm_wp - tmp)) + ! --- dmm3f + dm3f(:) = -dm3s + + ! Deallocates memory explicitly ... another obsolete statement :) + DEALLOCATE(a_ss,a_sf,b_ss,b_ff,c_ss,c_sf,tmp) + + ! Time to do something else ! + RETURN + END SUBROUTINE mm_haze_coagulation + + ELEMENTAL FUNCTION g0ssco(rcs,c_slf,c_kco) RESULT(res) + !! Get γ pre-factor for the 0th order moment with SS interactions in the continuous flow regime. + !! + !! @note + !! If __rcs__ is 0, the function returns 0. + REAL(kind=mm_wp), INTENT(in) :: rcs !! Characteristic radius of the spherical size-distribution. + REAL(kind=mm_wp), INTENT(in) :: c_slf !! Slip-Flow correction pre-factor. + REAL(kind=mm_wp), INTENT(in) :: c_kco !! Thermodynamic continuous flow regime pre-factor. + REAL(kind=mm_wp) :: res !! γ coagulation kernel pre-factor. + REAL(kind=mm_wp) :: a1, a2, a3 + res = 0._mm_wp ; IF (rcs <= 0._mm_wp) RETURN + ! computes mm_alpha coefficients + a1=mm_alpha_s(1._mm_wp) ; a2=mm_alpha_s(-1._mm_wp) ; a3=mm_alpha_s(-2._mm_wp) + ! Computes gamma pre-factor + res = (1._mm_wp + a1*a2 + c_slf/rcs *(a2+a1*a3))*c_kco + RETURN + END FUNCTION g0ssco + + ELEMENTAL FUNCTION g0sfco(rcs,rcf,c_slf,c_kco) RESULT(res) + !! Get γ pre-factor for the 0th order moment with SF interactions in the continuous flow regime. + !! + !! @note + !! If __rcs__ or __rcf__ is 0, the function returns 0. + REAL(kind=mm_wp), INTENT(in) :: rcs !! Characteristic radius of the spherical size-distribution. + REAL(kind=mm_wp), INTENT(in) :: rcf !! Characteristic radius of the fractal size-distribution. + REAL(kind=mm_wp), INTENT(in) :: c_slf !! Slip-Flow correction pre-factor. + REAL(kind=mm_wp), INTENT(in) :: c_kco !! Thermodynamic continuous flow regime pre-factor. + REAL(kind=mm_wp) :: res !! γ coagulation kernel pre-factor. + REAL(kind=mm_wp) :: a1, a2, a3, a4, a5, a6, e, rcff + res = 0._mm_wp ; IF (rcs <= 0._mm_wp .OR. rcf <= 0._mm_wp) RETURN + e=3._mm_wp/mm_df ; rcff = rcf**e*mm_rb2ra + ! computes mm_alpha coefficients + a1=mm_alpha_s(1._mm_wp) ; a2=mm_alpha_f(-e) ; a3=mm_alpha_f(e) + a4=mm_alpha_s(-1._mm_wp) ; a5=mm_alpha_s(-2._mm_wp) ; a6=mm_alpha_f(-2._mm_wp*e) + ! Computes gamma pre-factor + res = c_kco*( 2._mm_wp + a1*a2*rcs/rcff + a4*a3*rcff/rcs + c_slf*( a4/rcs + & + a2/rcff + a5*a3*rcff/rcs**2 + a1*a6*rcs/rcff**2)) + RETURN + END FUNCTION g0sfco + + ELEMENTAL FUNCTION g0ffco(rcf,c_slf,c_kco) RESULT(res) + !! Get γ pre-factor for the 0th order moment with FF interactions in the continuous flow regime. + !! + !! @note + !! If __rcf__ is 0, the function returns 0. + REAL(kind=mm_wp), INTENT(in) :: rcf !! Characteristic radius of the fractal size-distribution. + REAL(kind=mm_wp), INTENT(in) :: c_slf !! Slip-Flow correction pre-factor. + REAL(kind=mm_wp), INTENT(in) :: c_kco !! Thermodynamic continuous flow regime pre-factor. + REAL(kind=mm_wp) :: res !! γ coagulation kernel pre-factor. + REAL(kind=mm_wp) :: a1, a2, a3, e, rcff + res = 0._mm_wp ; IF (rcf <= 0._mm_wp) RETURN + ! computes mm_alpha coefficients + e = 3._mm_wp/mm_df ; rcff = rcf**e*mm_rb2ra + a1=mm_alpha_f(e) ; a2=mm_alpha_f(-e) ; a3=mm_alpha_s(-2._mm_wp*e) + ! Computes gamma pre-factor + res = (1._mm_wp + a1*a2 + c_slf/rcff *(a2+a1*a3))*c_kco + RETURN + END FUNCTION g0ffco + + ELEMENTAL FUNCTION g3ssco(rcs, c_slf, c_kco) RESULT(res) + !! Get γ pre-factor for the 3rd order moment with SS interactions in the continuous flow regime. + !! + !! @note + !! If __rcs__ is 0, the function returns 0. + REAL(kind=mm_wp), INTENT(in) :: rcs !! Characteristic radius of the spherical size-distribution. + REAL(kind=mm_wp), INTENT(in) :: c_slf !! Slip-Flow correction pre-factor. + REAL(kind=mm_wp), INTENT(in) :: c_kco !! Thermodynamic continuous flow regime pre-factor. + REAL(kind=mm_wp) :: res !! γ coagulation kernel pre-factor. + REAL(kind=mm_wp) :: a1, a2, a3, a4, a5, a6 + res = 0._mm_wp ; IF (rcs <= 0._mm_wp) RETURN + ! computes mm_alpha coefficients + a1=mm_alpha_s(3._mm_wp) ; a2=mm_alpha_s(2._mm_wp) ; a3=mm_alpha_s(1._mm_wp) + a4=mm_alpha_s(4._mm_wp) ; a5=mm_alpha_s(-1._mm_wp) ; a6=mm_alpha_s(-2._mm_wp) + + ! Computes gamma pre-factor + res = (2._mm_wp*a1 + a2*a3 + a4*a5 + c_slf/rcs*(a3**2 + a4*a6 + a1*a5 + a2))* & + c_kco/(a1**2*rcs**3) + RETURN + END FUNCTION g3ssco + + ELEMENTAL FUNCTION g3sfco(rcs, rcf, c_slf, c_kco) RESULT(res) + !! Get γ pre-factor for the 3rd order moment with SF interactions in the continuous flow regime. + !! + !! @note + !! If __rcs__ or __rcf__ is 0, the function returns 0. + REAL(kind=mm_wp), INTENT(in) :: rcs !! Characteristic radius of the spherical size-distribution. + REAL(kind=mm_wp), INTENT(in) :: rcf !! Characteristic radius of the fractal size-distribution. + REAL(kind=mm_wp), INTENT(in) :: c_slf !! Slip-Flow correction pre-factor. + REAL(kind=mm_wp), INTENT(in) :: c_kco !! Thermodynamic continuous flow regime pre-factor. + REAL(kind=mm_wp) :: res !! γ coagulation kernel pre-factor. + REAL(kind=mm_wp) :: a1, a2, a3, a4, a5, a6, a7, a8, e, rcff + res = 0._mm_wp ; IF (rcs <= 0._mm_wp .OR. rcf <= 0._mm_wp) RETURN + ! computes mm_alpha coefficients + e=3._mm_wp/mm_df ; rcff = rcf**e*mm_rb2ra + a1=mm_alpha_s(3._mm_wp) ; a2=mm_alpha_s(4._mm_wp) ; a3=mm_alpha_f(-e) + a4=mm_alpha_s(2._mm_wp) ; a5=mm_alpha_f(e) ; a6=mm_alpha_s(1._mm_wp) + a7=mm_alpha_f(-2._mm_wp*e) ; a8=mm_alpha_f(3._mm_wp) + ! Computes gamma pre-factor + res = (2._mm_wp*a1*rcs**3 + a2*rcs**4*a3/rcff + a4*rcs**2*a5*rcff + & + c_slf *( a4*rcs**2 + a1*rcs**3*a3/rcff + a6*rcs*a5*rcff + & + a2*rcs**4*a7/rcff**2))* c_kco/(a1*a8*(rcs*rcf)**3) + RETURN + END FUNCTION g3sfco + + ELEMENTAL FUNCTION g0ssfm(rcs, c_kfm) RESULT(res) + !! Get γ pre-factor for the 0th order moment with SS interactions in the Free Molecular flow regime. + !! + !! @note + !! If __rcs__ is 0, the function returns 0. + REAL(kind=mm_wp), INTENT(in) :: rcs !! Characteristic radius of the spherical size-distribution. + REAL(kind=mm_wp), INTENT(in) :: c_kfm !! Thermodynamic free molecular flow regime pre-factor. + REAL(kind=mm_wp) :: res !! γ coagulation kernel pre-factor. + REAL(kind=mm_wp) :: a1, a2, a3, a4, a5 + res = 0._mm_wp ; IF (rcs <= 0._mm_wp) RETURN + ! computes mm_alpha coefficients + a1=mm_alpha_s(0.5_mm_wp) ; a2=mm_alpha_s(1._mm_wp) ; a3=mm_alpha_s(-0.5_mm_wp) + a4=mm_alpha_s(2._mm_wp) ; a5=mm_alpha_s(-1.5_mm_wp) + ! Computes gamma pre-factor + res = (a1 + 2._mm_wp*a2*a3 + a4*a5)*rcs**0.5_mm_wp*mm_get_btk(1,0)*c_kfm + RETURN + END FUNCTION g0ssfm + + ELEMENTAL FUNCTION g0sffm(rcs, rcf, c_kfm) RESULT(res) + !> Get γ pre-factor for the 0th order moment with SF interactions in the Free Molecular flow regime. + !! + !! @note + !! If __rcs__ or __rcf__ is 0, the function returns 0. + REAL(kind=mm_wp), INTENT(in) :: rcs !! Characteristic radius of the spherical size-distribution. + REAL(kind=mm_wp), INTENT(in) :: rcf !! Characteristic radius of the fractal size-distribution. + REAL(kind=mm_wp), INTENT(in) :: c_kfm !! Thermodynamic free molecular flow regime pre-factor. + REAL(kind=mm_wp) :: res !! γ coagulation kernel pre-factor. + REAL(kind=mm_wp) :: a1, a2, a3, a4, a5, a6, a7, a8, a9, a10 + REAL(kind=mm_wp) :: e1, e2, e3, e4 + REAL(kind=mm_wp) :: rcff1, rcff2, rcff3, rcff4 + res = 0._mm_wp ; IF (rcs <= 0._mm_wp .OR. rcf <= 0._mm_wp) RETURN + ! computes mm_alpha coefficients + e1 = 3._mm_wp/mm_df + e2 = 6._mm_wp/mm_df + e3 = (6._mm_wp-3._mm_wp*mm_df)/(2._mm_wp*mm_df) + e4 = (12._mm_wp-3._mm_wp*mm_df)/(2._mm_wp*mm_df) + + rcff1 = mm_rb2ra * rcf**e1 + rcff2 = rcff1**2 + rcff3 = mm_rb2ra * rcf**e3 + rcff4 = mm_rb2ra**2 * rcf**e4 + + a1=mm_alpha_s(0.5_mm_wp) ; a2=mm_alpha_s(-0.5_mm_wp) ; a3=mm_alpha_f(e1) + a4=mm_alpha_s(-1.5_mm_wp) ; a5=mm_alpha_f(e2) ; a6=mm_alpha_s(2._mm_wp) + a7=mm_alpha_f(-1.5_mm_wp) ; a8=mm_alpha_s(1._mm_wp) ; a9=mm_alpha_f(e3) + a10=mm_alpha_f(e4) + + ! Computes gamma pre-factor + res = (a1*rcs**0.5_mm_wp + 2._mm_wp*rcff1*a2*a3/rcs**0.5_mm_wp + a4*a5*rcff2/rcs**1.5_mm_wp + & + a6*a7*rcs**2/rcf**1.5_mm_wp + 2._mm_wp*a8*a9*rcs*rcff3 + a10*rcff4 & + )*mm_get_btk(4,0)*c_kfm + RETURN + END FUNCTION g0sffm + + ELEMENTAL FUNCTION g0fffm(rcf, c_kfm) RESULT(res) + !! Get γ pre-factor for the 0th order moment with FF interactions in the Free Molecular flow regime. + !! + !! @note + !! If __rcf__ is 0, the function returns 0. + REAL(kind=mm_wp), INTENT(in) :: rcf !! Characteristic radius of the fractal size-distribution. + REAL(kind=mm_wp), INTENT(in) :: c_kfm !! Thermodynamic free molecular flow regime pre-factor. + REAL(kind=mm_wp) :: res !! γ coagulation kernel pre-factor. + REAL(kind=mm_wp) :: a1, a2, a3, a4, a5, e1, e2, e3, rcff + res = 0._mm_wp ; IF (rcf <= 0._mm_wp) RETURN + ! computes mm_alpha coefficients + e1=3._mm_wp/mm_df ; e2=(6_mm_wp-3._mm_wp*mm_df)/(2._mm_wp*mm_df) + e3=(12._mm_wp-3._mm_wp*mm_df)/(2._mm_wp*mm_df) + rcff=mm_rb2ra**2*rcf**e3 + a1=mm_alpha_f(e3) ; a2=mm_alpha_f(e1) ; a3=mm_alpha_f(e2) + a4=mm_alpha_f(-1.5_mm_wp) ; a5=mm_alpha_f(2._mm_wp*e1) + ! Computes gamma pre-factor + res = (a1 + 2._mm_wp*a2*a3 + a4*a5)*rcff*mm_get_btk(3,0)*c_kfm + RETURN + END FUNCTION g0fffm + + ELEMENTAL FUNCTION g3ssfm(rcs, c_kfm) RESULT(res) + !! Get γ pre-factor for the 3rd order moment with SS interactions in the Free Molecular flow regime. + !! + !! @note + !! If __rcs__ is 0, the function returns 0. + REAL(kind=mm_wp), INTENT(in) :: rcs !! Characteristic radius of the spherical size-distribution. + REAL(kind=mm_wp), INTENT(in) :: c_kfm !! Thermodynamic free molecular flow regime pre-factor. + REAL(kind=mm_wp) :: res !! γ coagulation kernel pre-factor. + REAL(kind=mm_wp) :: a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11 + res = 0._mm_wp ; IF (rcs <= 0._mm_wp) RETURN + ! computes mm_alpha coefficients + a1=mm_alpha_s(3.5_mm_wp) ; a2=mm_alpha_s(1._mm_wp) ; a3=mm_alpha_s(2.5_mm_wp) + a4=mm_alpha_s(2._mm_wp) ; a5=mm_alpha_s(1.5_mm_wp) ; a6=mm_alpha_s(5._mm_wp) + a7=mm_alpha_s(-1.5_mm_wp) ; a8=mm_alpha_s(4._mm_wp) ; a9=mm_alpha_s(-0.5_mm_wp) + a10=mm_alpha_s(3._mm_wp) ; a11=mm_alpha_s(0.5_mm_wp) + ! Computes gamma pre-factor + res = (a1 + 2._mm_wp*a2*a3 + a4*a5 + a6*a7 + 2._mm_wp*a8*a9 + a10*a11) & + *mm_get_btk(1,3)*c_kfm/(a10**2*rcs**2.5_mm_wp) + RETURN + END FUNCTION g3ssfm + + ELEMENTAL FUNCTION g3sffm(rcs, rcf, c_kfm) RESULT(res) + !! Get γ pre-factor for the 3rd order moment with SF interactions in the Free Molecular flow regime. + !! + !! @note + !! If __rcs__ or __rcf__ is 0, the function returns 0. + REAL(kind=mm_wp), INTENT(in) :: rcs !! Characteristic radius of the spherical size-distribution. + REAL(kind=mm_wp), INTENT(in) :: rcf !! Characteristic radius of the fractal size-distribution. + REAL(kind=mm_wp), INTENT(in) :: c_kfm !! Thermodynamic free molecular flow regime pre-factor. + REAL(kind=mm_wp) :: res !! γ coagulation kernel pre-factor. + REAL(kind=mm_wp) :: a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12 + REAL(kind=mm_wp) :: e1, e2, e3, rcff1, rcff2, rcff3 + res = 0._mm_wp ; IF (rcs <= 0._mm_wp .OR. rcf <= 0._mm_wp) RETURN + ! computes mm_alpha coefficients + e1=3._mm_wp/mm_df + e2=(6._mm_wp-3._mm_wp*mm_df)/(2._mm_wp*mm_df) + e3=(12._mm_wp-3._mm_wp*mm_df)/(2._mm_wp*mm_df) + rcff1=mm_rb2ra*rcf**e1 ; rcff2=mm_rb2ra*rcf**e2 ; rcff3=mm_rb2ra**2*rcf**e3 + a1=mm_alpha_s(3.5_mm_wp) ; a2=mm_alpha_s(2.5_mm_wp) ; a3=mm_alpha_f(e1) + a4=mm_alpha_s(1.5_mm_wp) ; a5=mm_alpha_f(2._mm_wp*e1) ; a6=mm_alpha_s(5._mm_wp) + a7=mm_alpha_f(-1.5_mm_wp) ; a8=mm_alpha_s(4._mm_wp) ; a9=mm_alpha_f(e2) + a10=mm_alpha_s(3._mm_wp) ; a11=mm_alpha_f(e3) ; a12=mm_alpha_f(3._mm_wp) + ! Computes gamma pre-factor + res = (a1*rcs**3.5_mm_wp + 2._mm_wp*a2*a3*rcs**2.5_mm_wp*rcff1 + a4*a5*rcs**1.5_mm_wp*rcff1**2 + & + a6*a7*rcs**5/rcf**1.5_mm_wp + 2._mm_wp*a8*a9*rcs**4*rcff2 + & + a10*a11*rcs**3*rcff3)*mm_get_btk(4,3)*c_kfm/(a10*a12*(rcs*rcf)**3) + RETURN + END FUNCTION g3sffm + + !============================================================================ + ! SEDIMENTATION PROCESS RELATED METHODS + !============================================================================ + + SUBROUTINE mm_haze_sedimentation(dm0s,dm3s,dm0f,dm3f) + !! Interface to sedimentation algorithm. + !! + !! The subroutine computes the evolution of each moment of the aerosols tracers + !! through sedimentation process and returns their tendencies for a timestep. + REAL(kind=mm_wp), INTENT(out), DIMENSION(:) :: dm0s + !! Tendency of the 0th order moment of the spherical mode (\(m^{-3}\)). + REAL(kind=mm_wp), INTENT(out), DIMENSION(:) :: dm3s + !! Tendency of the 3rd order moment of the spherical mode (\(m^{3}.m^{-3}\)). + REAL(kind=mm_wp), INTENT(out), DIMENSION(:) :: dm0f + !! Tendency of the 0th order moment of the fractal mode (\(m^{-3}\)). + REAL(kind=mm_wp), INTENT(out), DIMENSION(:) :: dm3f + !! Tendency of the 3rd order moment of the fractal mode (\(m^{3}.m^{-3}\)). + REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE :: ft,fdcor,wth + REAL(kind=mm_wp) :: m,n,p + REAL(kind=mm_wp), PARAMETER :: fac = 4._mm_wp/3._mm_wp * mm_pi + + ALLOCATE(ft(mm_nle),wth(mm_nle),fdcor(mm_nle)) + + !mm_aer_s_flux(:) = 0._mm_wp ; mm_aer_f_flux(:) = 0._mm_wp + IF (mm_wsed_m0) THEN + ! Spherical particles + ! M0 + call get_weff(mm_m0aer_s,0._mm_wp,3._mm_wp,mm_rcs,mm_dt,mm_alpha_s,wth,fdcor) + ft(:) = wth(:) * fdcor(:) ; mm_m0as_vsed(:) = ft(1:mm_nla) + call let_me_fall_in_peace(mm_m0aer_s,-ft,mm_dt,dm0s) + ! M3 + mm_m3as_vsed(:) = ft(1:mm_nla) + call let_me_fall_in_peace(mm_m3aer_s,-ft,mm_dt,dm3s) + ! get mass flux + mm_aer_s_flux(:) = fac * mm_rhoaer * ft(2:) * mm_m3aer_s + ! Fractal particles + ! M0 + call get_weff(mm_m0aer_f,0._mm_wp,mm_df,mm_rcf,mm_dt,mm_alpha_f,wth,fdcor) + ft(:) = wth(:) * fdcor(:) ; mm_m0af_vsed(:) = ft(1:mm_nla) + call let_me_fall_in_peace(mm_m0aer_f,-ft,mm_dt,dm0f) + ! M3 + mm_m3af_vsed(:) = ft(1:mm_nla) + call let_me_fall_in_peace(mm_m3aer_f,-ft,mm_dt,dm3f) + ! get mass flux + mm_aer_f_flux(:) = fac * mm_rhoaer * ft(2:) * mm_m3aer_f + ELSEIF (mm_wsed_m3) THEN + ! Spherical particles + ! M3 + call get_weff(mm_m3aer_s,3._mm_wp,3._mm_wp,mm_rcs,mm_dt,mm_alpha_s,wth,fdcor) + ft(:) = wth(:) * fdcor(:) ; mm_m3as_vsed(:) = ft(1:mm_nla) + call let_me_fall_in_peace(mm_m3aer_s,-ft,mm_dt,dm3s) + ! get mass flux + mm_aer_s_flux(:) = fac * mm_rhoaer * ft(2:) * mm_m3aer_s + ! M0 + mm_m0as_vsed(:) = ft(1:mm_nla) + call let_me_fall_in_peace(mm_m0aer_s,-ft,mm_dt,dm0s) + ! Fractal particles + ! M3 + call get_weff(mm_m3aer_f,3._mm_wp,mm_df,mm_rcf,mm_dt,mm_alpha_f,wth,fdcor) + ft(:) = wth(:) * fdcor(:) ; mm_m3af_vsed(:) = ft(1:mm_nla) + call let_me_fall_in_peace(mm_m3aer_f,-ft,mm_dt,dm3f) + ! get mass flux + mm_aer_f_flux(:) = fac * mm_rhoaer * ft(2:) * mm_m3aer_f + ! M0 + mm_m0af_vsed(:) = ft(1:mm_nla) + call let_me_fall_in_peace(mm_m0aer_f,-ft,mm_dt,dm0f) + ELSE + ! Spherical particles + ! M0 + call get_weff(mm_m0aer_s,0._mm_wp,3._mm_wp,mm_rcs,mm_dt,mm_alpha_s,wth,fdcor) + ft(:) = wth(:) * fdcor(:) ; mm_m0as_vsed(:) = ft(1:mm_nla) + call let_me_fall_in_peace(mm_m0aer_s,-ft,mm_dt,dm0s) + ! M3 + call get_weff(mm_m3aer_s,3._mm_wp,3._mm_wp,mm_rcs,mm_dt,mm_alpha_s,wth,fdcor) + ft(:) = wth(:) * fdcor(:) ; mm_m3as_vsed(:) = ft(1:mm_nla) + call let_me_fall_in_peace(mm_m3aer_s,-ft,mm_dt,dm3s) + ! get mass flux + mm_aer_s_flux(:) = fac * mm_rhoaer * ft(2:) * mm_m3aer_s + ! Fractal particles + ! M0 + call get_weff(mm_m0aer_f,0._mm_wp,mm_df,mm_rcf,mm_dt,mm_alpha_f,wth,fdcor) + ft(:) = wth(:) * fdcor(:) ; mm_m0af_vsed(:) = ft(1:mm_nla) + call let_me_fall_in_peace(mm_m0aer_f,-ft,mm_dt,dm0f) + ! M3 + call get_weff(mm_m3aer_f,3._mm_wp,mm_df,mm_rcf,mm_dt,mm_alpha_f,wth,fdcor) + ft(:) = wth(:) * fdcor(:) ; mm_m3af_vsed(:) = ft(1:mm_nla) + call let_me_fall_in_peace(mm_m3aer_f,-ft,mm_dt,dm3f) + ! get mass flux + mm_aer_f_flux(:) = fac * mm_rhoaer * ft(2:) * mm_m3aer_f + ENDIF + DEALLOCATE(ft,wth,fdcor) + RETURN + END SUBROUTINE mm_haze_sedimentation + + SUBROUTINE let_me_fall_in_peace(mk,ft,dt,dmk) + !! Compute the tendency of the moment through sedimentation process. + !! + !! + !! The method computes the time evolution of the \(k^{th}\) order moment through sedimentation: + !! + !! $$ \dfrac{dM_{k}}{dt} = \dfrac{\Phi_{k}}{dz} $$ + !! + !! The equation is resolved using a [Crank-Nicolson algorithm](http://en.wikipedia.org/wiki/Crank-Nicolson_method). + !! + !! Sedimentation algorithm is quite messy. It appeals to the dark side of the Force and uses evil black magic spells + !! from ancient times. It is based on \cite{toon1988b,fiadeiro1977,turco1979} and is an update of the algorithm + !! originally implemented in the LMDZ-Titan 2D GCM. + REAL(kind=mm_wp), INTENT(in), DIMENSION(:) :: mk !! \(k^{th}\) order moment to sediment (in \(m^{k}\)). + REAL(kind=mm_wp), INTENT(in) :: dt !! Time step (s). + REAL(kind=mm_wp), INTENT(in), DIMENSION(:) :: ft !! Downward sedimentation flux (effective velocity of the moment). + REAL(kind=mm_wp), INTENT(out), DIMENSION(:) :: dmk !! Tendency of \(k^{th}\) order moment (in \(m^{k}.m^{-3}\)). + INTEGER :: i + REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE :: as,bs,cs,mko + ALLOCATE(as(mm_nla), bs(mm_nla), cs(mm_nla), mko(mm_nla)) + mko(1:mm_nla) = 0._mm_wp + cs(1:mm_nla) = ft(2:mm_nla+1) - mm_dzlay(1:mm_nla)/dt + IF (ANY(cs > 0._mm_wp)) THEN + ! implicit case + as(1:mm_nla) = ft(1:mm_nla) + bs(1:mm_nla) = -(ft(2:mm_nle)+mm_dzlay(1:mm_nla)/dt) + cs(1:mm_nla) = -mm_dzlay(1:mm_nla)/dt*mk(1:mm_nla) + ! (Tri)diagonal matrix inversion + mko(1) = cs(1)/bs(1) + DO i=2,mm_nla ; mko(i) = (cs(i)-mko(i-1)*as(i))/bs(i) ; ENDDO + ELSE + ! explicit case + as(1:mm_nla)=-mm_dzlay(1:mm_nla)/dt + bs(1:mm_nla)=-ft(1:mm_nla) + ! boundaries + mko(1)=cs(1)*mk(1)/as(1) + mko(mm_nla)=(bs(mm_nla)*mk(mm_nla-1)+cs(mm_nla)*mk(mm_nla))/as(mm_nla) + ! interior + mko(2:mm_nla-1)=(bs(2:mm_nla-1)*mk(1:mm_nla-2) + & + cs(2:mm_nla-1)*mk(2:mm_nla-1) & + )/as(2:mm_nla-1) + ENDIF + dmk = mko - mk + DEALLOCATE(as,bs,cs,mko) + RETURN + END SUBROUTINE let_me_fall_in_peace + + SUBROUTINE get_weff(mk,k,df,rc,dt,afun,wth,corf) + !! Get the effective settling velocity for aerosols moments. + !! + !! This method computes the effective settling velocity of the \(k^{th}\) order moment of aerosol + !! tracers. The basic settling velocity (\(v^{eff}_{M_{k}}\)) is computed using the following + !! equation: + !! + !! $$ + !! \begin{eqnarray*} + !! \Phi^{sed}_{M_{k}} &=& \int_{0}^{\infty} n(r) r^{k} \times w(r) dr + !! == M_{k} \times v^{eff}_{M_{k}} \\ + !! v^{eff}_{M_{k} &=& \dfrac{2 \rho g r_{c}^{\dfrac{3D_{f}-3}{D_{f}}}} + !! {r_{m}^{D_{f}-3}/D_{f}} \times \alpha(k)} \times \left( \alpha \right( + !! \frac{D_{f}(k+3)-3}{D_{f}}\left) + \dfrac{A_{kn}\lambda_{g}}{r_{c}^{ + !! 3/D_{f}}} \alpha \right( \frac{D_{f}(k+3)-6}{D_{f}}\left)\left) + !! \end{eqnarray*} + !! $$ + !! + !! \(v^{eff}_{M_{k}\) is then corrected to reduce numerical diffusion of the sedimentation algorithm + !! as defined in \cite{toon1988b}. + !! + !! @warning + !! Both __df__, __rc__ and __afun__ must be consistent with each other otherwise wrong values will + !! be computed. + REAL(kind=mm_wp), INTENT(in), DIMENSION(mm_nla) :: mk + !! Moment of order __k__ (\(m^{k}.m^{-3}\)) at each layer. + REAL(kind=mm_wp), INTENT(in), DIMENSION(mm_nla) :: rc + !! Characteristic radius associated to the moment at each layer. + REAL(kind=mm_wp), INTENT(in) :: k + !! The order of the moment. + REAL(kind=mm_wp), INTENT(in) :: df + !! Fractal dimension of the aersols. + REAL(kind=mm_wp), INTENT(in) :: dt + !! Time step (s). + REAL(kind=mm_wp), INTENT(out), DIMENSION(mm_nle) :: wth + !! Theoretical Settling velocity at each vertical __levels__ (\( wth \times corf = weff\)). + REAL(kind=mm_wp), INTENT(out), DIMENSION(mm_nle), OPTIONAL :: corf + !! _Fiadero_ correction factor applied to the theoretical settling velocity at each vertical __levels__. + INTERFACE + FUNCTION afun(order) + !! Inter-moment relation function (see [[mm_interfaces(module):mm_alpha_s(interface)]]). + IMPORT mm_wp + REAL(kind=mm_wp), INTENT(in) :: order !! Order of the moment. + REAL(kind=mm_wp) :: afun !! Alpha value. + END FUNCTION afun + END INTERFACE + INTEGER :: i + REAL(kind=mm_wp) :: af1,af2,ar1,ar2 + REAL(kind=mm_wp) :: csto,cslf,ratio,wdt,dzb + REAL(kind=mm_wp) :: rb2ra + REAL(kind=mm_wp), DIMENSION(mm_nle) :: zcorf + ! ------------------ + + wth(:) = 0._mm_wp ; zcorf(:) = 1._mm_wp + + ar1 = (3._mm_wp*df -3._mm_wp)/df ; ar2 = (3._mm_wp*df -6._mm_wp)/df + af1 = (df*(k+3._mm_wp)-3._mm_wp)/df ; af2 = (df*(k+3._mm_wp)-6._mm_wp)/df + rb2ra = mm_rm**((df-3._mm_wp)/df) + DO i=2,mm_nla + IF (rc(i-1) <= 0._mm_wp) CYCLE + dzb = (mm_dzlay(i)+mm_dzlay(i-1))/2._mm_wp + csto = 2._mm_wp*mm_rhoaer*mm_effg(mm_zlev(i))/(9._mm_wp*mm_eta_g(mm_btemp(i))) + cslf = mm_akn * mm_lambda_g(mm_btemp(i),mm_plev(i)) + wth(i) = - csto/(rb2ra*afun(k)) * (rc(i-1)**ar1 * afun(af1) + cslf/rb2ra * rc(i-1)**ar2 * afun(af2)) + ! now correct velocity to reduce numerical diffusion + IF (.NOT.mm_no_fiadero_w) THEN + IF (mk(i) <= 0._mm_wp) THEN + ratio = mm_fiadero_max + ELSE + ratio = MAX(MIN(mk(i-1)/mk(i),mm_fiadero_max),mm_fiadero_min) + ENDIF + ! apply correction + IF ((ratio <= 0.9_mm_wp .OR. ratio >= 1.1_mm_wp) .AND. wth(i) /= 0._mm_wp) THEN + wdt = wth(i)*dt + zcorf(i) = dzb/wdt * (exp(-wdt*log(ratio)/dzb)-1._mm_wp) / (1._mm_wp-ratio) + ENDIF + ENDIF + ENDDO + ! last value (ground) set to first layer value: arbitrary :) + wth(i) = wth(i-1) + IF (PRESENT(corf)) corf(:) = zcorf(:) + RETURN + END SUBROUTINE get_weff + + !============================================================================ + ! PRODUCTION PROCESS RELATED METHOD + !============================================================================ + + SUBROUTINE mm_haze_production(dm0s,dm3s) + !! Compute the production of aerosols moments. + !! + !! The method computes the tendencies of M0 and M3 for the spherical mode through production process. + !! Production values are distributed along a normal law in altitude, centered at + !! [[mm_globals(module):mm_p_prod(variable)]] pressure level with a fixed sigma of 20km. + !! + !! First M3 tendency is computed and M0 is retrieved using the inter-moments relation a spherical + !! characteristic radius set to [[mm_globals(module):mm_rc_prod(variable)]]. + !! + !! If [[mm_globals(module):mm_var_prod(variable)]] is set to .true., the method computes time-dependent + !! tendencies using a sine wave of anuglar frequency [[mm_globals(module):mm_w_prod(variable)]] + REAL(kind=mm_wp), INTENT(out), DIMENSION(:) :: dm0s !! Tendency of M0 (\(m^{-3}\)). + REAL(kind=mm_wp), INTENT(out), DIMENSION(:) :: dm3s !! Tendency of M3 (\(m^{3}.m^{-3}\)). + INTEGER :: i + REAL(kind=mm_wp) :: zprod,cprod,timefact + REAL(kind=mm_wp), PARAMETER :: sigz = 20e3_mm_wp, & + fnorm = 1._mm_wp/(dsqrt(2._mm_wp*mm_pi)*sigz), & + znorm = dsqrt(2._mm_wp)*sigz + REAL(kind=mm_wp), SAVE :: ctime = 0._mm_wp + !$OMP THREADPRIVATE (ctime) + zprod = -1._mm_wp + ! locate production altitude + DO i=1, mm_nla-1 + IF (mm_plev(i) < mm_p_prod.AND.mm_plev(i+1) >= mm_p_prod) THEN + zprod = mm_zlay(i) ; EXIT + ENDIF + ENDDO + IF (zprod < 0._mm_wp) THEN + WRITE(*,'(a)') "cannot find aerosols production altitude" + call EXIT(11) + ENDIF + + dm3s(:)= mm_tx_prod *0.75_mm_wp/mm_pi *mm_dt / mm_rhoaer / 2._mm_wp / mm_dzlev(1:mm_nla) * & + (erf((mm_zlev(1:mm_nla)-zprod)/znorm) - & + erf((mm_zlev(2:mm_nla+1)-zprod)/znorm)) + dm0s(:) = dm3s(:)/(mm_rc_prod**3*mm_alpha_s(3._mm_wp)) + + IF (mm_var_prod) THEN + timefact = mm_d_prod*sin(mm_w_prod*ctime)+1._mm_wp + dm3s(:) = timefact*dm3s(:) + dm0s(:) = timefact*dm0s(:) + ctime = ctime + mm_dt + ENDIF + + + END SUBROUTINE mm_haze_production + +END MODULE MM_HAZE Index: trunk/LMDZ.TITAN/libf/muphytitan/mm_interfaces.f90 =================================================================== --- trunk/LMDZ.TITAN/libf/muphytitan/mm_interfaces.f90 (revision 1793) +++ trunk/LMDZ.TITAN/libf/muphytitan/mm_interfaces.f90 (revision 1793) @@ -0,0 +1,155 @@ +! Copyright 2013-2015 Université de Reims Champagne-Ardenne +! Contributor: J. Burgalat (GSMA, URCA) +! email of the author : jeremie.burgalat@univ-reims.fr +! +! This software is a computer program whose purpose is to compute +! microphysics processes using a two-moments scheme. +! +! This library is governed by the CeCILL-B license under French law and +! abiding by the rules of distribution of free software. You can use, +! modify and/ or redistribute the software under the terms of the CeCILL-B +! license as circulated by CEA, CNRS and INRIA at the following URL +! "http://www.cecill.info". +! +! As a counterpart to the access to the source code and rights to copy, +! modify and redistribute granted by the license, users are provided only +! with a limited warranty and the software's author, the holder of the +! economic rights, and the successive licensors have only limited +! liability. +! +! In this respect, the user's attention is drawn to the risks associated +! with loading, using, modifying and/or developing or reproducing the +! software by the user in light of its specific status of free software, +! that may mean that it is complicated to manipulate, and that also +! therefore means that it is reserved for developers and experienced +! professionals having in-depth computer knowledge. Users are therefore +! encouraged to load and test the software's suitability as regards their +! requirements in conditions enabling the security of their systems and/or +! data to be ensured and, more generally, to use and operate it in the +! same conditions as regards security. +! +! The fact that you are presently reading this means that you have had +! knowledge of the CeCILL-B license and that you accept its terms. + +!! file: mm_interfaces.f90 +!! summary: Interfaces module for external functions +!! author: J. Burgalat +!! date: 2013-2015 + +MODULE MM_INTERFACES + !! Interfaces to external functions. + !! + !! The module contains the definitions of all "external" functions used by moments model which are + !! left to the developer's responsibility. + !! + !! # Functions + !! + !! - [[mm_interfaces(module):mm_alpha_s(interface)]] should compute the inter-moments relation coefficient + !! as a function of the moment's order for the spherical mode. + !! - [[mm_interfaces(module):mm_alpha_f(interface)]] should perform the same computations as + !! [[mm_interfaces(module):mm_alpha_s(interface)]] but for the fractal mode. + !! - [[mm_interfaces(module):mm_ps2s(interface)]] should compute the probability for particles of the + !! spherical mode to remain in that mode during coagulation process. + !! - [[mm_interfaces(module):mm_qmean(interface)]] should compute the mean eletric charge correction to be + !! applied on each coagulation sub-kernels computed in mm_haze module. + !! - [[mm_interfaces(module):mm_get_btk(interface)]] should compute the \(b_{k}^{T}\) coefficient of the + !! free-molecular regime. + USE MM_MPREC + IMPLICIT NONE + + PUBLIC + + INTERFACE + + PURE FUNCTION mm_alpha_s(k) RESULT (res) + !! Inter-moment relation for spherical aerosols size distribution law. + !! + !! The method computes the relation between the kth order moment and the 0th order moment: + !! $$ \dfrac{M_{k}}{M_{0}} = r_{C}^{k} \times \alpha(k,a_{1},...a_{n}) $$ + IMPORT mm_wp + REAL(kind=mm_wp), INTENT(in) :: k !! Order of the moment. + REAL(kind=mm_wp) :: res !! Alpha value. + END FUNCTION mm_alpha_s + + PURE FUNCTION mm_alpha_f(k) RESULT (res) + !! Inter-moment relation for fractal aerosols size distribution law. + !! + !! The method computes the relation between the kth order moment and the 0th order moment: + !! $$ \dfrac{M_{k}}{M_{0}} = r_{C}^{k} \times \alpha(k,a_{1},...a_{n}) $$ + IMPORT mm_wp + REAL(kind=mm_wp), INTENT(in) :: k !! Order of the moment. + REAL(kind=mm_wp) :: res !! Alpha value. + END FUNCTION mm_alpha_f + + FUNCTION mm_ps2s(rcs,k,flow,t,p) RESULT(res) + !! Get the proportion of aerosols that remains in the spherical mode during SS coagulation. + IMPORT mm_wp + REAL(kind=mm_wp), INTENT(in) :: rcs !! Characteristic radius of the spherical size-distribution (m). + REAL(kind=mm_wp), INTENT(in) :: t !! Temperature (K). + REAL(kind=mm_wp), INTENT(in) :: p !! Pressure level (Pa). + INTEGER, INTENT(in) :: k !! Order of the moment (0 or 3). + INTEGER, INTENT(in) :: flow !! Flow regime (0: continuous, 1: Free molecular). + REAL(kind=mm_wp) :: res !! Proportion of spherical particles that remains in the spherical mode. + END FUNCTION mm_ps2s + + FUNCTION mm_qmean(rc1,rc2,order,modes,temp,pres) RESULT(res) + !! Get the electric correction for coagulation kernel. + !! + !! The method computes the eletric charging correction to apply to the coagulation + !! kernel as a function of the temperature, pressure and the characteristic radius of + !! the mode involved in the coagulation. + !! + !! Modes are referred by a two letters uppercase string with the combination of: + !! + !! - S : spherical mode + !! - F : fractal mode + !! + !! For example, SS means intra-modal coagulation for spherical particles. + IMPORT mm_wp + REAL(kind=mm_wp), INTENT(in) :: rc1 !! Characteristic radius of the the first distribution (m). + REAL(kind=mm_wp), INTENT(in) :: rc2 !! Characteristic radius of the the second distribution (m). + INTEGER, INTENT(in) :: order !! Moment's order (0 or 3). + CHARACTER(len=2), INTENT(in) :: modes !! Interaction mode (a combination of [S,F]). + REAL(kind=mm_wp), INTENT(in) :: temp !! Temperature (K). + REAL(kind=mm_wp), INTENT(in) :: pres !! Pressure level (Pa). + REAL(kind=mm_wp) :: res !! Electric charging correction. + END FUNCTION mm_qmean + + PURE FUNCTION mm_get_btk(t,k) RESULT(res) + !! Get the \(b_{k}^{T}\) coefficient of the Free Molecular regime. + !! + !! The method computes and returns the value of the pre-factor \(b_{k}^{T}\) used to + !! approximate free-molecular regime coagulation kernels. + !! @note + !! For more details about \(b_{k}^{T}\) coefficient, please read the + !! [scientific documentation](page/haze.html#free-molecular). + !! + !! @attention + !! In its current version, the model only deals with fixed values of __k__ and __T__. + !! __k__ can take the values (0,3) and, __T__, the values within [1,5]. + IMPORT mm_wp + INTEGER, INTENT(in) :: t !! Interaction identifier. + INTEGER, INTENT(in) :: k !! Moment order. + REAL(kind=mm_wp) :: res !! \(b_{k}^{T}\) value. + END FUNCTION mm_get_btk + + + ELEMENTAL FUNCTION mm_eta_g(t) RESULT (res) + !! Get the air viscosity at a given temperature. + IMPORT mm_wp + REAL(kind=mm_wp), INTENT(in) :: t !! Temperature (K). + REAL(kind=mm_wp) :: res !! Air viscosity at given temperature (\(Pa.s^{-1}\)). + END FUNCTION mm_eta_g + + ELEMENTAL FUNCTION mm_lambda_g(t,p) RESULT(res) + !! Get the air mean free path at given temperature and pressure. + IMPORT mm_wp + REAL(kind=mm_wp), INTENT(in) :: t !! Temperature (K). + REAL(kind=mm_wp), INTENT(in) :: p !! Pressure level (Pa). + REAL(kind=mm_wp) :: res !! Air mean free path (m). + END FUNCTION mm_lambda_g + + END INTERFACE + +END MODULE MM_INTERFACES + Index: trunk/LMDZ.TITAN/libf/muphytitan/mm_lib.f90 =================================================================== --- trunk/LMDZ.TITAN/libf/muphytitan/mm_lib.f90 (revision 1793) +++ trunk/LMDZ.TITAN/libf/muphytitan/mm_lib.f90 (revision 1793) @@ -0,0 +1,52 @@ +! Copyright 2013-2015 Université de Reims Champagne-Ardenne +! Contributor: J. Burgalat (GSMA, URCA) +! email of the author : jeremie.burgalat@univ-reims.fr +! +! This software is a computer program whose purpose is to compute +! microphysics processes using a two-moments scheme. +! +! This library is governed by the CeCILL-B license under French law and +! abiding by the rules of distribution of free software. You can use, +! modify and/ or redistribute the software under the terms of the CeCILL-B +! license as circulated by CEA, CNRS and INRIA at the following URL +! "http://www.cecill.info". +! +! As a counterpart to the access to the source code and rights to copy, +! modify and redistribute granted by the license, users are provided only +! with a limited warranty and the software's author, the holder of the +! economic rights, and the successive licensors have only limited +! liability. +! +! In this respect, the user's attention is drawn to the risks associated +! with loading, using, modifying and/or developing or reproducing the +! software by the user in light of its specific status of free software, +! that may mean that it is complicated to manipulate, and that also +! therefore means that it is reserved for developers and experienced +! professionals having in-depth computer knowledge. Users are therefore +! encouraged to load and test the software's suitability as regards their +! requirements in conditions enabling the security of their systems and/or +! data to be ensured and, more generally, to use and operate it in the +! same conditions as regards security. +! +! The fact that you are presently reading this means that you have had +! knowledge of the CeCILL-B license and that you accept its terms. + +!! file: mm_mp2m.f90 +!! summary: MP2M library interface module. +!! author: J. Burgalat +!! date: 2013-2015 + +MODULE MM_LIB + !! MP2M library interface module. + !! + !! This module is only intended to get a overall acces to all library module. It contains no + !! definitions and just __uses__ all others modules of the library. + USE MM_MPREC + USE MM_GLOBALS + USE MM_INTERFACES + USE MM_METHODS + USE MM_HAZE + USE MM_CLOUDS + USE MM_MICROPHYSIC +END MODULE MM_LIB + Index: trunk/LMDZ.TITAN/libf/muphytitan/mm_methods.f90 =================================================================== --- trunk/LMDZ.TITAN/libf/muphytitan/mm_methods.f90 (revision 1793) +++ trunk/LMDZ.TITAN/libf/muphytitan/mm_methods.f90 (revision 1793) @@ -0,0 +1,373 @@ +! Copyright 2013-2015 Université de Reims Champagne-Ardenne +! Contributor: J. Burgalat (GSMA, URCA) +! email of the author : jeremie.burgalat@univ-reims.fr +! +! This software is a computer program whose purpose is to compute +! microphysics processes using a two-moments scheme. +! +! This library is governed by the CeCILL-B license under French law and +! abiding by the rules of distribution of free software. You can use, +! modify and/ or redistribute the software under the terms of the CeCILL-B +! license as circulated by CEA, CNRS and INRIA at the following URL +! "http://www.cecill.info". +! +! As a counterpart to the access to the source code and rights to copy, +! modify and redistribute granted by the license, users are provided only +! with a limited warranty and the software's author, the holder of the +! economic rights, and the successive licensors have only limited +! liability. +! +! In this respect, the user's attention is drawn to the risks associated +! with loading, using, modifying and/or developing or reproducing the +! software by the user in light of its specific status of free software, +! that may mean that it is complicated to manipulate, and that also +! therefore means that it is reserved for developers and experienced +! professionals having in-depth computer knowledge. Users are therefore +! encouraged to load and test the software's suitability as regards their +! requirements in conditions enabling the security of their systems and/or +! data to be ensured and, more generally, to use and operate it in the +! same conditions as regards security. +! +! The fact that you are presently reading this means that you have had +! knowledge of the CeCILL-B license and that you accept its terms. + +!! file: mm_methods.f90 +!! summary: Model miscellaneous methods module. +!! author: J. Burgalat +!! date: 2013-2015 + +MODULE MM_METHODS + !! Model miscellaneous methods module. + !! + !! The module contains miscellaneous methods used either in the haze and clouds parts of the model. + !! + !! All thermodynamic functions related to cloud microphysics (i.e. [[mm_methods(module):mm_lHeatX(interface)]], + !! [[mm_methods(module):mm_sigX(interface)]] and [[mm_methods(module):mm_psatX(interface)]]) compute related equations + !! from \cite{reid1986}. A version of the book is freely available [here](http://f3.tiera.ru/3/Chemistry/References/Poling%20B.E.,%20Prausnitz%20J.M.,%20O'Connell%20J.P.%20The%20Properties%20of%20Gases%20and%20Liquids%20(5ed.,%20MGH,%202000)(ISBN%200070116822)(803s).pdf). + !! + !! The module defines the following functions/subroutines/interfaces: + !! + !! | name | description + !! | :---------: | :------------------------------------------------------------------------------------- + !! | mm_lheatx | Compute latent heat released + !! | mm_sigx | Compute surface tension + !! | mm_psatx | Compute saturation vapor pressure + !! | mm_qsatx | Compute saturation mass mixing ratio + !! | mm_fshape | Compute shape factor + !! | mm_lambda_g | Compute air mean free path + !! | mm_eta_g | Compute air viscosity + !! | mm_get_kfm | Compute the thermodynamic pre-factor of coagulation kernel in free-molecular regime + !! | mm_get_kco | Compute the thermodynamic pre-factor of coagulation kernel in continuous regime + USE MM_MPREC + USE MM_GLOBALS + USE MM_INTERFACES + IMPLICIT NONE + + PRIVATE + + PUBLIC :: mm_sigX, mm_LheatX, mm_psatX, mm_qsatx, mm_fshape, & + mm_get_kco, mm_get_kfm, mm_eta_g, mm_lambda_g + + ! ---- INTERFACES + + !> Interface to surface tension computation functions. + !! + !! The method computes the surface tension of a given specie at given temperature(s). + !! + !! ```fortran + !! FUNCTION mm_sigX(temp,xESP) + !! ``` + !! + !! __xESP__ must always be given as a scalar. If __temp__ is given as a vector, then the method + !! computes the result for all the temperatures and returns a vector of same size than __temp__. + INTERFACE mm_sigX + MODULE PROCEDURE sigx_sc,sigx_ve + END INTERFACE + + !> Interface to Latent heat computation functions. + !! + !! The method computes the latent heat released of a given specie at given temperature(s). + !! + !! ```fortran + !! FUNCTION mm_lheatX(temp,xESP) + !! ``` + !! + !! __xESP__ must always be given as a scalar. If __temp__ is given as a vector, then the method + !! computes the result for all the temperatures and returns a vector of same size than __temp__. + INTERFACE mm_LheatX + MODULE PROCEDURE lheatx_sc,lheatx_ve + END INTERFACE + + !> Interface to saturation vapor pressure computation functions. + !! + !! ```fortran + !! FUNCTION mm_psatX(temp,xESP) + !! ``` + !! + !! The method computes the saturation vapor pressure of a given specie at given temperature(s). + !! + !! __xESP__ must always be given as a scalar. If __temp__ is given as a vector, then the method + !! computes the result for all the temperatures and returns a vector of same size than __temp__. + INTERFACE mm_psatX + MODULE PROCEDURE psatx_sc,psatx_ve + END INTERFACE + + !! Interface to saturation mass mixing ratio computaiton functions. + !! + !! The method computes the mass mixing ratio at saturation of a given specie at given temperature(s) + !! and pressure level(s). + !! + !! ```fortran + !! FUNCTION mm_qsatX(temp,pres,xESP) + !! ``` + !! + !! __xESP__ must always be given as a scalar. If __temp__ and __pres__ are given as a vector (of same + !! size !), then the method computes the result for each couple of (temperature, pressure) and returns + !! a vector of same size than __temp__. + INTERFACE mm_qsatx + MODULE PROCEDURE qsatx_sc,qsatx_ve + END INTERFACE + + !> Interface to shape factor computation functions. + !! + !! The method computes the shape factor for the heterogeneous nucleation. + !! + !! ```fortran + !! FUNCTION mm_fshape(m,x) + !! ``` + !! + !! Where __m__ is cosine of the contact angle and __x__ the curvature radius. __m__ must always be + !! given as a scalar. If __x__ is given as a vector, then the method compute the result for each + !! value of __x__ and and returns a vector of same size than __x__. + INTERFACE mm_fshape + MODULE PROCEDURE fshape_sc,fshape_ve + END INTERFACE + + CONTAINS + + FUNCTION fshape_sc(cost,rap) RESULT(res) + !! Get the shape factor of a ccn (scalar). + !! + !! The method computes the shape factor for the heterogeneous nucleation on a fractal particle. + !! Details about the shape factor can be found in \cite{prup1978}. + REAL(kind=mm_wp), INTENT(in) :: cost !! Cosine of the contact angle. + REAL(kind=mm_wp), INTENT(in) :: rap !! Curvature radius (\(r_{particle}/r^{*}\)). + REAL(kind=mm_wp) :: res !! Shape factor value. + REAL(kind=mm_wp) :: phi,a,b,c + IF (rap > 3000._mm_wp) THEN + res = ((2._mm_wp+cost)*(1._mm_wp-cost)**2)/4._mm_wp + ELSE + phi = dsqrt(1._mm_wp-2._mm_wp*cost*rap+rap**2) + a = 1._mm_wp + ( (1._mm_wp-cost*rap)/phi )**3 + b = (rap**3) * (2._mm_wp-3._mm_wp*(rap-cost)/phi+((rap-cost)/phi)**3) + c = 3._mm_wp * cost * (rap**2) * ((rap-cost)/phi-1._mm_wp) + res = 0.5_mm_wp*(a+b+c) + ENDIF + RETURN + END FUNCTION fshape_sc + + FUNCTION fshape_ve(cost,rap) RESULT(res) + !! Get the shape factor of a ccn (vector). + !! + !! See [[mm_methods(module):fshape_sc(function)]]. + REAL(kind=mm_wp), INTENT(in) :: cost !! Cosine of the contact angle. + REAL(kind=mm_wp), INTENT(in), DIMENSION(:) :: rap !! Curvature radii (\(r_{particle}/r^{*}\)). + REAL(kind=mm_wp), DIMENSION(SIZE(rap)) :: res !! Shape factor value. + REAL(kind=mm_wp), DIMENSION(SIZE(rap)) :: phi,a,b,c + WHERE(rap > 3000._mm_wp) + res = ((2._mm_wp+cost)*(1._mm_wp-cost)**2)/4._mm_wp + ELSEWHERE + phi = dsqrt(1._mm_wp-2._mm_wp*cost*rap+rap**2) + a = 1._mm_wp + ((1._mm_wp-cost*rap)/phi )**3 + b = (rap**3)*(2._mm_wp-3._mm_wp*(rap-cost)/phi+((rap-cost)/phi)**3) + c = 3._mm_wp*cost*(rap**2)*((rap-cost)/phi-1._mm_wp) + res = 0.5_mm_wp*(a+b+c) + ENDWHERE + RETURN + END FUNCTION fshape_ve + + FUNCTION LHeatX_sc(temp,xESP) RESULT(res) + !! Compute latent heat of a given specie at given temperature (scalar). + !! + !! The method computes the latent heat equation as given in \cite{reid1986} p. 220 (eq. 7-9.4). + IMPLICIT NONE + ! - DUMMY + REAL(kind=mm_wp), INTENT(in) :: temp !! temperature (K). + TYPE(mm_esp), INTENT(in) :: xESP !! Specie properties. + REAL(kind=mm_wp) :: res !! Latent heat of given specie at given temperature (\(J.kg^{-1}\)). + REAL(kind=mm_wp) :: ftm + ftm=MIN(1._mm_wp-temp/xESP%tc,1.e-3_mm_wp) + res = mm_rgas*xESP%tc*(7.08_mm_wp*ftm**0.354_mm_wp+10.95_mm_wp*xESP%w*ftm**0.456_mm_wp)/xESP%masmol + END FUNCTION LHeatX_sc + + FUNCTION LHeatX_ve(temp,xESP) RESULT(res) + !! Compute latent heat of a given specie at given temperature (vector). + !! + !! See [[mm_methods(module):lheatx_sc(function)]]. + REAL(kind=mm_wp), INTENT(in), DIMENSION(:) :: temp !! temperatures (K). + TYPE(mm_esp), INTENT(in) :: xESP !! Specie properties. + REAL(kind=mm_wp), DIMENSION(SIZE(temp)) :: res !! Latent heat of given specie at given temperatures (\(J.kg^{-1}\)). + REAL(kind=mm_wp) :: ftm + INTEGER :: i + DO i=1,SIZE(temp) + ftm=MIN(1._mm_wp-temp(i)/xESP%tc,1.e-3_mm_wp) + res(i) = mm_rgas*xESP%tc*(7.08_mm_wp*ftm**0.354_mm_wp+10.95_mm_wp*xESP%w*ftm**0.456_mm_wp) / & + xESP%masmol + ENDDO + END FUNCTION LHeatX_ve + + FUNCTION sigX_sc(temp,xESP) RESULT(res) + !! Get the surface tension between a given specie and the air (scalar). + !! + !! The method computes the surface tension equation as given in \cite{reid1986} p. 637 (eq. 12-3.6). + REAL(kind=mm_wp), INTENT(in) :: temp !! temperature (K). + TYPE(mm_esp), INTENT(in) :: xESP !! Specie properties. + REAL(kind=mm_wp) :: res !! Surface tension (\(N.m^{-1}\)). + REAL(kind=mm_wp) :: tr,tbr,sig + tr=MIN(temp/xESP%tc,0.99_mm_wp) + tbr=xESP%tb/xESP%tc + sig = 0.1196_mm_wp*(1._mm_wp+(tbr*dlog(xESP%pc/1.01325_mm_wp))/(1._mm_wp-tbr))-0.279_mm_wp + sig = xESP%pc**(2._mm_wp/3._mm_wp)*xESP%tc**(1._mm_wp/3._mm_wp)*sig*(1._mm_wp-tr)**(11._mm_wp/9._mm_wp) + res = sig*1e3_mm_wp ! dyn/cm2 -> N/m + END FUNCTION sigX_sc + + FUNCTION sigX_ve(temp,xESP) RESULT(res) + !! Get the surface tension between a given specie and the air (vector). + !! + !! See [[mm_methods(module):sigx_sc(function)]]. + REAL(kind=mm_wp), INTENT(in), DIMENSION(:) :: temp !! temperatures (K). + TYPE(mm_esp), INTENT(in) :: xESP !! Specie properties. + REAL(kind=mm_wp), DIMENSION(SIZE(temp)) :: res !! Surface tensions (\(N.m^{-1}\)). + INTEGER :: i + REAL(kind=mm_wp) :: tr,tbr,sig + tbr = xESP%tb/xESP%tc + sig = 0.1196_mm_wp*(1._mm_wp+(tbr*dlog(xESP%pc/1.01325_mm_wp))/(1._mm_wp-tbr))-0.279_mm_wp + DO i=1,SIZE(temp) + tr = MIN(temp(i)/xESP%tc,0.99_mm_wp) + sig = xESP%pc**(2._mm_wp/3._mm_wp)*xESP%tc**(1._mm_wp/3._mm_wp)*sig*(1._mm_wp-tr)**(11._mm_wp/9._mm_wp) + res(i) = sig*1e3_mm_wp ! dyn/cm2 -> N/m + ENDDO + END FUNCTION sigX_ve + + FUNCTION psatX_sc(temp,xESP) RESULT(res) + !! Get saturation vapor pressure for a given specie at given temperature (scalar). + !! + !! The method computes the saturation vapor pressure equation given in \cite{reid1986} p. 657 (eq. 1). + !! + !! @warning + !! This subroutine accounts for a specific Titan feature: + !! If __xESP__ corresponds to \(CH_{4}\), the saturation vapor presure is multiplied by 0.85 + !! to take into account its dissolution in \(N_{2}\). + REAL(kind=mm_wp), INTENT(in) :: temp !! Temperature (K). + TYPE(mm_esp), INTENT(in) :: xESP !! Specie properties. + REAL(kind=mm_wp) :: res !! Saturation vapor pressure (Pa). + REAL(kind=mm_wp) :: x,qsat + x = 1._mm_wp-temp/xESP%tc + IF (x > 0._mm_wp) THEN + qsat = (1._mm_wp-x)**(-1) * & + (xESP%a_sat*x + xESP%b_sat*x**1.5_mm_wp + xESP%c_sat*x**3 + xESP%d_sat*x**6) + ELSE + qsat = XESP%a_sat*x/abs(1._mm_wp-x) ! approx for t > tc + ENDIF + ! Special case : ch4 : x0.85 (dissolution in N2) + IF (xESP%name == "ch4") THEN + res = xESP%pc*dexp(qsat)*0.85_mm_wp + ELSE + res = xESP%pc*dexp(qsat) + ENDIF + ! now convert bar to Pa + res = res * 1e5_mm_wp + END FUNCTION psatX_sc + + FUNCTION psatX_ve(temp,xESP) RESULT(res) + !! Get saturation vapor pressure for a given specie at given temperature (vector). + !! + !! See [[mm_methods(module):psatX_sc(function)]]. + REAL(kind=mm_wp), INTENT(in), DIMENSION(:) :: temp !! Temperatures (K). + TYPE(mm_esp), INTENT(in) :: xESP !! Specie properties. + REAL(kind=mm_wp), DIMENSION(SIZE(temp)) :: res !! Saturation vapor pressures (Pa). + INTEGER :: i + REAL(kind=mm_wp) :: x,qsat + DO i=1, SIZE(temp) + x = 1._mm_wp-temp(i)/xESP%tc + IF (x > 0._mm_wp) THEN + qsat = (1._mm_wp-x)**(-1) * & + (xESP%a_sat*x + xESP%b_sat*x**1.5_mm_wp + xESP%c_sat*x**3 + xESP%d_sat*x**6) + ELSE + qsat = XESP%a_sat*x/abs(1._mm_wp-x) ! approx for t > tc + ENDIF + res(i) = xESP%pc*dexp(qsat) + ! Peculiar case : ch4 : x0.85 (dissolution in N2) + IF (xESP%name == "ch4") res(i) = res(i)* 0.85_mm_wp + ENDDO + res = res * 1e5_mm_wp ! bar -> Pa + END FUNCTION psatX_ve + + FUNCTION qsatX_sc(temp,pres,xESP) RESULT(res) + !! Get the mass mixing ratio of a given specie at saturation (scalar). + REAL(kind=mm_wp), INTENT(in) :: temp !! Temperature (K). + REAL(kind=mm_wp), INTENT(in) :: pres !! Pressure level (Pa). + TYPE(mm_esp), INTENT(in) :: xESP !! Specie properties. + REAL(kind=mm_wp) :: res !! Mass mixing ratio of the specie. + REAL(kind=mm_wp) :: x,psat + psat = mm_psatX(temp,xESP) + res = (psat / pres) * xESP%fmol2fmas + END FUNCTION qsatX_sc + + FUNCTION qsatX_ve(temp,pres,xESP) RESULT(res) + !! Get the mass mixing ratio of a given specie at saturation (vector). + REAL(kind=mm_wp), INTENT(in), DIMENSION(:) :: temp !! Temperatures (K). + REAL(kind=mm_wp), INTENT(in), DIMENSION(:) :: pres !! Pressure levels (Pa). + TYPE(mm_esp), INTENT(in) :: xESP !! Specie properties. + REAL(kind=mm_wp), DIMENSION(SIZE(temp)) :: res !! Mass mixing ratios of the specie. + REAL(kind=mm_wp), DIMENSION(SIZE(temp)) :: psat + psat = mm_psatX(temp,xESP) + res = (psat / pres) * xESP%fmol2fmas + END FUNCTION qsatX_ve + + ELEMENTAL FUNCTION mm_get_kco(t) RESULT(res) + !! Get the Continuous regime thermodynamics pre-factor of the coagulation kernel. + REAL(kind=mm_wp), INTENT(in) :: t !! Temperature (K). + REAL(kind=mm_wp) :: res !! Continuous regime thermodynamics pre-factor (\(m^{3}.s^{-1}\)). + res = 2._mm_wp*mm_kboltz*t / (3._mm_wp*mm_eta_g(t)) + RETURN + END FUNCTION mm_get_kco + + ELEMENTAL FUNCTION mm_get_kfm(t) RESULT(res) + !! Get the Free Molecular regime thermodynamics pre-factor of the coagulation kernel. + REAL(kind=mm_wp), INTENT(in) :: t !! Temperature (K). + REAL(kind=mm_wp) :: res !! Free Molecular regime thermodynamics pre-factor (\(m^{5/2}.s^{-1}\)). + res = (6._mm_wp*mm_kboltz*t/mm_rhoaer)**(0.5_mm_wp) + RETURN + END FUNCTION mm_get_kfm + +! ELEMENTAL FUNCTION mm_eta_g(t) RESULT (res) +! !! Get the air viscosity at a given temperature. +! !! +! !! The function computes the air viscosity at temperature __t__ using Sutherland method. +! REAL(kind=mm_wp), INTENT(in) :: t !! Temperature (K). +! REAL(kind=mm_wp) :: res !! Air viscosity at given temperature (\(Pa.s^{-1}\)). +! REAL (kind=mm_wp), PARAMETER :: eta0 = 1.75e-5_mm_wp, & +! tsut = 109._mm_wp, & +! tref = 293._mm_wp +! res = eta0 *dsqrt(t/tref)*(1._mm_wp+tsut/tref)/(1._mm_wp+tsut/t) +! RETURN +! END FUNCTION mm_eta_g +! +! ELEMENTAL FUNCTION mm_lambda_g(t,p) RESULT(res) +! !! Get the air mean free path at given temperature and pressure. +! !! +! !! The method computes the air mean free path: +! !! +! !! $$ \lambda_{g} = \dfrac{k_{b}T}{4\sqrt{2}\pi r_{a}^2 P} $$ +! !! +! !! Where \(\lambda_{g}\), is the air mean free path, \(k_{b}\) the Boltzmann constant, T the +! !! temperature, P the pressure level and \(r_{a}\) the radius of an _air molecule_. +! REAL(kind=mm_wp), INTENT(in) :: t !! Temperature (K). +! REAL(kind=mm_wp), INTENT(in) :: p !! Pressure level (Pa). +! REAL(kind=mm_wp) :: res !! Air mean free path (m). +! res = mm_kboltz*t/(4._mm_wp*dsqrt(2._mm_wp)*mm_pi*(mm_air_rad**2)*p) +! RETURN +! END FUNCTION mm_lambda_g + +END MODULE MM_METHODS Index: trunk/LMDZ.TITAN/libf/muphytitan/mm_microphysic.f90 =================================================================== --- trunk/LMDZ.TITAN/libf/muphytitan/mm_microphysic.f90 (revision 1793) +++ trunk/LMDZ.TITAN/libf/muphytitan/mm_microphysic.f90 (revision 1793) @@ -0,0 +1,238 @@ +! Copyright 2013-2015 Université de Reims Champagne-Ardenne +! Contributor: J. Burgalat (GSMA, URCA) +! email of the author : jeremie.burgalat@univ-reims.fr +! +! This software is a computer program whose purpose is to compute +! microphysics processes using a two-moments scheme. +! +! This library is governed by the CeCILL-B license under French law and +! abiding by the rules of distribution of free software. You can use, +! modify and/ or redistribute the software under the terms of the CeCILL-B +! license as circulated by CEA, CNRS and INRIA at the following URL +! "http://www.cecill.info". +! +! As a counterpart to the access to the source code and rights to copy, +! modify and redistribute granted by the license, users are provided only +! with a limited warranty and the software's author, the holder of the +! economic rights, and the successive licensors have only limited +! liability. +! +! In this respect, the user's attention is drawn to the risks associated +! with loading, using, modifying and/or developing or reproducing the +! software by the user in light of its specific status of free software, +! that may mean that it is complicated to manipulate, and that also +! therefore means that it is reserved for developers and experienced +! professionals having in-depth computer knowledge. Users are therefore +! encouraged to load and test the software's suitability as regards their +! requirements in conditions enabling the security of their systems and/or +! data to be ensured and, more generally, to use and operate it in the +! same conditions as regards security. +! +! The fact that you are presently reading this means that you have had +! knowledge of the CeCILL-B license and that you accept its terms. + +!! file: mm_microphysic.f90 +!! brief: Microphysic processes interface module. +!! author: J. Burgalat +!! date: 2013-2015 + +MODULE MM_MICROPHYSIC + !! Microphysic processes interface module. + USE MM_MPREC + USE MM_GLOBALS + USE MM_HAZE + USE MM_CLOUDS + USE MM_METHODS + IMPLICIT NONE + + PRIVATE + + PUBLIC :: mm_muphys, mm_diagnostics, mm_get_radii + + !! Interface to main microphysics subroutine. + !! + !! The interface computes calls either all the microphysics processes ([[mm_microphysic(module):muphys_all(function)]] + !! or only aerosols microphysics ([[mm_microphysic(module):muphys_nocld(function)]]) in a single call. + INTERFACE mm_muphys + MODULE PROCEDURE muphys_all, muphys_nocld + END INTERFACE + + CONTAINS + + + + FUNCTION muphys_all(dm0a_s,dm3a_s,dm0a_f,dm3a_f,dm0n,dm3n,dm3i,dgazs) RESULT(ret) + !! Compute the evolution of moments tracers through haze and clouds microphysics processes. + !! + !! This method computes the evolution of all the microphysics tracers, given under the form of moments + !! (and molar fraction for cloud condensible species) during a time step. + !! + !! The method requires that global variables of the model (i.e. variables declared in [[mm_globals(module)]] + !! module) are initialized/updated correctly (see [[mm_globals(module):mm_global_init(interface)]], + !! [[mm_globals(module):mm_column_init(function)]],[[mm_globals(module):mm_aerosols_init(function)]] and + !! [[mm_globals(module):mm_clouds_init(function)]]). + !! + !! The tendencies returned by the method are defined on the vertical __layers__ of the model from the __GROUND__ to + !! the __TOP__ of the atmosphere. They should be added to the input variables used in the initialization methods + !! before the latter are called to initialize a new step. + !! @note + !! __dm3i__ and __dgazs__ are 2D-arrays with vertical __layers__ in the 1st dimension and the number of + !! ice components in the 2nd. They share the same _species_ indexing. + !! + !! It should be a 2D-array with the vertical layers in first dimension and the number of ice components in the second. + REAL(kind=mm_wp), INTENT(out), DIMENSION(:) :: dm0a_s + !! Tendency of the 0th order moment of the spherical mode distribution (\(m^{-2}\)). + REAL(kind=mm_wp), INTENT(out), DIMENSION(:) :: dm3a_s + !! Tendency of the 3rd order moment of the spherical mode distribution (\(m^{3}.m^{-2}\)). + REAL(kind=mm_wp), INTENT(out), DIMENSION(:) :: dm0a_f + !! Tendency of the 0th order moment of the fractal mode distribution (\(m^{-2}\)). + REAL(kind=mm_wp), INTENT(out), DIMENSION(:) :: dm3a_f + !! Tendency of the 3rd order moment of the fractal mode distribution (\(m^{3}.m^{-2}\)). + REAL(kind=mm_wp), INTENT(out), DIMENSION(:) :: dm0n + !! Tendency of the 0th order moment of the _CCN_ distribution (\(m^{-2}\)). + REAL(kind=mm_wp), INTENT(out), DIMENSION(:) :: dm3n + !! Tendency of the 3rd order moment of the _CCN_ distribution (\(m^{3}.m^{-2}\)). + REAL(kind=mm_wp), INTENT(out), DIMENSION(:,:) :: dm3i + !! Tendencies of the 3rd order moments of each ice components (\(m^{3}.m^{-2}\)). + REAL(kind=mm_wp), INTENT(out), DIMENSION(:,:) :: dgazs + !! Tendencies of each condensible gaz species (\(mol.mol^{-1}\)). + LOGICAL :: ret + !! .true. on success (i.e. model has been initialized at least once previously), .false. otherwise. + REAL(kind=mm_wp), DIMENSION(SIZE(dm0a_s)) :: zdm0a_f,zdm3a_f + INTEGER :: i + ! Checks initialization + ret = (mm_ini_col.AND.mm_ini_aer.AND.(.NOT.mm_w_clouds.OR.mm_ini_cld)) + IF (.NOT.ret) RETURN + ! Calls haze microphysics (-> m-3) + call mm_haze_microphysics(dm0a_s,dm3a_s,dm0a_f,dm3a_f) + IF (mm_w_clouds) THEN + ! Calls cloud microphysics (-> m-3) + call mm_cloud_microphysics(zdm0a_f,zdm3a_f,dm0n,dm3n,dm3i,dgazs) + ! add temporary aerosols tendencies (-> m-3) + dm0a_f = dm0a_f + zdm0a_f ; dm3a_f = dm3a_f + zdm3a_f + ! reverse directly clouds tendencies (-> m-2) + dm0n = dm0n(mm_nla:1:-1) * mm_dzlev(mm_nla:1:-1) + dm3n = dm3n(mm_nla:1:-1) * mm_dzlev(mm_nla:1:-1) + DO i=1,mm_nesp + dm3i(:,i) = dm3i(mm_nla:1:-1,i) * mm_dzlev(mm_nla:1:-1) + dgazs(:,i) = dgazs(mm_nla:1:-1,i) * mm_dzlev(mm_nla:1:-1) + ENDDO + ELSE + dm0n = 0._mm_wp ; dm3n = 0._mm_wp ; dm3i = 0._mm_wp ; dgazs = 0._mm_wp + ENDIF + ! multiply by altitude thickness and reverse vectors so they go + ! from ground to top :) + dm0a_s = dm0a_s(mm_nla:1:-1) * mm_dzlev(mm_nla:1:-1) + dm3a_s = dm3a_s(mm_nla:1:-1) * mm_dzlev(mm_nla:1:-1) + dm0a_f = dm0a_f(mm_nla:1:-1) * mm_dzlev(mm_nla:1:-1) + dm3a_f = dm3a_f(mm_nla:1:-1) * mm_dzlev(mm_nla:1:-1) + RETURN + END FUNCTION muphys_all + + FUNCTION muphys_nocld(dm0a_s,dm3a_s,dm0a_f,dm3a_f) RESULT(ret) + !! Compute the evolution of moments tracers through haze microphysics only. + !! + !! This method is a __light__ version of [[mm_microphysic(module):muphys_all(function)]] where + !! only haze microphysics is computed and its tendencies returned. + !! + !! The method has the same requirements and remarks than [[mm_microphysic(module):muphys_all(function)]]. + REAL(kind=mm_wp), INTENT(out), DIMENSION(:) :: dm0a_s + !! Tendency of the 0th order moment of the spherical mode distribution (\(m^{-2}\)). + REAL(kind=mm_wp), INTENT(out), DIMENSION(:) :: dm3a_s + !! Tendency of the 3rd order moment of the spherical mode distribution (\(m^{3}.m^{-2}\)). + REAL(kind=mm_wp), INTENT(out), DIMENSION(:) :: dm0a_f + !! Tendency of the 0th order moment of the fractal mode distribution (\(m^{-2}\)). + REAL(kind=mm_wp), INTENT(out), DIMENSION(:) :: dm3a_f + !! Tendency of the 3rd order moment of the fractal mode distribution (\(m^{3}.m^{-2}\)). + LOGICAL :: ret + !! .true. on succes (i.e. model has been initialized at least once previously), .false. otherwise. + ret = (mm_ini_col.AND.mm_ini_aer) + IF (.NOT.ret) RETURN + IF (mm_w_clouds.AND.mm_debug) THEN + WRITE(*,'(a)') "WARNING: clouds microphysics enabled but will not be & + &computed... (wrong interface)" + ENDIF + ! Calls haze microphysics + call mm_haze_microphysics(dm0a_s,dm3a_s,dm0a_f,dm3a_f) + ! reverse vectors so they go from ground to top :) + dm0a_s = dm0a_s(mm_nla:1:-1) * mm_dzlev(mm_nla:1:-1) + dm3a_s = dm3a_s(mm_nla:1:-1) * mm_dzlev(mm_nla:1:-1) + dm0a_f = dm0a_f(mm_nla:1:-1) * mm_dzlev(mm_nla:1:-1) + dm3a_f = dm3a_f(mm_nla:1:-1) * mm_dzlev(mm_nla:1:-1) + RETURN + END FUNCTION muphys_nocld + + SUBROUTINE mm_diagnostics(aer_prec,aer_s_flux,aer_f_flux, & + ccn_prec,ccn_flux, ice_prec,ice_fluxes, & + gazs_sat) + !! Get various diagnostic fields of the microphysics. + !! + !! The current diagnostics saved during microphysic computation are : + !! + !! - Mass fluxes (aerosols -both mode-, CCN and ices) + !! - Precipitations (aerosols -total-, CCN and ices) + !! - condensible gazes saturation ratio + !! + !! @note + !! Fluxes values are always negative as they account for sedimentation fluxes. They are set as + !! vector (for aerosols and CCN) or 2D-array (with the vertical structure in the first dimension + !! and number of species in the second, for ice) and are ordered from __GROUND__ to __TOP__. + !! + !! @note + !! Precipitations are always positive and defined in meters. For ice, it is set as a vector with + !! the precipitations of each cloud ice components. + !! + !! @note + !! __ccnprec__, __iceprec__, __icefluxes__ and __gazsat__ are always set to 0 if clouds + !! microphysics is disabled (see [[mm_globals(module):mm_w_clouds(variable)]] documentation). + REAL(kind=mm_wp), INTENT(out), OPTIONAL :: aer_prec !! Aerosols precipitations (both modes) (m). + REAL(kind=mm_wp), INTENT(out), OPTIONAL :: ccn_prec !! CCN precipitations (m). + REAL(kind=mm_wp), INTENT(out), OPTIONAL, DIMENSION(:) :: aer_s_flux !! Spherical aerosol mass flux (\(kg.m^{-2}.s^{-1}\)). + REAL(kind=mm_wp), INTENT(out), OPTIONAL, DIMENSION(:) :: aer_f_flux !! Fractal aerosol mass flux (\(kg.m^{-2}.s^{-1}\)). + REAL(kind=mm_wp), INTENT(out), OPTIONAL, DIMENSION(:) :: ccn_flux !! CCN mass flux (\(kg.m^{-2}.s^{-1}\)). + REAL(kind=mm_wp), INTENT(out), OPTIONAL, DIMENSION(:,:) :: ice_fluxes !! Ice sedimentation fluxes (\(kg.m^{-2}.s^{-1}\)). + REAL(kind=mm_wp), INTENT(out), OPTIONAL, DIMENSION(:,:) :: gazs_sat !! Condensible gaz saturation ratios (--). + REAL(kind=mm_wp), INTENT(out), OPTIONAL, DIMENSION(:) :: ice_prec !! Ice precipitations (m). + + IF (PRESENT(aer_prec)) aer_prec = ABS(mm_aer_prec) + IF (PRESENT(aer_s_flux)) aer_s_flux = -mm_aer_s_flux(mm_nla:1:-1) + IF (PRESENT(aer_f_flux)) aer_f_flux = -mm_aer_f_flux(mm_nla:1:-1) + + IF (mm_w_clouds) THEN + IF (PRESENT(ccn_prec)) ccn_prec = ABS(mm_ccn_prec) + IF (PRESENT(ice_prec)) ice_prec = ABS(mm_ice_prec) + IF (PRESENT(ccn_flux)) ccn_flux = -mm_ccn_flux(mm_nla:1:-1) + IF (PRESENT(ice_fluxes)) ice_fluxes = -mm_ice_fluxes(mm_nla:1:-1,:) + IF (PRESENT(gazs_sat)) gazs_sat = mm_gazs_sat(mm_nla:1:-1,:) + ELSE + IF (PRESENT(ccn_prec)) ccn_prec = 0._mm_wp + IF (PRESENT(ice_prec)) ice_prec = 0._mm_wp + IF (PRESENT(ccn_flux)) ccn_flux = 0._mm_wp + IF (PRESENT(ice_fluxes)) ice_fluxes = 0._mm_wp + IF (PRESENT(gazs_sat)) gazs_sat = 0._mm_wp + ENDIF + END SUBROUTINE mm_diagnostics + + SUBROUTINE mm_get_radii(rcsph,rcfra,rccld) + !! Get characteristic radii of microphysical tracers on the vertical grid. + REAL(kind=mm_wp), INTENT(out), DIMENSION(:), OPTIONAL :: rcsph !! Spherical mode characteristic radius + REAL(kind=mm_wp), INTENT(out), DIMENSION(:), OPTIONAL :: rcfra !! Fractal mode characteristic radius + REAL(kind=mm_wp), INTENT(out), DIMENSION(:), OPTIONAL :: rccld !! Cloud drops mean radius + IF (mm_ini_aer) THEN + IF (PRESENT(rcsph)) rcsph = mm_rcs(mm_nla:1:-1) + IF (PRESENT(rcfra)) rcfra = mm_rcf(mm_nla:1:-1) + ELSE + IF (PRESENT(rcsph)) rcsph = 0._mm_wp + IF (PRESENT(rcfra)) rcfra = 0._mm_wp + ENDIF + IF (PRESENT(rccld)) THEN + IF (mm_w_clouds.AND.mm_ini_cld) THEN + rccld = mm_drad(mm_nla:1:-1) + ELSE + rccld = 0._mm_wp + ENDIF + ENDIF + END SUBROUTINE mm_get_radii + +END MODULE MM_MICROPHYSIC + Index: trunk/LMDZ.TITAN/libf/muphytitan/mm_mprec.F90 =================================================================== --- trunk/LMDZ.TITAN/libf/muphytitan/mm_mprec.F90 (revision 1793) +++ trunk/LMDZ.TITAN/libf/muphytitan/mm_mprec.F90 (revision 1793) @@ -0,0 +1,69 @@ +! Copyright 2013-2015 Université de Reims Champagne-Ardenne +! Contributor: J. Burgalat (GSMA, URCA) +! email of the author : jeremie.burgalat@univ-reims.fr +! +! This software is a computer program whose purpose is to compute +! microphysics processes using a two-moments scheme. +! +! This library is governed by the CeCILL-B license under French law and +! abiding by the rules of distribution of free software. You can use, +! modify and/ or redistribute the software under the terms of the CeCILL-B +! license as circulated by CEA, CNRS and INRIA at the following URL +! "http://www.cecill.info". +! +! As a counterpart to the access to the source code and rights to copy, +! modify and redistribute granted by the license, users are provided only +! with a limited warranty and the software's author, the holder of the +! economic rights, and the successive licensors have only limited +! liability. +! +! In this respect, the user's attention is drawn to the risks associated +! with loading, using, modifying and/or developing or reproducing the +! software by the user in light of its specific status of free software, +! that may mean that it is complicated to manipulate, and that also +! therefore means that it is reserved for developers and experienced +! professionals having in-depth computer knowledge. Users are therefore +! encouraged to load and test the software's suitability as regards their +! requirements in conditions enabling the security of their systems and/or +! data to be ensured and, more generally, to use and operate it in the +! same conditions as regards security. +! +! The fact that you are presently reading this means that you have had +! knowledge of the CeCILL-B license and that you accept its terms. + +!! file: mm_mprec.F90 +!! summary: Library floating point precision module. +!! author: J. Burgalat +!! date: 2013-2015 + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif + +#ifndef PREC +#define PREC 64 +#elif (PREC != 32 && PREC != 64 && PREC != 80) +#undef PREC +#define PREC 64 +#endif + +MODULE MM_MPREC + !! Library floating point computations precision module. + !! + !! This module only defines a single variable [[mm_mprec(module):mm_wp(variable)]] which sets + !! the kind of floating point value used in all other part of the library (REAL(kind=mm_wp) + !! declaration statement). + IMPLICIT NONE + +#if (PREC == 32) + !> Size of floating point variables in the library (single). + INTEGER, PUBLIC, PARAMETER :: mm_wp = SELECTED_REAL_KIND(p=6) ! 32 bits +#elif (PREC == 64) + !> Size of floating point variables in the library (double). + INTEGER, PUBLIC, PARAMETER :: mm_wp = SELECTED_REAL_KIND(p=15) ! 64 bits +#elif (PREC == 80) + !> Size of floating point variables in the library (extended-double). + INTEGER, PUBLIC, PARAMETER :: mm_wp = SELECTED_REAL_KIND(p=18) ! 80 bits +#endif +END MODULE MM_MPREC + Index: trunk/LMDZ.TITAN/libf/muphytitan/mmp_gcm.f90 =================================================================== --- trunk/LMDZ.TITAN/libf/muphytitan/mmp_gcm.f90 (revision 1793) +++ trunk/LMDZ.TITAN/libf/muphytitan/mmp_gcm.f90 (revision 1793) @@ -0,0 +1,281 @@ +MODULE MMP_GCM + !! Interface to YAMMS for the LMDZ GCM. + USE MM_LIB + USE CFGPARSE + USE DATASETS + IMPLICIT NONE + + PUBLIC + + !> Alpha function parameters. + !! + !! It stores the parameters of the inter-moments relation functions. + !! + !! The inter-moments relation function is represented by the sum of exponential + !! quadratic expressions: + !! + !! $$ + !! \displaystyle \alpha(k) = \sum_{i=1}^{n} \exp\left( a_{i}\times k^{2} + + !! b_{i}\times k^{2} +c_{i}\right) + !! $$ + TYPE, PUBLIC :: aprm + !> Quadratic coefficients of the quadratic expressions. + REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE :: a + !> Linear coefficients of the quadratic expressions. + REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE :: b + !> Free term of the quadratic expressions. + REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE :: c + END TYPE + !> Inter-moment relation set of parameters for the spherical mode. + TYPE(aprm), PUBLIC, SAVE :: mmp_asp + !> Inter-moment relation set of parameters for the fractal mode. + TYPE(aprm), PUBLIC, SAVE :: mmp_afp + + !> Data set for @f$_{SF}^{M0}@f$. + TYPE(dset2d), PUBLIC, SAVE, TARGET :: mmp_qbsf0 + !> Extended values of [[mmp_globals(module):mmp_qbsf0(variable)]] dataset. + REAL(kind=mm_wp), PUBLIC, SAVE, DIMENSION(2,2) :: mmp_qbsf0_e + !> Data set for @f$_{SF}^{M3}@f$. + TYPE(dset2d), PUBLIC, SAVE, TARGET :: mmp_qbsf3 + !> Extended values of [[mmp_globals(module):mmp_qbsf3(variable)]] dataset. + REAL(kind=mm_wp), PUBLIC, SAVE, DIMENSION(2,2) :: mmp_qbsf3_e + !> Data set for @f$_{FF}^{M0}@f$. + TYPE(dset2d), PUBLIC, SAVE, TARGET :: mmp_qbff0 + !> Extended values of [[mmp_globals(module):mmp_qbff0(variable)]] dataset. + REAL(kind=mm_wp), PUBLIC, SAVE, DIMENSION(2,2) :: mmp_qbff0_e + + !> Data set for linear interpolation of transfert probability (M0/CO). + TYPE(dset1d), PUBLIC, SAVE, TARGET :: mmp_pco0p + !> Data set for linear interpolation of transfert probability (M3/CO). + TYPE(dset1d), PUBLIC, SAVE, TARGET :: mmp_pco3p + !> Data set for linear interpolation of transfert probability (M0/FM). + TYPE(dset1d), PUBLIC, SAVE, TARGET :: mmp_pfm0p + !> Data set for linear interpolation of transfert probability (M3/FM). + TYPE(dset1d), PUBLIC, SAVE, TARGET :: mmp_pfm3p + + !> \(b_{0}^{t}\) coefficients for Free-molecular regime kernel approximation. + REAL(kind=mm_wp), PUBLIC, SAVE, DIMENSION(5) :: mmp_bt0 = (/1._mm_wp,1._mm_wp,1._mm_wp,1._mm_wp,1._mm_wp/) + !> \(b_{3}^{t}\) coefficients for Free-molecular regime kernel approximation. + REAL(kind=mm_wp), PUBLIC, SAVE, DIMENSION(5) :: mmp_bt3 = (/1._mm_wp,1._mm_wp,1._mm_wp,1._mm_wp,1._mm_wp/) + + !> Spherical probability transfert control flag. + LOGICAL, SAVE :: mmp_w_ps2s = .true. + !> Aerosol electric charge correction control flag. + LOGICAL, SAVE :: mmp_w_qe = .true. + + + CONTAINS + + SUBROUTINE abort_program(err) + !! Dump error message and abort the program. + TYPE(error), INTENT(in) :: err !! Error object. + WRITE(stderr,'(a)') "ERROR: "//TRIM(err%msg) + CALL EXIT(err%id) + END SUBROUTINE abort_program + + + SUBROUTINE mmp_initialize(dt,df,rm,rho_aer,p_prod,tx_prod,rc_prod,rplanet,g0, air_rad,air_mmol,clouds,cfgpath) + !! Initialize global parameters of the model. + !! + !! The function initializes all the global parameters of the model from direct input. + !! Boolean (and Fiadero) parameters are optional as they are rather testing parameters. Their + !! default values are suitable for production runs. + !! @note + !! If the method fails to initialize parameters (i.e. returned error is not 0). Then the model + !! should probably be aborted as the global variables of the model will not be correctly setup. + !! + !! @warning + !! If OpenMP is activated, this subroutine must be called in an $OMP SINGLE statement as it + !! initializes global variable that are not thread private. + !! + !! ''' + !! !$OMP SINGLE + !! call mmp_initialize(...) + !! !$OMP END SINGLE + !! + REAL(kind=mm_wp), INTENT(in) :: dt + !! Microphysics timestep in seconds. + REAL(kind=mm_wp), INTENT(in) :: df + !! Fractal dimension of fractal aerosol. + REAL(kind=mm_wp), INTENT(in) :: rm + !! Monomer radius in meter. + REAL(kind=mm_wp), INTENT(in) :: rho_aer + !! Aerosol density in \(kg.m^{-3}\). + REAL(kind=mm_wp), INTENT(in) :: p_prod + !! Aerosol production pressure level in Pa. + REAL(kind=mm_wp), INTENT(in) :: tx_prod + !! Spherical aerosol mode production rate in \(kg.m^{-2}.s^{-1}\). + REAL(kind=mm_wp), INTENT(in) :: rc_prod + !! Spherical mode characteristic radius for production in meter. + REAL(kind=mm_wp), INTENT(in) :: rplanet + !! Planet radius in meter + REAL(kind=mm_wp), INTENT(in) :: g0 + !! Planet gravity acceleration at ground level in \(m.s^{-2}\). + REAL(kind=mm_wp), INTENT(in) :: air_rad + !! Air molecules mean radius in meter. + REAL(kind=mm_wp), INTENT(in) :: air_mmol + !! Air molecules mean molar mass in \(kg.mol^{-1}\). + LOGICAL, INTENT(in) :: clouds + !! Clouds microphysics control flag. + CHARACTER(len=*), INTENT(in), OPTIONAL :: cfgpath + !! Internal microphysic configuration file. + + INTEGER :: coag_choice + REAL(kind=mm_wp) :: fiad_max, fiad_min + LOGICAL :: w_h_prod, w_h_sed, w_h_coag, w_c_sed, w_c_nucond, & + no_fiadero, fwsed_m0, fwsed_m3 + TYPE(error) :: err + INTEGER :: i + TYPE(cfgparser) :: cparser + CHARACTER(len=st_slen) :: spcpath,pssfile,mqfile + CHARACTER(len=st_slen), DIMENSION(:), ALLOCATABLE :: species + REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE :: tmp + + w_h_prod = .true. + w_h_sed = .true. + w_h_coag = .true. + w_c_sed = clouds + w_c_nucond = clouds + fwsed_m0 = .true. + fwsed_m3 = .false. + no_fiadero = .false. + fiad_min = 0.1_mm_wp + fiad_max = 10._mm_wp + coag_choice = 7 + + WRITE(*,'(a)') "##### MMP_GCM SPEAKING #####" + WRITE(*,'(a)') "I will initialize ze microphysics model in moments YAMMS" + WRITE(*,'(a)') "On error I will simply abort the program. Stay near your computer !" + WRITE(*,*) + WRITE(*,'(a)') "Reading muphys configuration file ("//trim(cfgpath)//")..." + err = cfg_read_config(cparser,TRIM(cfgpath),.true.) + IF (err /= 0) THEN + ! RETURN AN ERROR !! + call abort_program(err) + ENDIF + + ! YAMMS internal parameters: + ! the following parameters are primarily used to test and debug YAMMS. + ! They are set in an optional configuration file and default to suitable values for production runs. + err = mm_check_opt(cfg_get_value(cparser,"haze_production",w_h_prod) ,w_h_prod ,.true. ,mm_log) + err = mm_check_opt(cfg_get_value(cparser,"haze_sedimentation",w_h_sed) ,w_h_sed ,.true. ,mm_log) + err = mm_check_opt(cfg_get_value(cparser,"haze_coagulation",w_h_coag) ,w_h_coag ,.true. ,mm_log) + err = mm_check_opt(cfg_get_value(cparser,"clouds_sedimentation",w_c_sed),w_c_sed ,clouds ,mm_log) + err = mm_check_opt(cfg_get_value(cparser,"clouds_nucl_cond",w_c_nucond) ,w_c_nucond ,clouds ,mm_log) + err = mm_check_opt(cfg_get_value(cparser,"wsed_m0",fwsed_m0) ,fwsed_m0 ,.true. ,mm_log) + err = mm_check_opt(cfg_get_value(cparser,"wsed_m3",fwsed_m3) ,fwsed_m3 ,.false. ,mm_log) + err = mm_check_opt(cfg_get_value(cparser,"no_fiadero",no_fiadero) ,no_fiadero ,.false. ,mm_log) + err = mm_check_opt(cfg_get_value(cparser,"fiadero_min_ratio",fiad_min) ,fiad_min ,0.1_mm_wp,mm_log) + err = mm_check_opt(cfg_get_value(cparser,"fiadero_max_ratio",fiad_max) ,fiad_max ,10._mm_wp,mm_log) + err = mm_check_opt(cfg_get_value(cparser,"haze_coag_interactions",coag_choice),coag_choice,7,mm_log) + + ! Retrieve clouds species configuration file + spcpath = '' + IF (clouds) THEN + err = mm_check_opt(cfg_get_value(cparser,"specie_cfg",spcpath), spcpath, wlog=mm_log) + IF (err/=0) call abort_program(err) + ENDIF + + ! YAMMS initialization. + err = mm_global_init_0(dt,df,rm,rho_aer,p_prod,tx_prod,rc_prod,rplanet,g0, & + air_rad,air_mmol,coag_choice,clouds,spcpath, & + w_h_prod,w_h_sed,w_h_coag,w_c_nucond, & + w_c_sed,fwsed_m0,fwsed_m3, & + no_fiadero,fiad_min,fiad_max) + IF (err /= 0) call abort_program(err) + + ! Extra initialization (needed for YAMMS method interfaces) + err = mm_check_opt(cfg_get_value(cparser, "transfert_probability", mmp_w_ps2s), mmp_w_ps2s, wlog=mm_log) + IF (err/=0) call abort_program(err) + err = mm_check_opt(cfg_get_value(cparser, "electric_charging" , mmp_w_qe ), mmp_w_qe, wlog=mm_log) + IF (err/=0) call abort_program(err) + + ! initialize transfert probabilities look-up tables + IF (mm_w_haze_coag .AND. mmp_w_ps2s) THEN + err = mm_check_opt(cfg_get_value(cparser, "ps2s_file", pssfile), pssfile) + IF (err /= 0) call abort_program(err) + + IF (.NOT.read_dset(pssfile,'p_m0_co',mmp_pco0p)) THEN + call abort_program(error("Cannot get 'p_m0_co' from "//pssfile,-1)) + ENDIF + IF (.NOT.read_dset(pssfile,'p_m3_co',mmp_pco3p)) THEN + call abort_program(error("Cannot get 'p_m3_co' from "//pssfile,-1)) + ENDIF + IF (.NOT.read_dset(pssfile,'p_m0_fm',mmp_pfm0p)) THEN + call abort_program(error("Cannot get 'p_m0_fm' from "//pssfile,-1)) + ENDIF + IF (.NOT.read_dset(pssfile,'p_m3_fm',mmp_pfm3p)) THEN + call abort_program(error("Cannot get 'p_m3_fm' from "//pssfile,-1)) + ENDIF + ENDIF + ! initialize mean electric correction look-up tables + IF (mm_w_haze_coag .AND. mmp_w_qe) THEN + err = mm_check_opt(cfg_get_value(cparser, "mq_file", mqfile), mqfile) + IF (err /= 0) call abort_program(err) + + IF (.NOT.read_dset(mqfile,'qbsf0',mmp_qbsf0)) THEN + call abort_program(error("Cannot get 'qbsf0' from "//mqfile,-1)) + ELSE + mmp_qbsf0_e(1,1) = MINVAL(mmp_qbsf0%x) + mmp_qbsf0_e(1,2) = MAXVAL(mmp_qbsf0%x) + mmp_qbsf0_e(2,1) = MINVAL(mmp_qbsf0%y) + mmp_qbsf0_e(2,2) = MAXVAL(mmp_qbsf0%y) + ENDIF + IF (.NOT.read_dset(mqfile,'qbsf3',mmp_qbsf3)) THEN + call abort_program(error("Cannot get 'qbsf3' from "//mqfile,-1)) + ELSE + mmp_qbsf3_e(1,1) = MINVAL(mmp_qbsf3%x) + mmp_qbsf3_e(1,2) = MAXVAL(mmp_qbsf3%x) + mmp_qbsf3_e(2,1) = MINVAL(mmp_qbsf3%y) + mmp_qbsf3_e(2,2) = MAXVAL(mmp_qbsf3%y) + ENDIF + IF (.NOT.read_dset(mqfile,'qbff0',mmp_qbff0)) THEN + call abort_program(error("Cannot get 'qbff0' from "//mqfile,-1)) + ELSE + mmp_qbff0_e(1,1) = MINVAL(mmp_qbff0%x) + mmp_qbff0_e(1,2) = MAXVAL(mmp_qbff0%x) + mmp_qbff0_e(2,1) = MINVAL(mmp_qbff0%y) + mmp_qbff0_e(2,2) = MAXVAL(mmp_qbff0%y) + ENDIF + ENDIF + ! spherical mode inter-moments function parameters + IF (.NOT.cfg_has_section(cparser,'alpha_s')) call abort_program(error("Cannot find [alpha_s] section",-1)) + err = read_aprm(cparser,'alpha_s',mmp_asp) + IF (err /= 0) call abort_program(error("alpha_s: "//TRIM(err%msg),-1)) + ! fractal mode inter-moments function parameters + IF (.NOT.cfg_has_section(cparser,'alpha_f')) call abort_program(error("Cannot find [alpha_f] section",-1)) + err = read_aprm(cparser,'alpha_f',mmp_afp) + IF (err /= 0) call abort_program(error("alpha_s: "//TRIM(err%msg),-1)) + ! btk coefficients + IF (.NOT.cfg_has_section(cparser,'btks')) call abort_program(error("Cannot find [btks] section",-1)) + err = cfg_get_value(cparser,"btks/bt0",tmp) ; IF (err/=0) call abort_program(error("bt0: "//TRIM(err%msg),-1)) + IF (SIZE(tmp) /= 5) call abort_program(error("bt0: Inconsistent number of coefficients",-1)) + mmp_bt0 = tmp + err = cfg_get_value(cparser,"btks/bt3",tmp) ; IF (err/=0) call abort_program(error("bt3: "//TRIM(err%msg),-1)) + IF (SIZE(tmp) /= 5) call abort_program(error("bt3: Inconsistent number of coefficients",-1)) + mmp_bt3 = tmp + + ! dump parameters ... + WRITE(*,'(a)') "========= MUPHYS PARAMETERS ===========" + WRITE(*,'(a,L2)') "transfert_probability: ", mmp_w_ps2s + WRITE(*,'(a,L2)') "electric_charging : ", mmp_w_qe + call mm_dump_parameters() + + END SUBROUTINE mmp_initialize + + FUNCTION read_aprm(parser,sec,pp) RESULT(err) + !! Read and store [[mmp_globals(module):aprm(type)]] parameters. + TYPE(cfgparser), INTENT(in) :: parser !! Configuration parser + CHARACTER(len=*), INTENT(in) :: sec !! Name of the section that contains the parameters. + TYPE(aprm), INTENT(out) :: pp !! [[mmp_globals(module):aprm(type)]] object that stores the parameters values. + TYPE(error) :: err !! Error status of the function. + err = cfg_get_value(parser,TRIM(sec)//'/a',pp%a) ; IF (err /= 0) RETURN + err = cfg_get_value(parser,TRIM(sec)//'/b',pp%b) ; IF (err /= 0) RETURN + err = cfg_get_value(parser,TRIM(sec)//'/c',pp%c) ; IF (err /= 0) RETURN + IF (SIZE(pp%a) /= SIZE(pp%b) .OR. SIZE(pp%a) /= SIZE(pp%c)) & + err = error("Inconsistent number of coefficients (a,b, and c must have the same size)",-1) + RETURN + END FUNCTION read_aprm + +END MODULE MMP_GCM + Index: trunk/LMDZ.TITAN/libf/muphytitan/mp_moments.f90 =================================================================== --- trunk/LMDZ.TITAN/libf/muphytitan/mp_moments.f90 (revision 1793) +++ trunk/LMDZ.TITAN/libf/muphytitan/mp_moments.f90 (revision 1793) @@ -0,0 +1,266 @@ +! Copyright 2013-2015 Université de Reims Champagne-Ardenne +! Contributor: J. Burgalat (GSMA, URCA) +! email of the author : jeremie.burgalat@univ-reims.fr +! +! This software is a computer program whose purpose is to compute +! microphysics processes using a two-moments scheme. +! +! This library is governed by the CeCILL license under French law and +! abiding by the rules of distribution of free software. You can use, +! modify and/ or redistribute the software under the terms of the CeCILL +! license as circulated by CEA, CNRS and INRIA at the following URL +! "http://www.cecill.info". +! +! As a counterpart to the access to the source code and rights to copy, +! modify and redistribute granted by the license, users are provided only +! with a limited warranty and the software's author, the holder of the +! economic rights, and the successive licensors have only limited +! liability. +! +! In this respect, the user's attention is drawn to the risks associated +! with loading, using, modifying and/or developing or reproducing the +! software by the user in light of its specific status of free software, +! that may mean that it is complicated to manipulate, and that also +! therefore means that it is reserved for developers and experienced +! professionals having in-depth computer knowledge. Users are therefore +! encouraged to load and test the software's suitability as regards their +! requirements in conditions enabling the security of their systems and/or +! data to be ensured and, more generally, to use and operate it in the +! same conditions as regards security. +! +! The fact that you are presently reading this means that you have had +! knowledge of the CeCILL license and that you accept its terms. + +!! file: mmp_moments.f90 +!! summary: YAMMS/MP2M model external methods +!! author: J. Burgalat +!! date: 2013-2015 +!! +!! This file contains the definitions of all external methods that should be defined +!! for mp2m library. +!! +!! All the methods defined here satisify the interfaces defined in __m_interfaces__ module +!! of YAMMS library. + +PURE FUNCTION mm_alpha_s(k) RESULT (res) + !! Inter-moment relation for spherical aerosols size distribution law. + !! + !! The method computes the relation between the kth order moment and the 0th + !! order moment of the size-distribution law: + !! + !! $$ \dfrac{M_{k}}{M_{0}} = r_{C}^{k} \times \alpha(k,a_{1},...a_{n}) $$ + !! + !! Here, alpha is computed as a sum of expenontial functions. + USE MMP_GCM, ONLY : mmp_asp, mm_wp + IMPLICIT NONE + REAL(kind=mm_wp), INTENT(in) :: k !! k Order of the moment. + REAL(kind=mm_wp) :: res !! Alpha value. + res = SUM(dexp(mmp_asp%a*k**2+mmp_asp%b*k+mmp_asp%c)) + RETURN +END FUNCTION mm_alpha_s + +PURE FUNCTION mm_alpha_f(k) RESULT (res) + !! Inter-moment relation for fractal aerosols size distribution law. + !! + !! [[mm_alpha_f(function)]] performs the same computations as [[mm_alpha_s(function)]] + !! using another set of parameters for the exponential functions. + USE MMP_GCM, ONLY : mmp_afp, mm_wp + IMPLICIT NONE + REAL(kind=mm_wp), INTENT(in) :: k !! k Order of the moment. + REAL(kind=mm_wp) :: res !! Alpha value. + res = SUM(dexp(mmp_afp%a*k**2+mmp_afp%b*k+mmp_afp%c)) + RETURN +END FUNCTION mm_alpha_f + +FUNCTION mm_ps2s(rcs,k,flow,t,p) RESULT(res) + !! Get the proportion of aerosols that remains in the spherical mode during SS coagulation. + !! + !! From __k__ and __flow__ values, the method selects one of the four probability datasets datasets + !! in [[mmp_globals(module)]] module (for instance [[mmp_globals(module):mmp_pco0p(variable)]]) + !! and interpolates linearly probability for the given value of __rcs__, __t__ and __p__. + !! + !! @warning + !! Here, the method assumes the datasets define the probability for __spherical__ particles to + !! be transferred in the __fractal__ mode, but returns the proportion of particles that remains + !! in the mode (which is expected by mp2m model). + !! + !! @attention + !! If value cannot be interpolated, the method aborts the program. Normally, it cannot happen + !! since we extrapolate the probability for characteristic radius value out of range. + !! + !! @attention + !! Consequently, as the probability can only range from 0 to 1, it is wise to ensure that the + !! look-up table limits this range: To do so, one can just add two values at the start and end + !! of the table with probabilities respectively set to 0 and 1. + USE LINTDSET + USE LOCATORS + USE MMP_GCM, ONLY : mmp_pco0p,mmp_pfm0p,mmp_pco3p,mmp_pfm3p,mmp_w_ps2s,mm_wp + IMPLICIT NONE + REAL(kind=mm_wp), INTENT(in) :: rcs + !! Characteristic radius of the spherical size-distribution (m). + INTEGER, INTENT(in) :: k + !! Order of the moment (0 or 3). + INTEGER, INTENT(in) :: flow + !! Flow regime indicator (0: Continous, 1: Free-molecular). + REAL(kind=mm_wp), INTENT(in) :: t + !! Temperature (K). + REAL(kind=mm_wp), INTENT(in) :: p + !! Pressure level (Pa). + REAL(kind=mm_wp) :: res + !! Proportion of spherical particles that stay in the spherical mode during SS coagulation. + TYPE(dset1d), POINTER :: pp + res = 1._mm_wp + IF (rcs <= 0.0_mm_wp .OR. .NOT.mmp_w_ps2s) RETURN + SELECT CASE(k+flow) + CASE(0) ; pp => mmp_pco0p ! 0 = 0 + 0 -> M0 / CO + CASE(1) ; pp => mmp_pfm0p ! 1 = 0 + 1 -> M0 / FM + CASE(3) ; pp => mmp_pco3p ! 3 = 3 + 0 -> M3 / CO + CASE(4) ; pp => mmp_pfm3p ! 4 = 3 + 1 -> M3 / FM + CASE DEFAULT ; RETURN + END SELECT + IF (.NOT.hdcd_lint_dset(rcs,pp,locate_reg_ext,res)) THEN + WRITE(*,'(a)') "mm_moments:ps2s_sc: Cannot interpolate transfert probability" + call EXIT(10) + ELSE + ! 05102017: do not care anymore for bad extrapolation: + ! Bound probability value between 0 and 1 + ! note: The input look-up table still must have strict monotic variation or + ! awkward results can be produced. + res = MAX(0.0_mm_wp,MIN(res,1.0_mm_wp)) + ! we have interpolated f = 1-p and we need p ! + res = 1._mm_wp - res + ENDIF +END FUNCTION mm_ps2s + +FUNCTION mm_qmean(rc1,rc2,order,modes,temp,pres) RESULT(res) + !! Get the electric correction for coagulation kernel. + !! + !! The method computes the eletric charging correction to apply to the coagulation + !! kernel as a function of the temperature, pressure and the characteristic radius of + !! the mode involved in the coagulation. + !! + !! Modes are referred by a two letters uppercase string with the combination of: + !! + !! - S : spherical mode + !! - F : fractal mode + !! + !! For example, SS means intra-modal coagulation for spherical particles. + !! + !! Here the electric charging correction is computed using linear interpolation from + !! pre-tabulated values. + USE LINTDSET + USE LOCATORS + USE MMP_GCM, ONLY : mmp_w_qe,mmp_qbsf0,mmp_qbsf3,mmp_qbff0, & + mmp_qbsf0_e,mmp_qbsf3_e,mmp_qbff0_e,mm_wp + IMPLICIT NONE + REAL(kind=mm_wp), INTENT(in) :: rc1 !! Characteristic radius of the first mode (m). + REAL(kind=mm_wp), INTENT(in) :: rc2 !! Characteristic radius of the the second mode (m). + INTEGER, INTENT(in) :: order !! Moment's order (0 or 3 expected). + CHARACTER(len=2), INTENT(in) :: modes !! Interaction mode (a combination of [S,F]). + REAL(kind=mm_wp), INTENT(in) :: temp !! Temperature (K). + REAL(kind=mm_wp), INTENT(in) :: pres !! Pressure level (Pa). + REAL(kind=mm_wp) :: res !! Electric charging correction. + INTEGER :: chx,np + REAL(kind=mm_wp) :: vmin,vmax + REAL(kind=mm_wp) :: r_tmp, t_tmp + chx = 0 + IF (.NOT.mmp_w_qe) THEN + res = 1._mm_wp + RETURN + ENDIF + + IF (SCAN(modes(1:1),"sS") /= 0) chx = chx + 1 + IF (SCAN(modes(2:2),"sS") /= 0) chx = chx + 1 + IF (SCAN(modes(1:1),"fF") /= 0) chx = chx + 3 + IF (SCAN(modes(2:2),"fF") /= 0) chx = chx + 3 + chx = chx + order + SELECT CASE(chx) + CASE(2) ! M0/SS + res = 1._mm_wp + CASE(4) ! M0/SF + ! Fix max values of input parameters + r_tmp = MAX(MIN(log(rc1),mmp_qbsf0_e(2,2)),mmp_qbsf0_e(2,1)) + t_tmp = MAX(MIN(temp,mmp_qbsf0_e(1,2)),mmp_qbsf0_e(1,1)) + ! Interpolates values + IF (.NOT.hdcd_lint_dset(t_tmp,r_tmp,mmp_qbsf0,locate_reg,res)) THEN + WRITE(*,'(a)') "mm_moments:mm_qmean: Cannot interpolate mean Qelec" + call EXIT(10) + ENDIF + CASE(5) ! M3/SS + res = 1._mm_wp + CASE(6) ! M0/FF + r_tmp = MAX(MIN(log(rc1),mmp_qbff0_e(2,2)),mmp_qbff0_e(2,1)) + t_tmp = MAX(MIN(temp,mmp_qbff0_e(1,2)),mmp_qbff0_e(1,1)) + IF (.NOT.hdcd_lint_dset(t_tmp,r_tmp,mmp_qbff0,locate_reg,res)) THEN + WRITE(*,'(a)') "mm_moments:mm_qmean: Cannot interpolate mean Qelec" + call EXIT(10) + ENDIF + CASE(7) ! M3/SF + r_tmp = MAX(MIN(log(rc1),mmp_qbsf3_e(2,2)),mmp_qbsf3_e(2,1)) + t_tmp = MAX(MIN(temp,mmp_qbsf3_e(1,2)),mmp_qbsf3_e(1,1)) + IF (.NOT.hdcd_lint_dset(t_tmp,r_tmp,mmp_qbsf3,locate_reg,res)) THEN + WRITE(*,'(a)') "mm_moments:mm_qmean: Cannot interpolate mean Qelec" + call EXIT(10) + ENDIF + CASE DEFAULT ! anything else :) + res = 1._mm_wp + END SELECT + RETURN +END FUNCTION mm_qmean + +PURE FUNCTION mm_get_btk(t,k) RESULT(res) + !! Get the \(b_{k}^{T}\) coefficient of the Free Molecular regime. + !! + !! The method get the value of the Free-molecular regime coagulation pre-factor \(b_{k}^{T}\). + !! For more details about this coefficient, please read [Coagulation](page/haze.html#coagulation) + !! documentation page. + !! + !! @warning + !! __k__ can only be one of the following value : 0 or 3. __t__ ranges only from 1 to 5. + USE MMP_GCM, ONLY : mmp_bt0,mmp_bt3,mm_wp + IMPLICIT NONE + INTEGER, INTENT(in) :: t !! Type index of the \(b_{k}^{T}\) coefficient to get + INTEGER, INTENT(in) :: k !! Moment Order of the \(b_{k}^{T}\) coefficient to get + REAL(kind=mm_wp) :: res !! \(b_{k}^{T}\) coefficient + IF (.NOT.(k == 3 .OR. k == 0)) res = 0._mm_wp + IF (t > 5 .OR. t < 1) res = 0._mm_wp + IF (k == 0) THEN + res = mmp_bt0(t) + ELSE IF (k == 3) THEN + res = mmp_bt3(t) + ENDIF + RETURN +END FUNCTION mm_get_btk + +ELEMENTAL FUNCTION mm_eta_g(t) RESULT (res) + !! Get the air viscosity at a given temperature. + !! + !! The function computes the air viscosity at temperature __t__ using Sutherland method. + USE MMP_GCM, ONLY: mm_wp + IMPLICIT NONE + REAL(kind=mm_wp), INTENT(in) :: t !! Temperature (K). + REAL(kind=mm_wp) :: res !! Air viscosity at given temperature (\(Pa.s^{-1}\)). + REAL (kind=mm_wp), PARAMETER :: eta0 = 1.75e-5_mm_wp, & + tsut = 109._mm_wp, & + tref = 293._mm_wp + res = eta0 *dsqrt(t/tref)*(1._mm_wp+tsut/tref)/(1._mm_wp+tsut/t) + RETURN +END FUNCTION mm_eta_g + +ELEMENTAL FUNCTION mm_lambda_g(t,p) RESULT(res) + !! Get the air mean free path at given temperature and pressure. + !! + !! The method computes the air mean free path: + !! + !! $$ \lambda_{g} = \dfrac{k_{b}T}{4\sqrt{2}\pi r_{a}^2 P} $$ + !! + !! Where \(\lambda_{g}\), is the air mean free path, \(k_{b}\) the Boltzmann constant, T the + !! temperature, P the pressure level and \(r_{a}\) the radius of an _air molecule_. + USE MMP_GCM, ONLY: mm_wp,mm_pi,mm_air_rad,mm_kboltz + IMPLICIT NONE + REAL(kind=mm_wp), INTENT(in) :: t !! Temperature (K). + REAL(kind=mm_wp), INTENT(in) :: p !! Pressure level (Pa). + REAL(kind=mm_wp) :: res !! Air mean free path (m). + res = mm_kboltz*t/(4._mm_wp*dsqrt(2._mm_wp)*mm_pi*(mm_air_rad**2)*p) + RETURN +END FUNCTION mm_lambda_g Index: trunk/LMDZ.TITAN/libf/muphytitan/strings.F90 =================================================================== --- trunk/LMDZ.TITAN/libf/muphytitan/strings.F90 (revision 1793) +++ trunk/LMDZ.TITAN/libf/muphytitan/strings.F90 (revision 1793) @@ -0,0 +1,2418 @@ +! Copyright Jérémie Burgalat (2017) +! +! burgalat.jeremie@gmail.com +! +! This software is a computer program whose purpose is to provide configuration +! file and command line arguments parsing features to Fortran programs. +! +! This software is governed by the CeCILL-B license under French law and +! abiding by the rules of distribution of free software. You can use, +! modify and/ or redistribute the software under the terms of the CeCILL-B +! license as circulated by CEA, CNRS and INRIA at the following URL +! "http://www.cecill.info". +! +! As a counterpart to the access to the source code and rights to copy, +! modify and redistribute granted by the license, users are provided only +! with a limited warranty and the software's author, the holder of the +! economic rights, and the successive licensors have only limited +! liability. +! +! In this respect, the user's attention is drawn to the risks associated +! with loading, using, modifying and/or developing or reproducing the +! software by the user in light of its specific status of free software, +! that may mean that it is complicated to manipulate, and that also +! therefore means that it is reserved for developers and experienced +! professionals having in-depth computer knowledge. Users are therefore +! encouraged to load and test the software's suitability as regards their +! requirements in conditions enabling the security of their systems and/or +! data to be ensured and, more generally, to use and operate it in the +! same conditions as regards security. +! +! The fact that you are presently reading this means that you have had +! knowledge of the CeCILL-B license and that you accept its terms. + +!! file: strings.F90 +!! summary: Strings manipulation source file +!! author: burgalat +!! date: 2017 + +#include "defined.h" + +MODULE STRINGS + !! Fortran strings manipulation module + !! + !! This module provides methods and objects to manipulate Fortran (allocatable) strings. It defines + !! a doubly linked-list of strings, [[strings(module):words(type)]] and several methods to format + !! strings or convert them in other intrinsic types. + USE ERRORS + IMPLICIT NONE + + PRIVATE + + PUBLIC :: str2dble_sc,str2dble_ve,str2real_sc,str2real_ve + ! errors module (not used but propagated) + PUBLIC :: noerror,error, error_to_string,aborting + + ! misc module methods + PUBLIC :: to_string, from_string, string_is, remove_quotes, format_string, & + format_paragraph, strip_newline, tokenize, str_length, str_endswith, & + str_startswith, str_to_lower, str_to_upper, str_add_attributes, & + str_delete_attributes, str_reset_attributes, str_remove, str_replace + + ! words object related methods + PUBLIC :: words_length, words_insert, words_append, words_prepend, words_get, & + words_set, words_get_max_width, words_get_total_width, words_pop, & + words_remove, words_next, words_previous, words_reset, & + words_valid, words_current, words_extend, words_reverse, & + words_reversed, words_dump, words_to_string, words_to_vector, & + new_words, words_clear + + ! Operators + PUBLIC :: ASSIGNMENT(=), OPERATOR(/=), OPERATOR(==) + + INTEGER, PUBLIC, PARAMETER :: st_string = 1 !! String type ID + INTEGER, PUBLIC, PARAMETER :: st_logical = 2 !! Logical type ID + INTEGER, PUBLIC, PARAMETER :: st_complex = 3 !! Complex type ID + INTEGER, PUBLIC, PARAMETER :: st_integer = 4 !! Integer type ID + INTEGER, PUBLIC, PARAMETER :: st_real = 5 !! Real type ID + + !> List of types names + CHARACTER(len=*), DIMENSION(5), PARAMETER, PUBLIC :: st_type_names = & + (/ 'string ', 'logical', 'complex', 'integer', 'real '/) + + INTEGER, PUBLIC, PARAMETER :: st_slen = SSLEN !! Maximum short string length + INTEGER, PUBLIC, PARAMETER :: st_llen = SLLEN !! Maximum long string length + + INTEGER, PUBLIC, PARAMETER :: FC_BLACK = 30 !! Black foreground csi code + INTEGER, PUBLIC, PARAMETER :: FC_RED = 31 !! Red foreground csi code + INTEGER, PUBLIC, PARAMETER :: FC_GREEN = 32 !! Green foreground csi code + INTEGER, PUBLIC, PARAMETER :: FC_YELLOW = 33 !! Yellow foreground csi code + INTEGER, PUBLIC, PARAMETER :: FC_BLUE = 34 !! Blue foreground csi code + INTEGER, PUBLIC, PARAMETER :: FC_MAGENTA = 35 !! Magenta foreground csi code + INTEGER, PUBLIC, PARAMETER :: FC_CYAN = 36 !! Cyan foreground csi code + INTEGER, PUBLIC, PARAMETER :: FC_WHITE = 37 !! White foreground csi code + INTEGER, PUBLIC, PARAMETER :: BG_BLACK = 40 !! Black foreground csi code + INTEGER, PUBLIC, PARAMETER :: BG_RED = 41 !! Black background csi code + INTEGER, PUBLIC, PARAMETER :: BG_GREEN = 42 !! Green background csi code + INTEGER, PUBLIC, PARAMETER :: BG_YELLOW = 43 !! Yellow background csi code + INTEGER, PUBLIC, PARAMETER :: BG_BLUE = 44 !! Blue background csi code + INTEGER, PUBLIC, PARAMETER :: BG_MAGENTA = 45 !! Magenta background csi code + INTEGER, PUBLIC, PARAMETER :: BG_CYAN = 46 !! Cyan background csi code + INTEGER, PUBLIC, PARAMETER :: BG_WHITE = 47 !! White background csi code + INTEGER, PUBLIC, PARAMETER :: ST_NORMAL = 0 !! Normal (regular) attribute + INTEGER, PUBLIC, PARAMETER :: ST_BOLD = 1 !! Bold (brighter) attribute + INTEGER, PUBLIC, PARAMETER :: ST_ITALIC = 3 !! Italic attribute (sometimes reverse video or underline) + INTEGER, PUBLIC, PARAMETER :: ST_UNDERLINE = 4 !! Underline attribute + INTEGER, PUBLIC, PARAMETER :: ST_BLINK = 5 !! Slow blink mode + !> List of all attributes in a vector + INTEGER, PUBLIC, PARAMETER, DIMENSION(21) :: attributes = [FC_BLACK, & + FC_RED, & + FC_GREEN, & + FC_YELLOW, & + FC_BLUE, & + FC_MAGENTA, & + FC_CYAN, & + FC_WHITE, & + BG_BLACK, & + BG_RED, & + BG_GREEN, & + BG_YELLOW, & + BG_BLUE, & + BG_MAGENTA, & + BG_CYAN, & + BG_WHITE, & + ST_NORMAL, & + ST_BOLD, & + ST_ITALIC, & + ST_UNDERLINE, & + ST_BLINK & + ] + + !> [[words(type)]] object assignement interface + INTERFACE ASSIGNMENT(=) + MODULE PROCEDURE ws_affect + END INTERFACE + + + !> [[words(type)]] interface constructor + !! + !! The interface encapsulates the two constructors of the words object: + !! + !! - [[new_words_1(function)]] initializes the object with a single word. + !! - [[new_words_str(function)]] initializes the object with a string that is + !! splitted according to a given delimiter. + INTERFACE new_words + MODULE PROCEDURE new_words_1, new_words_str + END INTERFACE + + !> Clear either a scalar or a vector of list of [[words(type)]] + !! + !! The interface encapsulates words _destructors_, that deallocate memory used + !! by the given list(s) of words. This method should be called anytime words + !! object(s) is no longer used to avoid memory leaks. + !! @note + !! If the library support Derived type finalization, calling destructor is not + !! mandatory. + INTERFACE words_clear + MODULE PROCEDURE ws_clear_sc, ws_clear_ve + END INTERFACE + + !> Extend a given [[words(type)]] object either by another or by a string + !! + !! The interface encapsulates two subroutines: + !! + !! - [[ws_extend_ws(subroutine)]](this,other) which extends __this__ by __other__ + !! (both are words objects). + !! - [[ws_extend_str(subroutine)]](this,str,delimiter,merge) which splits __str__ + !! according to __delimiter__ (and optionally __merge__) and then extends + !! __this__ with the resulting tokens. + INTERFACE words_extend + MODULE PROCEDURE ws_extend_ws,ws_extend_str + END INTERFACE + + !> Convert an intrinsic type value to a string + !! + !! This (very) generic interface provides conversion functions from + !! intrinsic types to ALLOCATED string. + !! + !! ``` + !! (1) FUNCTION to_string(value) RESULT(str) + !! (2) FUNCTION to_string(value,fmt,width) RESULT(str) + !! ``` + !! Where : + !! + !! - __value__ is the value to convert + !! - __fmt__ is a string the format descriptor of the output string. Surrounding + !! parenthesis can be omitted. + !! - __width__ is an integer with the width of the output string (which should be given + !! in __fmt__ anyway). + !! - __str__ is an allocatable string with the converted value in output, or an empty + !! string if the conversion failed. + INTERFACE to_string + MODULE PROCEDURE int2str_as,int2str_fs + MODULE PROCEDURE log2str_as,log2str_fs + MODULE PROCEDURE real2str_as,real2str_fs + MODULE PROCEDURE dble2str_as,dble2str_fs + MODULE PROCEDURE cplx2str_as,cplx2str_fs + END INTERFACE + + !> Convert a string into an intrisinc type + !! + !! All methods defined in the interface are functions which take in arguments, + !! a string (input) and an output variable with the relevant type (or vectors of both). + !! They always return an error object which is set to -5 error code (i.e. cannot cast value) + !! on error, otherwise [[errors(module):noerror(variable)]]. + INTERFACE from_string + MODULE PROCEDURE str2int_sc,str2log_sc,str2real_sc,str2dble_sc,str2cplx_sc + MODULE PROCEDURE str2int_ve,str2log_ve,str2real_ve,str2dble_ve,str2cplx_ve + END INTERFACE + + !> Define a linked word + !! + !! Linked words are only intended to be used within a words type. + !! It's part of the doubly linked list words. + TYPE, PUBLIC :: word +#if HAVE_FTNDTSTR + CHARACTER(len=:), ALLOCATABLE :: value !! Value of the word +#else + !> Value of the word + !! + !! @warning + !! It is always limited to strings::st_slen characters. + CHARACTER(len=st_slen) :: value = '' +#endif + TYPE(word), PRIVATE, POINTER :: next => null() !! Next word in the list of words + TYPE(word), PRIVATE, POINTER :: prev => null() !! Previous word in the list of words + END TYPE word + + !> Define a list of words + TYPE, PUBLIC :: words + INTEGER :: nw = 0 !! Number of word in the list + TYPE(word), PRIVATE, POINTER :: head => null() !! First word in the list + TYPE(word), PRIVATE, POINTER :: tail => null() !! Last word in the list + TYPE(word), PRIVATE, POINTER :: iter => null() !! Current word (iterator) +#if HAVE_FTNPROC + CONTAINS + PROCEDURE, PRIVATE :: ws_extend_ws + PROCEDURE, PRIVATE :: ws_extend_str + PROCEDURE, PUBLIC :: length => words_length + !! Get the number of words in the list + PROCEDURE, PUBLIC :: insert => words_insert + !! Insert a word at given index + PROCEDURE, PUBLIC :: append => words_append + !! Append a word at the end of the list + PROCEDURE, PUBLIC :: prepend => words_prepend + !! Prepend a word at the beginning of the list + PROCEDURE, PUBLIC :: get => words_get + !! Get the word at given index + PROCEDURE, PUBLIC :: set => words_set + !! Set a word at given index + PROCEDURE, PUBLIC :: max_width => words_get_max_width + !! Get the width of the biggest word in the list + PROCEDURE, PUBLIC :: total_width => words_get_total_width + !! Get the total width of the words stored in the list + PROCEDURE, PUBLIC :: reverse => words_reverse + !! Reverse the list in place + PROCEDURE, PUBLIC :: reversed => words_reversed + !! Get a reversed copy of the list + PROCEDURE, PUBLIC :: dump => words_dump + !! Dump words of the list (on per line) + PROCEDURE, PUBLIC :: tostring => words_to_string + !! Convert the list in a single string + PROCEDURE, PUBLIC :: to_vector => words_to_vector + !! Convert the list in a vector + PROCEDURE, PUBLIC :: pop => words_pop + !! Pop a word from the list and returns it + PROCEDURE, PUBLIC :: remove => words_remove + !! Remove a word from the list + PROCEDURE, PUBLIC :: next => words_next + !! Go to the next word in the list + PROCEDURE, PUBLIC :: previous => words_previous + !! Go to the previous word in the list + PROCEDURE, PUBLIC :: reset => words_reset + !! Reset the list's iterator + PROCEDURE, PUBLIC :: valid => words_valid + !! Check if iterator position is valid + PROCEDURE, PUBLIC :: current => words_current + !! Get the current word in the list + GENERIC, PUBLIC :: extend => ws_extend_ws,ws_extend_str + !! Extend a list with either a string or another list of words +#endif + END TYPE words + + CONTAINS + + FUNCTION word_length(this) RESULT(lgth) + !! Get the trimmed length of the word object + TYPE(word), INTENT(in) :: this + !! A word object + INTEGER :: lgth + !! The length of the word's value (without trailing spaces) +#if HAVE_FTNDTSTR + IF (.NOT.ALLOCATED(this%value)) THEN + lgth = 0 ; RETURN + ENDIF +#endif + lgth = LEN_TRIM(this%value) + RETURN + END FUNCTION word_length + + SUBROUTINE disconnect_word(this) + !! Disconnect a word object + !! + !! The object is no more connected to its neighbours which are connected together. + !! @note + !! After this method is called the object is no longer connected to its parent words + !! object and should be deallocated in order to avoid memory leaks. + TYPE(word), INTENT(inout) :: this + !! A word object to disconnect + TYPE(word), POINTER :: pw,nw + nw => this%next ; pw => this%prev + IF (ASSOCIATED(nw)) nw%prev => pw + IF (ASSOCIATED(pw)) pw%next => nw + RETURN + END SUBROUTINE disconnect_word + + FUNCTION new_words_1(value) RESULT(list) + !! words constructor + !! + !! The method initializes a list of words with a single value. + CHARACTER(len=*), INTENT(in), OPTIONAL :: value + !! An optional string with the value to set in the list + TYPE(words) :: list + !! A words object + IF (PRESENT(value)) CALL ini_word(list,value) + RETURN + END FUNCTION new_words_1 + + FUNCTION new_words_str(string,delimiter,merge,protect) RESULT(list) + !! words constructor (extended version) + !! + !! The method splits an input strings and initializes a words object with the resulting tokens. + CHARACTER(len=*), INTENT(in) :: string + !! A string used to initialize the words object + CHARACTER(len=*), INTENT(in) :: delimiter + !! A string with the words delimiters. + !! + !! Note that each character is seen as a single delimiter. + LOGICAL, INTENT(in), OPTIONAL :: merge + !! An optional boolean control flag that instructs the method + !! wether to merge or not successive delimiters (default to .false.) + LOGICAL, INTENT(in), OPTIONAL :: protect + !! An optional boolean flag with .true. (default) to indicate that delimiter characters + !! between quotes are protected + TYPE(words) :: list + !! A new words object + CHARACTER(len=:), ALLOCATABLE :: seps + LOGICAL :: zmerge, zprotect + zmerge = .false. ; zprotect = .true. ; seps = ' ' + IF (PRESENT(merge)) zmerge = merge + IF (PRESENT(protect)) zprotect = protect + IF (LEN(delimiter) > 0) seps = delimiter + CALL ws_extend_str(list,string,seps,zmerge,zprotect) + RETURN + END FUNCTION new_words_str + + SUBROUTINE ws_affect(this,other) + !! words object assignment operator subroutine + TYPE(words), INTENT(out) :: this + !! A words object to be assigned + TYPE(words), INTENT(in) :: other + !! A words object to assign + TYPE(word), POINTER :: cur + CALL ws_clear_sc(this) + IF (other%nw == 0) THEN + RETURN + ELSE + cur => other%head + DO WHILE(associated(cur)) +#if HAVE_FTNDTSTR + IF (.NOT.ALLOCATED(cur%value)) THEN + CALL words_append(this,"") + ELSE + CALL words_append(this,cur%value) + ENDIF +#else + CALL words_append(this,cur%value) +#endif + IF (ASSOCIATED(cur,other%iter)) this%iter => this%tail + cur => cur%next + ENDDO + ENDIF + RETURN + END SUBROUTINE ws_affect + + SUBROUTINE ini_word(this,value) + !! Initialize the first word of a list of words + !! + !! This subroutine is not a constructor. It is only intended to set the first word + !! object in a words object. + TYPE(words), INTENT(inout) :: this + !! A words object reference + CHARACTER(len=*), INTENT(in) :: value + !! A string with the word used to initialize the list + ALLOCATE(this%head) + this%head%next => null() + this%head%prev => null() + this%tail => this%head + ASSIGN_DTSTR(value,this%tail%value) + this%nw = 1 + RETURN + END SUBROUTINE ini_word + + SUBROUTINE ws_clear_sc(obj) + !! Clear a list of words + !! + !! This subroutine deallocates all memory used by the given words object. + !! @warning + !! The subroutine should be called whenever a words is no more used (e.g. at + !! the end of the current scope), otherwise memory leaks could occur. + TYPE(words),INTENT(inout), TARGET :: obj + !! A words object to clear + TYPE(word), POINTER :: cur,next + IF (obj%nw == 0) RETURN + cur => obj%head + DO WHILE(ASSOCIATED(cur)) + next => cur%next + CALL disconnect_word(cur) +#if HAVE_FTNDTSTR + IF (ALLOCATED(cur%value)) DEALLOCATE(cur%value) +#endif + DEALLOCATE(cur) + cur => next + ENDDO + obj%nw = 0 + obj%head => null() ; obj%tail => null() + obj%iter => null() + END SUBROUTINE ws_clear_sc + + SUBROUTINE ws_clear_ve(objs) + !! Clear a vector of list of words + !! + !! This subroutine deallocates all memory used by the given vector of words objects. + !! @warning + !! The subroutine should be called whenever a words is no more used (e.g. at the end + !! of the current scope), otherwise memory leaks could occur. + TYPE(words),INTENT(inout), DIMENSION(:) :: objs + !! A vector of words objects to clear + TYPE(word), POINTER :: cur,next + INTEGER :: i + DO i=1,SIZE(objs) + IF (objs(i)%nw == 0) CYCLE + cur => objs(i)%head + DO WHILE(ASSOCIATED(cur)) + next => cur%next + CALL disconnect_word(cur) + DEALLOCATE(cur) + cur => next + ENDDO + objs(i)%nw = 0 + objs(i)%head => null() ; objs(i)%tail => null() + ENDDO + END SUBROUTINE ws_clear_ve + + SUBROUTINE ws_extend_ws(this, other) + !! Extend a list of words with another one + OBJECT(words), INTENT(inout) :: this + !! A words object to extend + TYPE(words), INTENT(in) :: other + !! A words object to extend with + TYPE(word), POINTER :: cw + IF (other%nw == 0) RETURN + cw => other%head + DO WHILE(ASSOCIATED(cw)) + CALL words_append(this,cw%value) ; cw => cw%next + ENDDO + RETURN + END SUBROUTINE ws_extend_ws + + SUBROUTINE ws_extend_str(this,str,delimiter,merge,protect) + !> Extend a list of word with a given string + !! @details The method adds a new list of words to the current list by + !! splitting a string using a set of delimiters. + !! + !! - If __delimiter__ is not given, THEN blank space is used. + !! - __delimiter__ can be a string of any length, but each character of + !! the sequence is seen as a single delimiter. Each time one of these + !! special character is seen on the string, it is splitted. + !! - If __protect__ is set to .true. THEN delimiter enclosed by + !! either single or double quotes are protected. + !! - The optional argument __merge__ instructs the method wether to merge + !! or not successive delimiters in the string. + !! + !! For example, considering the following string: + !!
@verbatim "I like coffee and bananas." @endverbatim
+ !! - Used with only __delimiter__ = " e", the method returns the list: + !!
"I","lik","","coff","","","and","bananas"
+ !! - Used with both __delimiter__ = " e" and __merge__ = .true. : + !!
"I","lik","coff","and","bananas"
+ !! @warning + !! The method does not trim or adjust the input string. Consequently, it can + !! add several empty words at the end of the list if the string is not well + !! defined. + !! @warning To avoid such problems, consider using TRIM() and ADJUSTL() + !! function on __str__ actual argument when calling this subroutine. + OBJECT(words), INTENT(inout), TARGET :: this + !! A words object to extend + CHARACTER(len=*), INTENT(in) :: str + !! A string to split in words + CHARACTER(len=*), INTENT(in), OPTIONAL :: delimiter + !! An optional string with the words delimiters (default to blank space). + LOGICAL, INTENT(in), OPTIONAL :: merge + !! An optional boolean control flag that instructs the method + !! wether to merge or not successive delimiters (default to .false.) + LOGICAL, INTENT(in), OPTIONAL :: protect + !! An optional boolean flag with .true. to indicate that + !! delimiter characters between quotes are protected + ! - LOCAL + INTEGER :: sl,p,i,j,stat + LOGICAL :: zmerge,zprotect,indq,insq,outer + CHARACTER(len=:), ALLOCATABLE :: seps + CHARACTER(len=:), ALLOCATABLE :: curw + CHARACTER(len=1), PARAMETER :: sq = CHAR(39) ! single quote ascii code + CHARACTER(len=1), PARAMETER :: dq = CHAR(34) ! double quotes ascii code + stat=0 ; p=1 ; indq = .false. ; insq = .false. + seps = ' ' + zmerge = .false. ; IF (PRESENT(merge)) zmerge = merge + zprotect = .true. ; IF (PRESENT(protect)) zprotect = protect + IF (PRESENT(delimiter)) THEN + IF (LEN(delimiter) > 0) seps = delimiter + ENDIF + sl = LEN(str) ; IF (sl == 0) RETURN + outer = (INDEX(str,sq) == 1 .AND. INDEX(str,sq,.true.) == LEN(str)) & + .OR.(INDEX(str,dq) == 1 .AND. INDEX(str,dq,.true.) == LEN(str)) + ! no delimiter found or (have outer quotes and should protect) + IF (SCAN(str,seps) == 0.OR.(outer.AND.zprotect)) THEN + CALL words_append(this,remove_quotes(str)) + RETURN + ENDIF + ! We have to loop... + i = 1 ; curw='' + DO + IF (i > sl) EXIT + p = SCAN(str(i:),seps) + IF (p == 0) THEN + ! a gerer + curw = curw//TRIM(str(i:)) + CALL words_append(this,TRIM(str(i:))) ; EXIT + curw='' + ELSE + IF (zprotect) THEN + j=i + ! starting state + DO WHILE(j null() + IF (idx < 1 .OR. idx > words_length(this)) THEN + RETURN + ENDIF + IF (idx > (this%nw+1)/2) THEN + pted => this%tail + DO i=1,this%nw - idx ; pted => pted%prev ; ENDDO + ELSE + pted => this%head + DO i=1,idx-1 ; pted => pted%next ; ENDDO + ENDIF + RETURN + END FUNCTION ws_get_ptr + + FUNCTION words_length(this) RESULT(res) + !! Get the size of the words object. + !! + !! The method returns the number of words stored in the given list of words. + OBJECT(words), INTENT(in) :: this !! A words object. + INTEGER :: res !! The number of words in the object. + res = this%nw + RETURN + END FUNCTION words_length + + SUBROUTINE words_insert(this, idx, value) + !! Insert a word before given index in a list of words. + !! + !! The method inserts a new word before the given index in the list of words. If the given index is out + !! of range, the method prepends/appends the object based on the index value. + OBJECT(words), INTENT(inout) :: this + !! A words object. + INTEGER, INTENT(in) :: idx + !! An integer with the index of an object in the list. The new object will be inserted before that index. + CHARACTER(len=*), INTENT(in) :: value + !! A string with the word to insert in the list. + TYPE(word), POINTER :: welt,nx,pv + INTEGER :: i + welt => null() ; nx => null() ; pv => null() + IF (this%nw == 0) THEN + CALL ini_word(this,value) + ELSE IF (idx > this%nw) THEN + this%nw = this%nw + 1 + welt => this%tail + allocate(this%tail) + ASSIGN_DTSTR(value,this%tail%value) + this%tail%prev => welt + this%tail%prev%next => this%tail + ELSE IF (idx <= 1) THEN + this%nw = this%nw + 1 + welt => this%head + allocate(this%head) + ASSIGN_DTSTR(value,this%head%value) + this%head%next => welt + this%head%next%prev => this%head + ELSE + IF (idx > (this%nw+1)/2) THEN + nx => this%tail + DO i=1, this%nw - idx ; nx => nx%prev ; ENDDO + ELSE + nx => this%head + DO i=1, idx-1 ; nx => nx%next ; ENDDO + ENDIF + pv => nx%prev + allocate(welt) + ASSIGN_DTSTR(value,welt%value) + welt%prev => pv ; welt%next => nx + pv%next => welt ; nx%prev => welt + this%nw = this%nw + 1 + ENDIF + RETURN + END SUBROUTINE words_insert + + SUBROUTINE words_append(this,value) + !! Append a word to the list of word + !! + !! The method appends a word to the list of word. This is a convinient wrapper to + !! [[strings(module)::words_insert(subroutine)] to add a new word at the beginning of the list. + OBJECT(words), INTENT(inout) :: this !! A words object + CHARACTER(len=*), INTENT(in) :: value !! A string to append + CALL words_insert(this,this%nw+1,value) + RETURN + END SUBROUTINE words_append + + SUBROUTINE words_prepend(this,value) + !! Prepend a word to the list of word + !! + !! The method prepends a word to the list of word. This is a convinient wrapper to + !! [[strings(module)::words_insert(subroutine)]] to add a new word at the end of the list. + OBJECT(words), INTENT(inout) :: this !! A words object + CHARACTER(len=*), INTENT(in) :: value !! A string to prepend + CALL words_insert(this,0,value) + RETURN + END SUBROUTINE words_prepend + + FUNCTION words_get(this,idx,case) RESULT (res) + !! Get the word's value at given index + !! + !! The method attempts to get the word's value at the given index. If index is out of range + !! an empty string is returned. + !! @note + !! The returned string is always trimmed. + OBJECT(words), INTENT(in) :: this + !! A words object reference + INTEGER, INTENT(in) :: idx + !! An integer with the index of a word in the list + CHARACTER(len=5), INTENT(in), OPTIONAL :: case + !! An optional string with either 'upper' or 'lower' to get the value converted in the relevant case + CHARACTER(len=:), ALLOCATABLE :: res + !! The value of the word stored at given index in the list of words + TYPE(word), POINTER :: cur + cur => ws_get_ptr(this,idx) + IF (.not.associated(cur)) THEN + res = '' ; RETURN + ENDIF + IF (PRESENT(case)) THEN + IF (case == "upper") res = str_to_upper(cur%value) + IF (case == "lower") res = str_to_lower(cur%value) + ELSE + res = TRIM(cur%value) + ENDIF + RETURN + END FUNCTION words_get + + SUBROUTINE words_set(this,idx,value) + !! Set a new value to a word object in the list of words at given index + !! + !! The method sets a new word at given index. If index is out of range, the method simply does nothing. + OBJECT(words), INTENT(inout) :: this !! A words object + INTEGER, INTENT(in) :: idx !! An integer with the index of the word object to modify in the list + CHARACTER(len=*), INTENT(in) :: value !! A string with the new value to set + TYPE(word), POINTER :: cur + cur => ws_get_ptr(this,idx) + IF (.NOT.ASSOCIATED(cur)) RETURN + cur%value = value + END SUBROUTINE words_set + + FUNCTION words_get_max_width(this) RESULT(res) + !! Get the longest word's width in the words object + !! + !! The method computes and returns the longest (trimmed) word's width in the words object. + OBJECT(words), INTENT(in) :: this !! A words object + INTEGER :: res !! An integer with the maximum width (0 if the list is empty) + TYPE(word), POINTER :: cur + res = 0 + IF (this%nw == 0) RETURN + cur => this%head ; res = word_length(cur) + DO WHILE(ASSOCIATED(cur%next)) + cur => cur%next + IF (word_length(cur) > res) res = word_length(cur) + ENDDO + RETURN + END FUNCTION words_get_max_width + + FUNCTION words_get_total_width(this) RESULT(width) + !! Get the total width of all words stored in the list of words + !! + !! The method computes and returns the total width of all words stored in + !! the list of words. + !! @note + !! Total width is computed using strings::word_length so it only takes + !! into account trimmed words (without trailing blanks) + !! @note + !! If csi codes have been added to words elements they are counted in the width. + OBJECT(words), INTENT(in) :: this !! A words object + INTEGER :: width !! Total length of the list of words + TYPE(word), POINTER :: cur + width = 0 + IF (this%nw == 0) RETURN + cur => this%head ; width = word_length(cur) + DO WHILE(ASSOCIATED(cur%next)) + cur => cur%next + width = width + word_length(cur) + ENDDO + cur => null() + RETURN + END FUNCTION words_get_total_width + + SUBROUTINE words_reverse(this) + !! Reverse the list of words in-place + OBJECT(words), INTENT(inout) :: this + !! A words object to reverse + TYPE(word), POINTER :: loop,iwc,iwp + IF (this%nw <= 1) RETURN + loop => this%head ; iwc=> this%head ; iwp=> null() + DO WHILE(ASSOCIATED(loop%next)) + loop => loop%next + iwp => iwc%prev ; iwc%prev => iwc%next ; iwc%next => iwp + iwc => loop + ENDDO + iwp=>this%tail%prev ; this%tail%prev=>this%tail%next ; this%tail%next=>iwp + iwc => this%head ; this%head => this%tail ; this%tail => iwc + loop => null() ; iwc => null() ; iwp => null() + RETURN + END SUBROUTINE words_reverse + + FUNCTION words_reversed(this) RESULT(res) + !! Get a reversed copy of the list of words + OBJECT(words), INTENT(in) :: this + !! A words object to reverse + TYPE(words) :: res + !! A reversed copy of the input list of words + TYPE(word),POINTER :: cur + IF(this%nw == 0) RETURN + cur => this%tail + DO WHILE(ASSOCIATED(cur)) + CALL words_append(res,cur%value) + IF (ASSOCIATED(cur,this%iter)) res%iter => res%tail + cur => cur%prev + ENDDO + cur => null() + RETURN + END FUNCTION words_reversed + + SUBROUTINE words_dump(this,lun) + !! Dump the list of words + !! + !! The method dumps on the given logical unit the elements of the list one by line. + OBJECT(words), INTENT(in) :: this + !! A words object to dump + INTEGER, INTENT(in), OPTIONAL :: lun + !! An optional integer with the printing logical unit. If not given, the list is dumped on + !! standard output stream. + TYPE(word), POINTER :: cur + INTEGER :: lu + IF (this%nw == 0) RETURN + lu=6 ; IF (PRESENT(lun)) lu = lun + cur => this%head + DO WHILE(ASSOCIATED(cur)) + WRITE(lu,'(a)') TRIM(cur%value) + cur => cur%next + ENDDO + cur => null() + RETURN + END SUBROUTINE words_dump + + FUNCTION words_to_string(this, delimiter) RESULT(str) + !! Convert the list of words into a string + !! + !! The method converts the list of words into a string. In output, string is always + !! allocated even if the list is empty. + OBJECT(words), INTENT(in) :: this + !! A words object + CHARACTER(len=*), INTENT(in), OPTIONAL :: delimiter + !! An optional string used as delimiter between each words + CHARACTER(len=:), ALLOCATABLE :: str + !! An allocatable string with the list of words joined by the given delimiter (if any) + TYPE(word), POINTER :: cur + str = '' + IF (this%nw == 0) RETURN + cur => this%head + DO WHILE(ASSOCIATED(cur)) + str=str//TRIM(cur%value) + IF (PRESENT(delimiter).AND..NOT.ASSOCIATED(cur,this%tail)) & + str=str//delimiter + cur => cur%next + ENDDO + RETURN + END FUNCTION words_to_string + + FUNCTION words_to_vector(this,ret) RESULT(ok) + !! Convert the list of words into a vector of strings + !! + !! The method attempts to convert the list of words in a vector of strings. + !! If _this_ list of words is empty the output vector is allocated with 0 elements and the method returns + !! .false.. Otherwise it returns .true. + !! @note + !! If the size of the output string vector (i.e. the character length of the string elements within the + !! vector) is too small, words can be truncated. + OBJECT(words), INTENT(in) :: this + !! A words object reference + CHARACTER(len=*), INTENT(out), ALLOCATABLE, DIMENSION(:) :: ret + !! An allocatable vector of assumed length string with the words of __this__ + LOGICAL :: ok + !! Return status. + INTEGER :: l,mw + TYPE(word), POINTER :: iw + ok = .true. + l = words_length(this) + IF (l == 0) THEN + ALLOCATE(ret(0)) + ok = .false. + RETURN + ENDIF + ALLOCATE(ret(l)) ; mw = LEN(ret(l)) + ret(1:l) = ' ' ! really needed ? + iw => this%head ; l=1 + DO WHILE(ASSOCIATED(iw)) + ret(l) = TRIM(iw%value) ; l=l+1 ; iw => iw%next + ENDDO + END FUNCTION words_to_vector + + FUNCTION words_pop(this,idx,move_forward) RESULT(value) + !! Pop a word in the list of words + !! + !! The method removes the word of the list at given index and returns it. If no index is given, + !! last word of the list is removed. + !! + !! If the index is out of range, the method does nothing and returns an empty string. + !! + !! By default, if the iterator is located on the item to be removed, it is moved backward before + !! deletion occurs. If __move\_forward__ is set to .true., the iterator is moved forward. + OBJECT(words), INTENT(inout) :: this + !! A words object + INTEGER, INTENT(in), OPTIONAL :: idx + !! Optional index of the word to delete + LOGICAL, INTENT(in), OPTIONAL :: move_forward + !! Move the iterator forward if needed. By default the iterator is moved backward. + CHARACTER(len=:), ALLOCATABLE :: value + !! The word's value at given index + LOGICAL :: zforward + INTEGER :: zidx + TYPE(word), POINTER :: cur + zidx=words_length(this) ; IF (PRESENT(idx)) zidx = idx + zforward = .false. ; IF (PRESENT(move_forward)) zforward = move_forward + cur => ws_get_ptr(this,zidx) + IF (.NOT.ASSOCIATED(cur)) THEN + value = '' ; RETURN + ELSE IF (ASSOCIATED(cur,this%iter)) THEN + IF (zforward) THEN + CALL words_next(this) + ELSE + CALL words_previous(this) + ENDIF + ENDIF + value = TRIM(cur%value) + CALL disconnect_word(cur) + DEALLOCATE(cur) + this%nw = this%nw - 1 + RETURN + END FUNCTION words_pop + + SUBROUTINE words_remove(this,idx,move_forward) + !! Remove the word of the list at given index + !! + !! The method removes the word of the list at given index. If no index is given, last word + !! of the list is removed. + !! + !! If the index is out of range, the method does nothing. + !! + !! By default, if the iterator is located on the item to be removed, it is moved backward before + !! deletion occurs. If __move\_forward__ is set to .true., the iterator is moved forward. + OBJECT(words), INTENT(inout) :: this + !! A words object + INTEGER, INTENT(in), OPTIONAL :: idx + !! Index of the word to delete + LOGICAL, INTENT(in), OPTIONAL :: move_forward + !! Move the iterator forward if needed. By default the iterator is moved backward. + LOGICAL :: zforward + INTEGER :: zidx + TYPE(word), POINTER :: cur + zidx=words_length(this) ; IF(PRESENT(idx)) zidx = idx + zforward = .false. ; IF (PRESENT(move_forward)) zforward = move_forward + cur => ws_get_ptr(this,idx) + IF (.NOT.ASSOCIATED(cur)) THEN + RETURN + ELSE IF (ASSOCIATED(cur,this%iter)) THEN + IF (zforward) THEN + CALL words_next(this) + ELSE + CALL words_previous(this) + ENDIF + ENDIF + CALL disconnect_word(cur) + DEALLOCATE(cur) + this%nw = this%nw - 1 + RETURN + END SUBROUTINE words_remove + + SUBROUTINE words_next(this) + !! Go to the next word in the list + OBJECT(words), INTENT(inout) :: this !! A words object + IF (ASSOCIATED(this%iter)) this%iter => this%iter%next + END SUBROUTINE words_next + + SUBROUTINE words_previous(this) + !! Go to the previous word in the list + OBJECT(words), INTENT(inout) :: this !! A words object + IF (ASSOCIATED(this%iter)) this%iter => this%iter%prev + END SUBROUTINE words_previous + + FUNCTION words_valid(this) RESULT(ret) + !! Check if the current iterated word is valid + OBJECT(words), INTENT(in) :: this !! A words object + LOGICAL :: ret !! A logical flag with .true. if the current iterated word is valid + ret = associated(this%iter) + END FUNCTION words_valid + + FUNCTION words_current(this) RESULT(wrd) + !! Get current word value + OBJECT(words), INTENT(in) :: this + !! A words object + CHARACTER(len=:), ALLOCATABLE :: wrd + !! A string with the value of the current word or __an unallocated string__ if current word + !! is not valid (see [[strings(module):words_valid(function)]]). + IF (ASSOCIATED(this%iter)) THEN + wrd = this%iter%value + ENDIF + END FUNCTION words_current + + SUBROUTINE words_reset(this,to_end) + !! Reset the iterator + !! + !! The method resets the iterator either at the beginning or at the end of the list of words + !! (if __to_end__ is set to .true.). + OBJECT(words), INTENT(inout) :: this !! A words object + LOGICAL, INTENT(in), OPTIONAL :: to_end !! An optional logical flag with .true. to reset the iterator at the end of the list + this%iter => this%head + IF (PRESENT(to_end)) THEN + IF (to_end) this%iter => this%tail + ENDIF + END SUBROUTINE words_reset + + ! Fancy string methods + ! -------------------- + + FUNCTION tokenize(str,vector,delimiter,merge,protect) RESULT(ok) + !! Tokenize a string. + CHARACTER(len=*), INTENT(in) :: str + !! A string to tokenize + CHARACTER(len=*), INTENT(out), DIMENSION(:), ALLOCATABLE :: vector + !! An allocatable vector of strings with the tokens found. If string cannot be tokenized, + !! the vector is __allocated to 0 elements__ and the method returns .false.. + CHARACTER(len=*), INTENT(in), OPTIONAL :: delimiter + !! An optional string with the words delimiters. It is set to blank space by default. + !! Note that each character is seen as a single delimiter. + LOGICAL, INTENT(in), OPTIONAL :: merge + !! An optional boolean control flag with .true. that instructs the method wether to + !! merge or not successive delimiters. + LOGICAL, INTENT(in), OPTIONAL :: protect + !! An optional boolean flag with .true. to indicate that delimiter characters between + !! quotes are protected. + LOGICAL :: ok + !! Return status (.true. on success) + CHARACTER(len=:), ALLOCATABLE :: seps + TYPE(words) :: tmp + LOGICAL :: zmerge,zprotect + zmerge = .false. ; zprotect = .true. ; seps = ' ' + IF (PRESENT(merge)) zmerge = merge + IF (PRESENT(protect)) zprotect = protect + IF (PRESENT(delimiter)) THEN + IF (LEN(delimiter) > 0 ) seps = delimiter + ENDIF + tmp = new_words_str(str,seps,zmerge,zprotect) + ok = words_to_vector(tmp,vector) + CALL ws_clear_sc(tmp) + RETURN + END FUNCTION tokenize + + FUNCTION remove_quotes(str) RESULT(ostr) + !! Strips outer quotes from string + !! + !! The function removes only external quotes from the input string + !! and returns the result in an allocatable string. + !! Quotes are removed only if they are the first and last non blank + !! characters. Either double and single quotes are stripped without distinction. + !! The output string is trimmed from leading and trailing blank spaces + CHARACTER(len=*), INTENT(in) :: str !! A string to check + CHARACTER(len=:), ALLOCATABLE :: ostr !! A string without external quotes (if any). + CHARACTER(len=1), PARAMETER :: sq=CHAR(39), dq=CHAR(34) + CHARACTER(len=2), PARAMETER :: dsq=CHAR(39)//CHAR(34) + INTEGER :: i, j + IF (LEN_TRIM(str) == 0) RETURN + ostr = TRIM(ADJUSTL(str)) + i = SCAN(ostr,sq//dq) ; j = SCAN(ostr,sq//dq,.true.) + IF (i == j) RETURN + IF (i /= 1) i = 0 + IF (j /= LEN(ostr)) j = LEN(ostr)+1 + ostr = ostr(i+1:j-1) + RETURN + END FUNCTION remove_quotes + + FUNCTION string_is(str) RESULT(ret) + !! Check if string represents an intrinsic type + !! + !! The method checks if the given string represents an intrinsic type. Both logical and complex type + !! are checked in a strict way : + !! + !! - A string is a logical if it is one of the following value: __.false.__, __.true.__, __F__, __T__. + !! - A string is potentially a complex if it has the following format: __(\*\*\*,\*\*\*)__ where + !! __\*\*\*__ is checked to see wether it is numerical or not. + !! + !! Valid numerical values can take the following forms: + !! ``` + !! [0-9] + !! [0-9]*.?[0-9]*?([ed][+-]?[0-9]+)? + !! ``` + !! Obviously if returned value is greater than 3, the string can be converted in + !! floating point value. + !! + !! Empty input string is simply considered to be of string type ! + CHARACTER(len=*), INTENT(in) :: str + !! A string to check + INTEGER :: ret + !! An integer with the intrinsic type related to the string. + !! + !! Types are one of the following parameters + !! + !! - [[strings(module):st_string(variable)]] (1) for string + !! - [[strings(module):st_logical(variable)]] (2) for logical + !! - [[strings(module):st_complex(variable)]] (3) for complex + !! - [[strings(module):st_integer(variable)]] (4) for integer + !! - [[strings(module):st_real(variable)]] (5) for floating point value + CHARACTER(len=:), ALLOCATABLE :: zs,zzs + INTEGER :: j,l + ret = 1 ; IF (LEN_TRIM(str) == 0) RETURN + zs = str_to_lower(TRIM(ADJUSTL(str))) ; j = INDEX(zs,',') ; l = len(zs) + IF (zs(1:1)=='('.AND.zs(l:l) == ')'.AND.j==INDEX(zs,',')) THEN + IF (j == 2 .OR. j == l-1) RETURN + zzs = TRIM(ADJUSTL(zs(2:j-1))) ; IF (what_(zzs) < 3) RETURN + zzs = TRIM(ADJUSTL(zs(j+1:l-1))) ; ret = what_(zzs) + IF (ret > 3) THEN ; ret = 3 ; ELSE ; ret = 1 ; ENDIF + ELSE + ret = what_(zs) + ENDIF + CONTAINS + FUNCTION what_(s) RESULT(is) + !! Check if the given string is numerical, logical or a simple string + !! @note + !! Input string should be in lower case, otherwise, the method will give a a wrong result. + !! @warning + !! The test performed for logical checking is quite strict : A string is considered as logical + !! if and only if it is one of the following values : __.false.__, __.true.__, __F__, __T__. + CHARACTER(len=*), INTENT(in) :: s + !! A string to check + INTEGER :: is + !! An integer with : __1__ for string, __2__ for logical, __4__ for integer and __5__ for real + LOGICAL :: dec,fdot,fexp + INTEGER :: i + CHARACTER(len=24), PARAMETER :: aset='abcfghijklmnopqrstuvwxyz' + CHARACTER(len=10), PARAMETER :: iset='1234567890' + CHARACTER(len=2), PARAMETER :: dset='ed' + CHARACTER(len=2), PARAMETER :: sset='+-' + CHARACTER(len=7), PARAMETER :: slog(4) = (/'.true. ','.false.',& + 't ','f '/) + is = -1 ; dec = .false. ; fdot = dec ; fexp = fdot + DO i = 1,LEN(s) + IF (i == 1) THEN + ! string does not start by [+-\.\d] + IF (VERIFY(s(i:i),'.'//iset//sset) /= 0) THEN + is = 1 ; EXIT + ENDIF + ! update control flag for decimal part + dec = s(i:i) == '.' ; fdot = dec + ELSE + ! check if char is in [a-z] + IF(VERIFY(s(i:i),aset) == 0) THEN + dec=.false. ; is = 1 ; EXIT + ELSE IF (s(i:i) == '.') THEN + ! check for dot in decimal/exponent part (==> not a number + IF (fdot.OR.fexp) THEN + dec = .false. ; is = 1 ; EXIT + ENDIF + ELSE IF (VERIFY(s(i:i),dset)==0) THEN + IF (fexp) THEN + dec = .false. ; is = 1 ; EXIT + ENDIF + ELSE IF (VERIFY(s(i:i),sset) == 0) THEN + IF (VERIFY(s(i-1:i-1),dset) /= 0) THEN + dec = .false. ; is = 1 ; EXIT + ENDIF + ENDIF + fdot = (fdot .OR. s(i:i) == '.') + fexp = (fexp .OR. VERIFY(s(i:i), dset) == 0) + ENDIF + ENDDO + ! it is a string + IF (is == 1) THEN + ! but have the format of a logical + IF (any(slog == s)) is = 2 + ELSE + IF ((fexp.AND.SCAN(s(LEN(s):LEN(s)),dset) /= 0)) THEN + is = 1 + ELSE + is = 4 + IF (fdot.OR.fexp) is = 5 + ENDIF + ENDIF + END FUNCTION what_ + END FUNCTION string_is + + FUNCTION format_string(str,idt1,idto) RESULT(output) + !! Format the given string + !! + !! This function only replaces all '\\n' escape sequence in the given string by NEW_LINE() character. + !! The output string is eventually indented if optional arguments are set. + !! @warning + !! __idto__ is relative to __idt1__ ! + CHARACTER(len=*), INTENT(in) :: str !! The string to format + INTEGER, INTENT(in), OPTIONAL :: idt1, & !! An optional integer with the indentation level of the first output line (default to 0) + idto !! An optional integer with the indentation level of all other output lines (default to 0) + CHARACTER(len=:), ALLOCATABLE :: output !! An allocatable string with the output formatted string. + ! - LOCAL + INTEGER :: i,c,ti,mx + CHARACTER(len=:), ALLOCATABLE :: idts + IF (LEN_TRIM(str) == 0) THEN + ALLOCATE(output,source='') ; RETURN + ENDIF + i=0 ; IF (PRESENT(idt1)) i = MAX(i,idt1) + ALLOCATE(CHARACTER(len=i) :: output) + IF (i > 0) output(1:i) = CHAR(32) + ! i0 is relative to i1 and must be >= 0 + IF (PRESENT(idto)) i = MAX(i+idto,0) + ALLOCATE(CHARACTER(len=i+1) :: idts) + idts(1:1) = NEW_LINE('A') ; IF (i>1) idts(2:) = CHAR(32) + ! Builds output string + c=1 ; mx = LEN_TRIM(str) + i = INDEX(str(c:),'\n') ; ti = c+i-1 + IF (i == 0) THEN + output=output//TRIM(str(ti+1:mx)) + ELSE + output=output//TRIM(str(c:ti-1)) ; c=ti+2 + DO + i = INDEX(str(c:),"\n") ; ti = c+i-1 + IF (i == 0) THEN + output=output//TRIM(str(ti+1:mx)) ; c = mx+1 + ELSE + output=output//idts//str(c:ti-1) ; c = ti+2 + ENDIF + IF (c > mx) EXIT + ENDDO + ENDIF + ! print a newline if we have \n at the end of the string + IF (INDEX(TRIM(str),'\n',.true.) == mx-1.AND.TRIM(str) /= '\n') & + output=output//idts(1:1) + END FUNCTION format_string + + FUNCTION format_paragraph(str,width,idt1,idto) RESULT(output) + !! Split and format a string over several lines + !! + !! The function splits an input string in words so output lines fit (almost) in __width__ characters. + !! The method handles indentation level (defined as leading blank spaces). It also accounts for known + !! csi (see [[strings(module):attributes(variable)]]. + !! @note + !! Words are considered indivisible and thus output lines can sometimes exceed the maximum width if + !! there is not enough space to put a word (with the associated indentation if given). The default + !! behavior in that case is to print the word in a new line (with the correct leading blank spaces). + !! @warning + !! If __width__, __idt1__ and/or __idto__ have inconsistent values (e.g. __width__ <= __idt1__), the + !! method still computes the paragraph, but each words will be set on a new line with the appropriate + !! indentation. + CHARACTER(len=*), INTENT(in) :: str !! string with the content to split + INTEGER, INTENT(in) :: width !! An positive integer with the maximum width of a line + INTEGER, INTENT(in), OPTIONAL :: idt1 !! An optional integer with the indentation level of the first output line + INTEGER, INTENT(in), OPTIONAL :: idto !! An optional integer with the indentation level of the other output lines + CHARACTER(len=:), ALLOCATABLE :: output !! An allocatable string with the output content + CHARACTER(len=:), ALLOCATABLE :: idts,zs + INTEGER :: l1,lo,zmx,zw,cc,j,jj,l + zw = abs(width) ; zs = strip_newline(str) + zmx = LEN_TRIM(zs) + IF (zmx == 0) THEN + ALLOCATE(output,source='') ; RETURN + ENDIF + l1=0 ; IF (PRESENT(idt1)) l1 = MAX(l1,idt1) + ALLOCATE(CHARACTER(len=l1) :: output) + IF (l1 > 0) output(1:l1) = CHAR(32) + lo=l1 ; IF (PRESENT(idto)) lo = MAX(l1+idto,0) + ALLOCATE(CHARACTER(len=lo+1) :: idts) + idts(1:1) = NEW_LINE('A') ; IF (lo>=1) idts(2:len(idts)) = CHAR(32) + ! Prints a message if user is just stupid... + IF (lo+1 > zw .OR. l1+1 > zw) THEN + output = str ; RETURN + ENDIF + ! check if can just return the string as is + IF (zmx + l1 <= zw) THEN + output=output//TRIM(zs) ; RETURN + ENDIF + j=1 ; jj=1+l1 + DO + ! Gets next blank in input string + cc = INDEX(TRIM(zs(j:)),CHAR(32)) + ! no more blank + ! Gets total length of csi between zs(j:j+cc-1) + ! this value will be substracted to each length test + IF (cc == 0) THEN + l = csis_length(zs(j:)) + IF (jj-1+LEN_TRIM(zs(j:))-l > zw) THEN + output = output//idts + ENDIF + output=output//TRIM(zs(j:)) + EXIT ! we are at the last word : we must exit the infinite loop ! + ELSE + l = csis_length(zs(j:j+cc-1)) + IF (cc+jj-1-l > zw) THEN + output=output//idts//zs(j:j+cc-1) ; jj = lo+1+cc+1 - l + ELSE + output=output//zs(j:j+cc-1) ; jj = jj + cc - l + ENDIF + ENDIF + j = j + cc + ENDDO + CONTAINS + FUNCTION csis_length(str) RESULT(value) + ! - DUMMY + CHARACTER(len=*), INTENT(in) :: str + ! - RESULT + INTEGER :: value + ! - LOCAL + INTEGER :: jc,iesc,im + LOGICAL :: tcsi + value = 0 + jc=1 + DO + IF (jc>LEN(str)) EXIT + ! search for escape + iesc = INDEX(str(jc:),CHAR(27)) + IF (iesc == 0) EXIT + ! search for m + im = INDEX(str(jc+iesc:),"m") + ! no m in the string after ESC --> this could not be a csi + IF (im == 0) EXIT + ! check if this is really a csi and updates length + tcsi = is_csi(str(jc+iesc-1:jc+iesc+im-1)) + jc = jc + iesc + IF (tcsi) THEN + value=value+im+1 + jc=jc+im + ENDIF + ENDDO + END FUNCTION csis_length + END FUNCTION format_paragraph + + FUNCTION strip_newline(str,rpl) RESULT(stripped) + !! Replace newline escape sequences by spaces + !! + !! The function replaces newline (both '\\n' escape sequence and Fortran NEW_LINE() character) in the + !! given string and returns the resulting string. + CHARACTER(len=*), INTENT(in) :: str !! A string to process + CHARACTER(len=1), INTENT(in), OPTIONAL :: rpl !! A optional single character used as substitution of escape sequences (blank space by default) + CHARACTER(len=:), ALLOCATABLE :: stripped !! An allocatable string with all newline sequences replaced by blank space or __rpl__ if given + CHARACTER(len=1) :: zrp + INTEGER :: i, j, ns + zrp = CHAR(32) ; IF(PRESENT(rpl)) zrp = rpl + IF (str == NEW_LINE('A')) THEN + stripped = zrp ; RETURN + ENDIF + ns = LEN_TRIM(str) + IF (ns == 0) THEN + ALLOCATE(stripped,source='') ; RETURN + ENDIF + ALLOCATE(CHARACTER(len=ns) :: stripped) ; stripped(1:ns) = CHAR(32) + i=1 ; j=1 + DO + IF (str(i:i) == NEW_LINE('A')) THEN + stripped(j:j) = zrp + ELSE IF (i < ns) THEN + IF (str(i:i+1) == "\n") THEN + stripped(j:j) = zrp ; i=i+1 + ELSE + stripped(j:j) = str(i:i) + ENDIF + ELSE + stripped(j:j) = str(i:i) + ENDIF + j=j+1 ; i=i+1 + IF (i > ns .OR. j > ns) EXIT + ENDDO + IF (j < ns) stripped = stripped(1:j) + RETURN + END FUNCTION strip_newline + + FUNCTION str_length(str) RESULT(res) + !! Get the length of the string object + !! + !! The method computes the length of the string. It differs from LEN intrinsic function as + !! it does not account for extra-characters of csi codes. + CHARACTER(len=*), INTENT(in) :: str !! String to process + INTEGER :: res !! The actual length of string (i.e. does not account for csi codes) + CHARACTER(len=:), ALLOCATABLE :: tmp + res = 0 + IF (LEN(str) /= 0) THEN + tmp = str_reset_attributes(str) + res = LEN(tmp) + DEALLOCATE(tmp) + ENDIF + RETURN + END FUNCTION str_length + + FUNCTION str_to_lower(str1) RESULT(str) + !! Convert the string in lower case + !! + !! The method converts the input string in lower case and accounts for + !! possible csi codes in the string. + CHARACTER(len=*), INTENT(in) :: str1 !! Input string to convert + CHARACTER(len=:), ALLOCATABLE :: str !! A copy of the string in lower case + INTEGER :: i,ic + IF (LEN(str1) /= 0) THEN + str = str1 + DO i = 1, len(str1) + ic = ichar(str1(i:i)) + IF (ic >= 65 .AND. ic < 90) str(i:i) = char(ic + 32) + ENDDO + ELSE + str='' + ENDIF + END FUNCTION str_to_lower + + FUNCTION str_to_upper(str1) RESULT(str) + !! Convert the string in upper case + !! + !! The method converts the input string in upper case and accounts for + !! possible csi codes in the string. + CHARACTER(len=*), INTENT(in) :: str1 !! Input string to convert + CHARACTER(len=:), ALLOCATABLE :: str !! A copy of the string in upper case + INTEGER :: j,i,ic,icsi,lcsi + IF (LEN(str1) > 0) THEN + str = str1 + i = 1 + DO + IF (i > LEN(str)) EXIT + icsi = str_index_of_csi(str(i:),lcsi) + IF (icsi == 0) THEN + ! no more csi the end of string is upper case converted + DO j=i,LEN(str) + ic = ichar(str(j:j)) + IF (ic >= 97 .AND. ic < 122) str(j:j) = char(ic-32) + ENDDO + RETURN + ELSE IF (icsi == 1) THEN + i = i + lcsi + ELSE IF (icsi > 1) THEN + ! csi is not the first word: we convert in upper case until its + ! position THEN copy the csi and get back in the loop + DO j=i,i+icsi-2 + ic = ichar(str(j:j)) + IF (ic >= 97 .AND. ic < 122) str(j:j) = char(ic-32) + ENDDO + i = i + icsi + lcsi-1 + ENDIF + ENDDO + ELSE + str='' + ENDIF + END FUNCTION str_to_upper + + FUNCTION str_remove(string,substring,back,all) RESULT(str) + !! Remove substring from current string + !! + !! The function removes the first occurence of __substring__ in __string__ or all + !! its occurences if __all__ is explicitly set to .true.. + CHARACTER(len=*), INTENT(in) :: string !! A string to search in + CHARACTER(len=*), INTENT(in) :: substring !! A string to search and removes from __string__ + LOGICAL, INTENT(in), OPTIONAL :: back, & !! An optional boolean flag with .true. to begin search at the end of the string + all !! An optional boolean flag with .true. to remove all occurences of __substring__ + CHARACTER(len=:), ALLOCATABLE :: str !! An allocatable string with __substring__ occurence(s) removed + LOGICAL :: zb,za + INTEGER :: is,j,zboff + str='' + zb = .false. ; za = .false. + IF (PRESENT(back)) zb = back + IF (PRESENT(all)) za = all + IF (za) zb=.false. + zboff = 0 ; IF (zb) zboff = 1 + IF (LEN(string) == 0) RETURN + j=1 + DO + IF (j>LEN(string)) EXIT + ! search for substring + is = INDEX(string(j:),substring,back=zb) + IF (is == 0) THEN + ! substring is not found : we get the last part of the string and return + str = str//string(j:) ; RETURN + ELSE IF (is == 1) THEN + j = j + LEN(substring) + ELSE + ! substring is not at the begin of the string : saves the string + str = str//string(j:j+is-2) + j = j + is+LEN(substring)-1 + ENDIF + ! if we only want to str_remove ONE occurence we exit if substring + ! has been found + IF (.NOT.(is==0.OR.za)) EXIT + ENDDO + IF (j <= LEN(string).AND..NOT.zb) str=str//string(j:) + RETURN + END FUNCTION str_remove + + FUNCTION str_replace(string,old,new,back,all) RESULT(str) + !! Replace substring from current string + !! + !! The function replaces the first occurence of __old__ in __string__ by + !! __new__ or all its occurence(s) if __all__ is explicitly set to .true.. + CHARACTER(len=*), INTENT(in) :: string !! A string to search in + CHARACTER(len=*), INTENT(in) :: old, & !! A string to search and replace + new !! A string to substitute to __old__ + LOGICAL, INTENT(in), OPTIONAL :: back, & !! An optional boolean flag with .true. to begin search at the end of the string + all !! An optional boolean flag with .true. to replace all occurences of __old__ + CHARACTER(len=:), ALLOCATABLE :: str !! An allocatable string with occurence(s) of __old__ replaced by __new__ + LOGICAL :: zb,za + INTEGER :: is,j + str='' + zb = .false. ; za = .false. + IF (PRESENT(back)) zb = back + IF (PRESENT(all)) za = all + IF (za) zb = .NOT.za + IF (LEN(string) == 0) RETURN + j=1 + DO + IF (j>LEN(string)) EXIT + ! search for "old" + is = INDEX(string(j:),old,back=zb) + IF (is == 0) THEN + ! "old" is not found : we get the last part of the string and return + str = str//string(j:) ; RETURN + ELSE IF (is == 1) THEN + str = str//new + j = j + LEN(old) + ELSE + ! "old" is not at the begin of the string : saves the string + str = str//string(j:j+is-2)//new + j = j + is + LEN(old) - 1 + ENDIF + IF (.NOT.(is==0.OR.za)) EXIT + ENDDO + IF (j <= LEN(str)) str=str//string(j:) + RETURN + END FUNCTION str_replace + + FUNCTION str_endswith(string,substring,icase) RESULT(ret) + !! Check if string ends by substring + CHARACTER(len=*), INTENT(in) :: string + !! @param[in] string A string to check + CHARACTER(len=*), INTENT(in) :: substring + !! A string to search in __string__ + LOGICAL, INTENT(in), OPTIONAL :: icase + !! An optional boolean flag with .true. to perform insensitive case search + LOGICAL :: ret + !! .true. if __string__ ends by __substring__, .false. otherwise. + CHARACTER(len=:), ALLOCATABLE :: zthis,zstr + INTEGER :: idx + LOGICAL :: noc + ret = .false. + noc = .false. ; IF (PRESENT(icase)) noc = icase + IF (LEN(string) == 0 .OR. LEN(substring) == 0) RETURN + zthis = str_reset_attributes(string) ; zstr=str_reset_attributes(substring) + IF (noc) THEN + idx = INDEX(str_to_lower(zthis),str_to_lower(zstr),.true.) + ELSE + idx = INDEX(zthis,zstr,.true.) + ENDIF + IF (idx == 0.OR.idx+str_length(zstr)-1 /= str_length(zthis)) RETURN + ret=.true. + END FUNCTION str_endswith + + FUNCTION str_startswith(string,substring,icase) RESULT(ret) + !! Check if string starts by substring + CHARACTER(len=*), INTENT(in) :: string + !! A string to check + CHARACTER(len=*), INTENT(in) :: substring + !! A string to search in __string__ + LOGICAL, INTENT(in), OPTIONAL :: icase + !! An optional boolean flag with .true. to perform insensitive case search + LOGICAL :: ret + !! .true. if __string__ starts by __substring__, .false. otherwise. + CHARACTER(len=:), ALLOCATABLE :: zthis,zstr + INTEGER :: idx + LOGICAL :: noc + ret = .false. + noc = .false. ; IF (PRESENT(icase)) noc = icase + IF (LEN(string) == 0 .OR. LEN(substring) == 0) RETURN + zthis = str_reset_attributes(string) ; zstr=str_reset_attributes(substring) + IF (noc) THEN + idx = INDEX(str_to_lower(zthis),str_to_lower(zstr)) + ELSE + idx = INDEX(zthis,zstr) + ENDIF + IF (idx /= 1) RETURN + ret=.true. + END FUNCTION str_startswith + + ! CSI related functions + ! --------------------- + + FUNCTION str_add_attributes(string,attrs) RESULT(str) + !! Set csi attributes to the given string object + !! + !! The function adds csi (ANSI escape sequences) to the given string and + !! returns a copy of it. + CHARACTER(len=*), INTENT(in) :: string + !! @param[in] string A string object reference + INTEGER, INTENT(in), DIMENSION(:) :: attrs + !! A vector of integers with the code to add. Each __attrs__ value should refers to one i + !! of [[strings(module):attributes(variable)]] values. + CHARACTER(len=:), ALLOCATABLE :: str + !! An allocatable string with new csi codes added. + INTEGER :: j,iesc,im + CHARACTER(len=:), ALLOCATABLE :: tmp,csi + CHARACTER(len=4), PARAMETER :: rcsi = CHAR(27)//"[0m" + str='' + ! 1) Check for input string + IF (LEN(string) == 0) RETURN + ! 2) Removes last [0m if any and initializes output string + ! we must remove only the last [0m if any + IF (INDEX(string,rcsi,.true.) == LEN(string)-3) THEN + tmp = str_remove(string,rcsi,back=.true.) + ELSE + tmp = string + ENDIF + ! 3) Add all the given csi preceded by [0m at the beginning of the string + ! if it does not start by an ANSI sequence + IF (INDEX(tmp,CHAR(27)//"[") /= 1) & + tmp = str_add_to_csi(rcsi,attrs)//tmp + ! Loops on new string and updates csi codes + j=1 + DO + IF (j>LEN(tmp)) EXIT + ! search for escape + iesc = INDEX(tmp(j:),CHAR(27)) + IF (iesc == 0) THEN + ! no more ESC : cat until end of input string and exit + str = str//tmp(j:) ; EXIT + ELSE IF (iesc > 1) THEN + ! ESC is not first char: copy until ESC + str = str//tmp(j:j+iesc-2) + ENDIF + ! search for m + im = INDEX(tmp(j+iesc:),"m") + ! no m in the string after ESC --> copy string (INCLUDING ESC) and leave + IF (im == 0) THEN + str = str//tmp(j+iesc-1:) + RETURN + ENDIF + csi = tmp(j+iesc-1:j+iesc+im-1) + ! we have a csi: we add new codes to it + IF (is_csi(csi)) THEN + csi = str_add_to_csi(csi,attrs) + ENDIF + str = str//csi + j = j + iesc + im + ENDDO + IF (INDEX(str,rcsi,.true.) /= LEN(str)-3) str = str//rcsi + RETURN + END FUNCTION str_add_attributes + + FUNCTION str_delete_attributes(string,attrs) RESULT(str) + !! Remove attributes to the given string + !! + !! The function removes list of csi (ANSI escape sequences) from the given + !! string and returns a copy of it. + !! @note + !! This method does not update @lerror. + CHARACTER(len=*), INTENT(in) :: string + !! Input string + INTEGER, INTENT(in), DIMENSION(:) :: attrs + !! A vector of integers with the code to remove. Each __attrs__ value should + !! refers to one of [[strings(module):attributes(variable)]] values. + CHARACTER(len=:), ALLOCATABLE :: str + !! An allocatable string with csi codes from __list__ removed + LOGICAL :: ok + INTEGER :: j,iesc,im + CHARACTER(len=:), ALLOCATABLE :: tmp,csi,csis + CHARACTER(len=st_slen), DIMENSION(:), ALLOCATABLE :: tks + CHARACTER(len=4), PARAMETER :: rcsi = CHAR(27)//"[0m" + str='' + IF (LEN(string) == 0) RETURN + ! remove last [0m if found at the end of the string + IF (INDEX(string,rcsi,.true.) == LEN(string)-3) THEN + tmp = str_remove(string,rcsi,back=.true.) + ELSE + tmp = string + ENDIF + ! Loops on new string and updates csi codes + j=1 ; csis="" + DO + IF (j>LEN(tmp)) EXIT + ! search for escape + iesc = INDEX(tmp(j:),CHAR(27)) + IF (iesc == 0) THEN + ! no more ESC : cat until end of input string and exit + str = str//tmp(j:) ; EXIT + ELSE IF (iesc > 1) THEN + ! ESC is not first char: copy until ESC + str = str//tmp(j:j+iesc-2) + ENDIF + ! search for m + im = INDEX(tmp(j+iesc:),"m") + ! no m in the string after ESC --> copy string (INCLUDING ESC) and leave + IF (im == 0) THEN + str = str//tmp(j+iesc-1:) + RETURN + ENDIF + csi = tmp(j+iesc-1:j+iesc+im-1) + ! we have a csi: we add new codes to it + IF (is_csi(csi)) THEN + csi = str_del_from_csi(csi,attrs) + ENDIF + csis=csis//csi//"|" + str = str//csi + j = j + iesc + im + ENDDO + ! Add [0m at the end of string if not found + IF (INDEX(str,rcsi,.true.) /= LEN(str)-3) str = str//rcsi + ! resets all attributes if we only have [0m in final list + ok = tokenize(csis(1:LEN(csis)-1),tks,"|") + IF (ALL(tks == rcsi)) str = str_reset_attributes(str) + DEALLOCATE(tks) + RETURN + END FUNCTION str_delete_attributes + + FUNCTION str_reset_attributes(string) RESULT(str) + !! Reset all csi codes of the string + !! + !! The method removes __all__ the known escape sequences from the input string. + CHARACTER(len=*), INTENT(in) :: string + !! Input string + CHARACTER(len=:), ALLOCATABLE :: str + !! An allocatable string with the copy of input string stripped off csi codes. + INTEGER :: j,iesc,im + LOGICAL :: tcsi + str = "" + IF (LEN(string) == 0) RETURN + j=1 + DO + IF (j>LEN(string)) EXIT + ! search for escape + iesc = INDEX(string(j:),CHAR(27)) + IF (iesc == 0) THEN + str = str//string(j:) ; EXIT + ENDIF + ! search for m + im = INDEX(string(j+iesc:),"m") + ! no m in the string after ESC --> copy string (INCLUDING ESC) and leave + IF (im == 0) THEN + str = str//string(j+iesc-1:) + RETURN + ENDIF + ! csi includes everything between ESC and m (excluding them): + ! to check for csi it should begin by [ and then be a list of integers + ! separated by ; + tcsi = is_csi(string(j+iesc-1:j+iesc+im-1)) + IF (iesc > 1) THEN + str = str//string(j:j+iesc-2) + ENDIF + j = j + iesc ; IF (tcsi) j=j+im + ENDDO + RETURN + END FUNCTION str_reset_attributes + + + FUNCTION is_csi(value) RESULT(yes) + !! Check if string is a known csi + !! + !! The function only check for known csi code which are defined in [[strings(module):attributes(variable)]]. + CHARACTER(len=*), INTENT(in) :: value + !! A Fortran intrinsic string to check + LOGICAL :: yes + !! .true. if it is a known csi, .false. otherwise + LOGICAL :: ok + CHARACTER(len=:), ALLOCATABLE :: tmp + TYPE(words) :: wtks + CHARACTER(len=st_slen), DIMENSION(:), ALLOCATABLE :: stks + INTEGER, DIMENSION(:), ALLOCATABLE :: nums + INTEGER :: i + yes = .false. + IF (LEN(value) < 4) RETURN + tmp = value(3:len(value)-1) + wtks = new_words(tmp,";") + ok = words_to_vector(wtks,stks) + CALL ws_clear_sc(wtks) + IF (.NOT.ok) RETURN + ! if we cannot convert strings to integers : it is not a csi + IF (.NOT.from_string(stks,nums)) RETURN + DEALLOCATE(stks) + DO i=1, SIZE(nums) + IF (.NOT.ANY(attributes == nums(i))) RETURN + ENDDO + yes = .true. + END FUNCTION is_csi + + FUNCTION str_add_to_csi(csi,list) RESULT(ncsi) + !! Add a new list of codes to the input csi string + !! + !! The method adds all the csi codes given in __list__ that are known by the module and not + !! already present in the input csi. + CHARACTER(len=*), INTENT(in) :: csi + !! A string with the input csi. It __must__ begin with "[" and ends with "m". + INTEGER, INTENT(in), DIMENSION(:) :: list + !! A vector of integers with the csi code to add. Each value of __list__ should be one of + !! [[strings(module):attributes(variable)]] values. All unknwon values are filtered out as well + !! as csi code already present in input __csi__. + CHARACTER(len=:), ALLOCATABLE :: ncsi + !! A new csi string or the input __csi__ if some "errors" occured (the input csi could not + !! be tokenized or none of __list__ values are left after filtering). + LOGICAL :: ok + CHARACTER(len=LEN(csi)), DIMENSION(:), ALLOCATABLE :: tks + CHARACTER(len=:), ALLOCATABLE :: tmp + INTEGER, DIMENSION(:), ALLOCATABLE :: zlist,nums + INTEGER :: i,j,ni,no + ! 1) Filter input list : + ! 1.1) Gets the list of current csi codes + ncsi = csi(3:len(csi)-1) + ok = tokenize(ncsi,tks,"; ",merge=.true.) + IF (.NOT.from_string(tks,nums)) THEN + ncsi = csi + RETURN + ENDIF + DEALLOCATE(tks) + ! 1.2) Filter input list of new flags to add + ! counts number of valid flags + j=0 + DO i=1,SIZE(list) + ! new flags must be in attributes but NOT in nums + IF (ANY(attributes==list(i).AND..NOT.ANY(nums == list(i)))) j=j+1 + ENDDO + ! No "valid" flags -> returns old csi + IF (j == 0) THEN ; ncsi = csi ; RETURN ; ENDIF + ni = SIZE(nums) ; no = j + ni + ALLOCATE(zlist(no)) ; zlist(1:ni) = nums(:) ; j = ni + DO i=1,SIZE(list) + ! new flags must be in attributes but NOT in nums + IF (ANY(attributes==list(i).AND..NOT.ANY(nums == list(i)))) THEN + j=j+1 ; zlist(j) = list(i) + ENDIF + ENDDO + DEALLOCATE(nums) + ! 2) Builds new csi + ! Here we explictly set the first flag to 0 (i.e. reset attributes)... + ncsi = CHAR(27)//"[0;" + DO i=1,no + ! ... So we get rid of all "0" flag in the list + IF (zlist(i) /= 0) THEN + tmp = to_string(zlist(i)) + IF (LEN_TRIM(tmp) == 0) THEN + ncsi = csi ; RETURN + ENDIF + ncsi = ncsi//tmp + IF (i /= no) ncsi = ncsi//";" + ENDIF + ENDDO + ncsi = ncsi//"m" + END FUNCTION str_add_to_csi + + FUNCTION str_del_from_csi(csi,list) RESULT(ncsi) + !! Remove a list of codes from the input csi string + !! + !! The method removes all the csi codes given in __list__ that are known by the + !! module and already present in the input csi. + CHARACTER(len=*), INTENT(in) :: csi + !! An intrinsic Fortran string with the input csi. It __must__ begin with "[" and ends with "m". + INTEGER, INTENT(in), DIMENSION(:) :: list + !! A vector of integers with the csi code to remove. Each value of __list__ should be one of + !! [[strings(module):attributes(variable)]] values. All unknwon values are filtered out. + CHARACTER(len=:), ALLOCATABLE :: ncsi + !! A new csi string or the input __csi__ if some "errors" occured (the input csi could not + !! be tokenized or none of __list__ values are left after filtering). + LOGICAL :: ok + CHARACTER(len=LEN(csi)), DIMENSION(:), ALLOCATABLE :: tks + CHARACTER(len=:), ALLOCATABLE :: tmp + INTEGER, DIMENSION(:), ALLOCATABLE :: nums + INTEGER :: i + ncsi = csi(3:len(csi)-1) + ok = tokenize(ncsi,tks,"; ",merge=.true.) + IF (.NOT.from_string(tks,nums)) THEN + ncsi = csi + RETURN + ENDIF + DEALLOCATE(tks) + tmp="" + DO i=1, SIZE(nums) + IF (ALL(nums(i) /= list).AND.nums(i) /= 0) THEN + ! no need to check for to_string status : it is always ok ! + tmp=tmp//to_string(nums(i))//";" + ENDIF + ENDDO + IF (LEN_TRIM(tmp) /= 0) THEN + ncsi=CHAR(27)//"[0;"//tmp(1:LEN(tmp)-1)//"m" + ELSE + ncsi=CHAR(27)//"[0m" + ENDIF + END FUNCTION str_del_from_csi + + FUNCTION str_index_of_csi(str,length) RESULT(pos) + !! Get the position of the first known csi in string + !! + !! The method searches for the first known csi in string. The csi must contain known codes + !! (i.e. values of [[strings(module):attributes(variable)]]). + CHARACTER(len=*), INTENT(in) :: str !! A string to search in + INTEGER, INTENT(out) :: length !! Length of the csi in the string + INTEGER :: pos !! Position of the first csi found. It is set to 0 if no csi has been found. + INTEGER :: iesc,im + pos = 0 ; length = 0 + ! we need at least 4 chars to create a csi + IF (LEN_TRIM(str) < 4) RETURN + iesc = INDEX(str,CHAR(27)) + IF (iesc == 0) RETURN + ! search for m + im = INDEX(str(iesc:),"m") + ! no m in the string after ESC --> copy string (INCLUDING ESC) and leave + IF (im == 0) RETURN + IF (.NOT.is_csi(str(iesc:iesc+im-1))) RETURN + pos = iesc ; length = im + END FUNCTION str_index_of_csi + + ! String conversion functions + ! --------------------------- + + FUNCTION str2int_sc(str, value) RESULT(ret) + !! Convert string value to integer value (scalar) + CHARACTER(len=*), INTENT(in) :: str !! String to convert + INTEGER, INTENT(out) :: value !! Output value + LOGICAL :: ret !! Return status (.true. on success) + CHARACTER(len=:), ALLOCATABLE :: zs + ret = .true. ; zs = remove_quotes(str) + IF (string_is(zs) /= st_integer) THEN + ret = .false. + ELSE + READ(zs, *) value + ENDIF + RETURN + END FUNCTION str2int_sc + + FUNCTION str2log_sc(str, value) RESULT(ret) + !! Convert string value to logical value (scalar) + CHARACTER(len=*), INTENT(in) :: str !! String to convert + LOGICAL, INTENT(out) :: value !! Output value + LOGICAL :: ret !! Return status (.true. on success) + CHARACTER(len=:), ALLOCATABLE :: zs + integer :: r + ret = .true. ; zs = remove_quotes(str) + r = string_is(zs) + IF (string_is(zs) /= st_logical) THEN + ret = .false. + ELSE + READ(zs, *) value + ENDIF + RETURN + END FUNCTION str2log_sc + + FUNCTION str2real_sc(str, value) RESULT(ret) + !! Convert string value to simple precision floating precision value (scalar) + CHARACTER(len=*), INTENT(in) :: str !! String to convert + REAL(kind=4), INTENT(out) :: value !! Output value + LOGICAL :: ret !! Return status (.true. on success) + CHARACTER(len=:), ALLOCATABLE :: zs + ret = .true.; zs = remove_quotes(str) + IF (string_is(zs) < st_integer) THEN + ret = .false. + ELSE + READ(zs, *) value + ENDIF + RETURN + END FUNCTION str2real_sc + + FUNCTION str2dble_sc(str, value) RESULT(ret) + !! Convert string value to double precision floating precision value (scalar) + CHARACTER(len=*), INTENT(in) :: str !! String to convert + REAL(kind=8), INTENT(out) :: value !! Output value + LOGICAL :: ret !! Return status (.true. on success) + CHARACTER(len=:), ALLOCATABLE :: zs + ret = .true. ; zs = remove_quotes(str) + IF (string_is(zs) < st_integer) THEN + ret = .false. + ELSE + READ(zs, *) value + ENDIF + RETURN + END FUNCTION str2dble_sc + + FUNCTION str2cplx_sc(str, value) RESULT(ret) + !! Convert string value to complex value (scalar) + CHARACTER(len=*), INTENT(in) :: str !! String to convert + COMPLEX(kind=4), INTENT(out) :: value !! Output value + LOGICAL :: ret !! Return status (.true. on success) + ! - LOCAL + CHARACTER(len=:), ALLOCATABLE :: zs + ret = .true. ; zs = remove_quotes(str) + IF (string_is(zs) /= st_complex) THEN + ret = .false. + ELSE + READ(zs, *) value + ENDIF + RETURN + END FUNCTION str2cplx_sc + + FUNCTION str2int_ve(str, value) RESULT(ret) + !! Convert strings values to integer values (vector) + CHARACTER(len=*), INTENT(in), DIMENSION(:) :: str !! Vector of strings to convert + INTEGER, INTENT(out), DIMENSION(:), ALLOCATABLE :: value !! Vector of output values + LOGICAL :: ret !! Return status (.true. on success) + INTEGER :: i,ns + CHARACTER(len=:), ALLOCATABLE :: zs + ret = .true. ; ns = SIZE(str) ; ALLOCATE(value(ns)) + DO i=1,ns + zs = remove_quotes(str(i)) + IF (string_is(zs) /= st_integer) THEN + ret = .false. ; DEALLOCATE(value) ; RETURN + ELSE + READ(zs, *) value(i) + ENDIF + ENDDO + RETURN + END FUNCTION str2int_ve + + FUNCTION str2log_ve(str, value) RESULT(ret) + !! Convert strings values to logical values (vector) + CHARACTER(len=*), INTENT(in), DIMENSION(:) :: str !! Vector of strings to convert + LOGICAL, INTENT(out), DIMENSION(:), ALLOCATABLE :: value !! Vector of output values + LOGICAL :: ret !! Return status (.true. on success) + INTEGER :: i,ns + CHARACTER(len=:), ALLOCATABLE :: zs + ret = .true. ; ns = SIZE(str) ; ALLOCATE(value(ns)) + DO i=1,ns + zs = remove_quotes(str(i)) + IF (string_is(zs) /= st_logical) THEN + ret = .false. ; DEALLOCATE(value) ; RETURN + ELSE + READ(zs, *) value(i) + ENDIF + ENDDO + RETURN + END FUNCTION str2log_ve + + FUNCTION str2real_ve(str, value) RESULT(ret) + !! Convert strings values to simple precision floating point values (vector) + CHARACTER(len=*), INTENT(in), DIMENSION(:) :: str !! Vector of strings to convert + REAL(kind=4), INTENT(out), DIMENSION(:), ALLOCATABLE :: value !! Vector of output values + LOGICAL :: ret !! Return status (.true. on success) + INTEGER :: i,ns + CHARACTER(len=:), ALLOCATABLE :: zs + ret = .true. ; ns = SIZE(str) ; ALLOCATE(value(ns)) + DO i=1,ns + IF (string_is(zs) < st_integer) THEN + ret = .false. ; DEALLOCATE(value) ; RETURN + ELSE + READ(zs, *) value(i) + ENDIF + ENDDO + RETURN + END FUNCTION str2real_ve + + FUNCTION str2dble_ve(str, value) RESULT(ret) + !! Convert strings values to double precision floating point values (vector) + CHARACTER(len=*), INTENT(in), DIMENSION(:) :: str !! Vector of strings to convert + REAL(kind=8), INTENT(out), DIMENSION(:), ALLOCATABLE :: value !! Vector of output values + LOGICAL :: ret !! Return status (.true. on success) + INTEGER :: i,ns + CHARACTER(len=:), ALLOCATABLE :: zs + ret = .true. ; ns = SIZE(str) ; ALLOCATE(value(ns)) + DO i=1,ns + zs = remove_quotes(str(i)) + IF (string_is(zs) < st_integer) THEN + ret = .false. ; DEALLOCATE(value) ; RETURN + ELSE + READ(zs, *) value(i) + ENDIF + ENDDO + RETURN + END FUNCTION str2dble_ve + + FUNCTION str2cplx_ve(str, value) RESULT(ret) + !! Convert strings values to complex values (vector) + CHARACTER(len=*), INTENT(in), DIMENSION(:) :: str !! Vector of strings to convert + COMPLEX(kind=4), INTENT(out), DIMENSION(:), ALLOCATABLE :: value !! Vector of output values + LOGICAL :: ret !! Return status (.true. on success) + INTEGER :: i,ns + CHARACTER(len=:), ALLOCATABLE :: zs + ret = .true. ; ns = SIZE(str) ; ALLOCATE(value(ns)) + DO i=1,ns + zs = remove_quotes(str(i)) + IF (string_is(zs) /= st_complex) THEN + ret = .false. ; DEALLOCATE(value) ; RETURN + ELSE + READ(zs, *) value(i) + ENDIF + ENDDO + RETURN + END FUNCTION str2cplx_ve + + FUNCTION int2str_as(value) RESULT(str) + !! Convert an integer value to string (auto format / string result) + INTEGER, INTENT(in) :: value !! Value to convert + CHARACTER(len=:), ALLOCATABLE :: str !! String with the converted value in output + INTEGER :: err + ALLOCATE(CHARACTER(len=DIGITS(value)) :: str) + WRITE(str,*,iostat=err) value + str = TRIM(ADJUSTL(str)) + IF (err /= 0) str = '' + RETURN + END FUNCTION int2str_as + + FUNCTION log2str_as(value) RESULT(str) + !! Convert a logical value to string (auto format / string result) + LOGICAL, INTENT(in) :: value !! Value to convert + CHARACTER(len=:), ALLOCATABLE :: str !! String with the converted value in output + INTEGER :: err + ALLOCATE(CHARACTER(len=2) :: str) + WRITE(str, *, IOSTAT = err) value + str=TRIM(ADJUSTL(str)) + IF (err /= 0) str = '' + RETURN + END FUNCTION log2str_as + + FUNCTION real2str_as(value) RESULT(str) + !! Convert a simple precision floating point value to string (auto format / string result) + REAL(kind=4), INTENT(in) :: value !! Value to convert + CHARACTER(len=:), ALLOCATABLE :: str !! String with the converted value in output + INTEGER :: err + ALLOCATE(CHARACTER(len=DIGITS(value)) ::str) + WRITE(str,*, IOSTAT = err) value + str=TRIM(ADJUSTL(str)) + IF (err /= 0) str = '' + RETURN + END FUNCTION real2str_as + + FUNCTION dble2str_as(value) RESULT(str) + !! Convert a double precision floating point value to string (auto format / string result) + REAL(kind=8), INTENT(in) :: value !! Value to convert + CHARACTER(len=:), ALLOCATABLE :: str !! String with the converted value in output + INTEGER :: err + ALLOCATE(CHARACTER(len=DIGITS(value)) ::str) + WRITE(str,*, IOSTAT = err) value + str=TRIM(ADJUSTL(str)) + IF (err /= 0) str = '' + RETURN + END FUNCTION dble2str_as + + FUNCTION cplx2str_as(value) RESULT(str) + !! Convert a complex value to string (auto format / string result) + COMPLEX(kind=4), INTENT(in) :: value !! Value to convert + CHARACTER(len=:), ALLOCATABLE :: str !! String with the converted value in output + INTEGER :: err,sl + sl = DIGITS(REAL(value))*2+3 + ALLOCATE(CHARACTER(len=sl) :: str) + WRITE(str, *, IOSTAT = err) value + str = TRIM(ADJUSTL(str)) + IF (err /= 0) str = '' + RETURN + END FUNCTION cplx2str_as + + FUNCTION int2str_fs(value, fmt, width) RESULT(str) + !! Convert an integer value to string (user format / string result) + INTEGER, INTENT(in) :: value !! Value to convert + CHARACTER(len=*), INTENT(in) :: fmt !! String format + INTEGER, INTENT(in) :: width !! Expected width of the output string (as defined in __fmt__) + CHARACTER(len=:), ALLOCATABLE :: str !! String with the converted value in output + INTEGER :: err + ALLOCATE(CHARACTER(len=width) :: str) + WRITE(str, '('//fmt//')', IOSTAT = err) value + str = TRIM(ADJUSTL(str)) + IF (err /= 0) str = '' + RETURN + END FUNCTION int2str_fs + + FUNCTION log2str_fs(value, fmt, width) RESULT(str) + !! Convert a logical value to string (user format / string result) + LOGICAL, INTENT(in) :: value !! Value to convert + CHARACTER(len=*), INTENT(in) :: fmt !! String format + INTEGER, INTENT(in) :: width !! Expected width of the output string (as defined in __fmt__) + CHARACTER(len=:), ALLOCATABLE :: str !! String with the converted value in output + INTEGER :: err + ALLOCATE(CHARACTER(len=width) :: str) + WRITE(str, '('//fmt//')', IOSTAT = err) value + str=TRIM(ADJUSTL(str)) + IF (err /= 0) str = '' + RETURN + END FUNCTION log2str_fs + + FUNCTION real2str_fs(value, fmt, width) RESULT(str) + !! Convert a simple precision floating point value to string (user format / string result) + REAL(kind=4), INTENT(in) :: value !! Value to convert + CHARACTER(len=*), INTENT(in) :: fmt !! String format + INTEGER, INTENT(in) :: width !! Expected width of the output string (as defined in __fmt__) + CHARACTER(len=:), ALLOCATABLE :: str !! String with the converted value in output + INTEGER :: err + ALLOCATE(CHARACTER(len=width) :: str) + WRITE(str, '('//fmt//')', IOSTAT = err) value + str = TRIM(ADJUSTL(str)) + IF (err /= 0) str = '' + RETURN + END FUNCTION real2str_fs + + FUNCTION dble2str_fs(value, fmt, width) RESULT(str) + !! Convert a double precision floating point value to string (user format / string result) + REAL(kind=8), INTENT(in) :: value !! Value to convert + CHARACTER(len=*), INTENT(in) :: fmt !! String format + INTEGER, INTENT(in) :: width !! Expected width of the output string (as defined in __fmt__) + CHARACTER(len=:), ALLOCATABLE :: str !! String with the converted value in output + INTEGER :: err + ALLOCATE(CHARACTER(len=width) :: str) + WRITE(str, '('//fmt//')', IOSTAT = err) value + str = TRIM(ADJUSTL(str)) + IF (err /= 0) str = '' + RETURN + END FUNCTION dble2str_fs + + FUNCTION cplx2str_fs(value, fmt, width) RESULT(str) + !! Convert a complex value to string (user format / string result) + COMPLEX(kind=4), INTENT(in) :: value !! Value to convert + CHARACTER(len=*), INTENT(in) :: fmt !! String format + INTEGER, INTENT(in) :: width !! Expected width of the output string (as defined in __fmt__) + CHARACTER(len=:), ALLOCATABLE :: str !! String with the converted value in output + INTEGER :: err + ALLOCATE(CHARACTER(len=width) :: str) + WRITE(str, '('//fmt//')', IOSTAT = err) value + str = TRIM(ADJUSTL(str)) + IF (err /= 0) str = '' + RETURN + END FUNCTION cplx2str_fs + +END MODULE STRINGS + +MODULE ESTRINGS + !! Fortran strings extensions + !! + !! This module is an extension of [[strings(module)]] module (i.e. contains all its definitions). + !! It defines overloaded string concatenation (//) and assignment operators (=) that simplify the + !! conversion between intrinsic types and strings. + !! + !! These operators only work with allocatable strings. + USE STRINGS + + PUBLIC + + PRIVATE :: str_affect_int, str_affect_bool, str_affect_real, & + str_affect_double, str_affect_cplx, str_affect_dcplx, & + str_cat_int, str_cat_bool, str_cat_real, str_cat_double, & + str_cat_cplx, str_cat_dcplx, str_cat_int_inv, & + str_cat_bool_inv, str_cat_real_inv, str_cat_double_inv, & + str_cat_cplx_inv, str_cat_dcplx_inv + + + + !> Overloaded string assignment operator interface + INTERFACE ASSIGNMENT(=) + MODULE PROCEDURE str_affect_int, str_affect_bool, str_affect_real, & + str_affect_double, str_affect_cplx, str_affect_dcplx + END INTERFACE + + !> Overloaded string concatentation operator interface + INTERFACE OPERATOR(//) + MODULE PROCEDURE str_cat_int, str_cat_bool, str_cat_real, str_cat_double, & + str_cat_cplx, str_cat_dcplx + MODULE PROCEDURE str_cat_int_inv, str_cat_bool_inv, str_cat_real_inv, & + str_cat_double_inv, str_cat_cplx_inv, str_cat_dcplx_inv + END INTERFACE + + + CONTAINS + + ! Extended strings features + ! --------------------------- + + FUNCTION str_cat_int(str1,int2) RESULT(str) + !! Concatenate a string with a integer + CHARACTER(len=*), INTENT(in) :: str1 !! String to concatenate + INTEGER, INTENT(in) :: int2 !! Integer to concatenate + CHARACTER(len=:), ALLOCATABLE :: str !! Concatenation resulting string + ALLOCATE(CHARACTER(len=DIGITS(int2)) :: str) + WRITE(str,*) int2 ; str = TRIM(ADJUSTL(str)) + IF (LEN(str1) /= 0) str = str1//str + RETURN + END FUNCTION str_cat_int + + !! @param[in] int2 An integer to concatenate + !! @param[in] str1 A string to concatenate + !! @return An allocatable string with the concatenation of input values. + FUNCTION str_cat_int_inv(int2,str1) RESULT(str) + !! Concatenate a string with a integer (inversed) + INTEGER, INTENT(in) :: int2 !! Integer to concatenate + CHARACTER(len=*), INTENT(in) :: str1 !! String to concatenate + CHARACTER(len=:), ALLOCATABLE :: str !! Concatenation resulting string + ALLOCATE(CHARACTER(len=DIGITS(int2)) :: str) + WRITE(str,*) int2 ; str = TRIM(ADJUSTL(str)) + IF (LEN(str1) /= 0) str = str//str1 + RETURN + END FUNCTION str_cat_int_inv + + FUNCTION str_cat_bool(str1,bool2) RESULT(str) + !! Concatenate a string with a logical + CHARACTER(len=*), INTENT(in) :: str1 !! String to concatenate + LOGICAL, INTENT(in) :: bool2 !! Logical to concatenate + CHARACTER(len=:), ALLOCATABLE :: str !! Concatenation resulting string + CHARACTER(len=2) :: tmp + WRITE(tmp,*) bool2 + str=TRIM(ADJUSTL(tmp)) + IF (LEN(str1) /= 0) str = str1//str + RETURN + END FUNCTION str_cat_bool + + FUNCTION str_cat_bool_inv(bool2,str1) RESULT(str) + !! Concatenate a string with a logical (inversed) + LOGICAL, INTENT(in) :: bool2 !! Logical to concatenate + CHARACTER(len=*), INTENT(in) :: str1 !! String to concatenate + CHARACTER(len=:), ALLOCATABLE :: str !! Concatenation resulting string + CHARACTER(len=2) :: tmp + WRITE(tmp,*) bool2 + str = TRIM(ADJUSTL(tmp)) + IF (LEN(str1) /= 0) str = str//str1 + RETURN + END FUNCTION str_cat_bool_inv + + FUNCTION str_cat_real(str1,real2) RESULT(str) + !! Concatenate a string with a real simple precision + CHARACTER(len=*), INTENT(in) :: str1 !! String to concatenate + REAL(kind=4), INTENT(in) :: real2 !! Simple precision real to concatenate + CHARACTER(len=:), ALLOCATABLE :: str !! Concatenation resulting string + ALLOCATE(CHARACTER(len=DIGITS(real2)) :: str) + WRITE(str,*) real2 ; str = TRIM(ADJUSTL(str)) + IF (LEN(str1) /= 0) str=str1//str + RETURN + END FUNCTION str_cat_real + + FUNCTION str_cat_real_inv(real2,str1) RESULT(str) + !! Concatenate a string with a real simple precision (inversed) + REAL(kind=4), INTENT(in) :: real2 !! Simple precision real to concatenate + CHARACTER(len=*), INTENT(in) :: str1 !! String to concatenate + CHARACTER(len=:), ALLOCATABLE :: str !! Concatenation resulting string + ALLOCATE(CHARACTER(len=DIGITS(real2)) :: str) + WRITE(str,*) real2 ; str = TRIM(ADJUSTL(str)) + IF (LEN(str1) /= 0) str = str//str1 + RETURN + END FUNCTION str_cat_real_inv + + FUNCTION str_cat_double(str1,double2) RESULT(str) + !! Concatenate a string with a real double precision + CHARACTER(len=*), INTENT(in) :: str1 !! String to concatenate + REAL(kind=8), INTENT(in) :: double2 !! Double precision real to concatenate + CHARACTER(len=:), ALLOCATABLE :: str !! Concatenation resulting string + ALLOCATE(CHARACTER(len=DIGITS(double2)) :: str) + WRITE(str,*) double2 ; str = TRIM(ADJUSTL(str)) + IF (LEN(str1) /= 0) str=str1//str + RETURN + END FUNCTION str_cat_double + + FUNCTION str_cat_double_inv(double2,str1) RESULT(str) + !! Concatenate a string with a real double precision (inversed) + REAL(kind=8), INTENT(in) :: double2 !! Double precision real to concatenate + CHARACTER(len=*), INTENT(in) :: str1 !! String to concatenate + CHARACTER(len=:), ALLOCATABLE :: str !! Concatenation resulting string + ALLOCATE(CHARACTER(len=DIGITS(double2)) :: str) + WRITE(str,*) double2 ; str = TRIM(ADJUSTL(str)) + IF (LEN(str1) /= 0) str = str//str1 + RETURN + END FUNCTION str_cat_double_inv + + FUNCTION str_cat_cplx(str1,cplx2) RESULT(str) + !! Concatenate a string with a complex + CHARACTER(len=*), INTENT(in) :: str1 !! String to concatenate + COMPLEX(kind=4), INTENT(in) :: cplx2 !! Complex value to concatenate + CHARACTER(len=:), ALLOCATABLE :: str !! Concatenation resulting string + INTEGER :: sl + sl = DIGITS(REAL(cplx2))*2+3 + ALLOCATE(CHARACTER(len=sl) :: str) + WRITE(str,*) cplx2 ; str = TRIM(ADJUSTL(str)) + IF (LEN(str1) /= 0) str = str//str1 + RETURN + END FUNCTION str_cat_cplx + + FUNCTION str_cat_cplx_inv(cplx2,str1) RESULT(str) + !! Concatenate a string with a complex (inversed) + COMPLEX(kind=4), INTENT(in) :: cplx2 !! Complex value to concatenate + CHARACTER(len=*), INTENT(in) :: str1 !! String to concatenate + CHARACTER(len=:), ALLOCATABLE :: str !! Concatenation resulting string + INTEGER :: sl + sl = DIGITS(REAL(cplx2))*2+3 + ALLOCATE(CHARACTER(len=sl) :: str) + WRITE(str,*) cplx2 + str = TRIM(ADJUSTL(str)) + IF (LEN(str1) /= 0) str = str//str1 + RETURN + END FUNCTION str_cat_cplx_inv + + FUNCTION str_cat_dcplx(str1,dcplx2) RESULT(str) + !! Concatenate a string with a double precision complex + CHARACTER(len=*), INTENT(in) :: str1 !! String to concatenate + COMPLEX(kind=8), INTENT(in) :: dcplx2 !! Complex value to concatenate + CHARACTER(len=:), ALLOCATABLE :: str !! Concatenation resulting string + INTEGER :: sl + sl = DIGITS(REAL(dcplx2))*2+3 + ALLOCATE(CHARACTER(len=sl) :: str) + WRITE(str,*) dcplx2 ; str = TRIM(ADJUSTL(str)) + IF (LEN(str1) /= 0) str = str//str1 + RETURN + END FUNCTION str_cat_dcplx + + FUNCTION str_cat_dcplx_inv(dcplx2,str1) RESULT(str) + !! Concatenate a string with a double precision complex (inversed) + COMPLEX(kind=8), INTENT(in) :: dcplx2 !! Complex value to concatenate + CHARACTER(len=*), INTENT(in) :: str1 !! string to concatenate + CHARACTER(len=:), ALLOCATABLE :: str !! Concatenation resulting string + INTEGER :: sl + sl = DIGITS(REAL(dcplx2))*2+3 + ALLOCATE(CHARACTER(len=sl) :: str) + WRITE(str,*) dcplx2 + str = TRIM(ADJUSTL(str)) + IF (LEN(str1) /= 0) str = str//str1 + RETURN + END FUNCTION str_cat_dcplx_inv + + SUBROUTINE str_affect_int(str,int) + !! Assignment subroutine (using intrinsic integer) + CHARACTER(len=:), INTENT(out), ALLOCATABLE :: str !! Output string to be assigned + INTEGER, INTENT(in) :: int !! Input value to assign + str = str_cat_int('',int) + END SUBROUTINE str_affect_int + + SUBROUTINE str_affect_bool(str,bool) + !! Assignment subroutine (using intrinsic logical) + CHARACTER(len=:), INTENT(out), ALLOCATABLE :: str !! Output string to be assigned + LOGICAL, INTENT(in) :: bool !! Input value to assign + str = str_cat_bool('',bool) + END SUBROUTINE str_affect_bool + + SUBROUTINE str_affect_real(str,float) + !! Assignment subroutine (using intrinsic real) + CHARACTER(len=:), INTENT(out), ALLOCATABLE :: str !! Output string to be assigned + REAL(kind=4), INTENT(in) :: float !! Input value to assign + str = str_cat_real('',float) + END SUBROUTINE str_affect_real + + SUBROUTINE str_affect_double(str,double) + !! Assignment subroutine (using intrinsic real(kind=8)) + CHARACTER(len=:), INTENT(out), ALLOCATABLE :: str !! Output string to be assigned + REAL(kind=8), INTENT(in) :: double !! Input value to assign + str = str_cat_double('',double) + END SUBROUTINE str_affect_double + + SUBROUTINE str_affect_cplx(str,cplx) + !! Assignment subroutine (using intrinsic complex) + CHARACTER(len=:), INTENT(out), ALLOCATABLE :: str !! Output string to be assigned + COMPLEX(kind=4), INTENT(in) :: cplx !! Input value to assign + str = str_cat_cplx('',cplx) + END SUBROUTINE str_affect_cplx + + SUBROUTINE str_affect_dcplx(str,dcplx) + !! Assignment subroutine (using intrinsic complex(kind=8)) + CHARACTER(len=:), INTENT(out), ALLOCATABLE :: str !! Output string to be assigned + COMPLEX(kind=8), INTENT(in) :: dcplx !! Input value to assign + str = str_cat_dcplx('',dcplx) + END SUBROUTINE str_affect_dcplx + +END MODULE estrings