Changeset 1897


Ignore:
Timestamp:
Jan 24, 2018, 10:24:24 PM (7 years ago)
Author:
jvatant
Message:

Making Titan's hazy again - part II
+ Major updates of J.Burgalat YAMMS library and optical coupling, including :
++ Added the routines for haze optics inside YAMMS
++ Calling rad. transf. with interactive haze is plugged
in but should stay unactive as long as the microphysics is
in test phase : cf "uncoupl_optic_haze" flag : true for now !
++ Also some sanity checks for negative tendencies and
some others upkeep of YAMMS model
+ Also added a temporary CPP key USE_QTEST in physiq_mod
that enables to have microphysical tendencies separated
from dynamics for debugging and test phases
-- JVO and JB

Location:
trunk/LMDZ.TITAN
Files:
5 added
2 deleted
28 edited

Legend:

Unmodified
Added
Removed

  • trunk/LMDZ.TITAN/README

    r1896 r1897  
    14011401Added a bash script ( utilities/prepare_startkim.bash ) to create startfi files
    14021402with upper_chemistry_layers dimension and fill fields from old comp_xx files
     1403
     1404== 24/01/18 == JVO
     1405Major updates in YAMMS and it's coupling from J.Burgalat, including
     1406+ Added the microphysics optical routines and coupling of YAMMS haze with the radiative transfer
     1407+ ... yet you shouldn't activate it yet ( flag uncoupl_optic_haze has to be true ) !
     1408+ Some supplementary safety checks to keep microphysics spitting negative tendencies
     1409+ Other upkeep changes deeper in the library

  • trunk/LMDZ.TITAN/libf/muphytitan/argparse.F90

    r1814 r1897  
    1 ! Copyright Jérémie Burgalat (2010-2015)
     1! Copyright Jérémie Burgalat (2010-2015,2017)
    22!
    3 ! burgalat.jeremie@gmail.com
     3! jeremie.burgalat@univ-reims.fr
    44!
    55! This software is a computer program whose purpose is to provide configuration
    … …  
    3333
    3434!! file: argparse.F90
    35 !! summary: Command-line parser source file
    36 !! author: burgalat
    37 !! date: 2013-2015
     35!! summary: Command-line parser source file.
     36!! author: J. Burgalat
     37!! date: 2013-2015,2017
    3838
    3939#include "defined.h"
    … …  
    4747  !!
    4848  !! If you only wish to have an overview of argparse usage, you'd better go
    49   !! [p_argparse](here).
     49  !! [here](|url|/page/swift/p01_argparse.html).
     50
    5051  USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY : stdout=>OUTPUT_UNIT, stderr=>ERROR_UNIT
    5152  USE ERRORS
    5253  USE FSYSTEM, ONLY : fs_termsize
    53   USE STRINGS, getpar => format_paragraph, &
    54                splitstr  => format_string, &
    55                ap_string  => st_string,    & !! String value type ID
    56                ap_complex  => st_complex,  & !! Complex value type ID
    57                ap_logical => st_logical,   & !! Logical value type ID
    58                ap_integer => st_integer,   & !! Integer value type ID
    59                ap_real    => st_real         !! Floating point value type ID
     54  USE STRING_OP, getpar => format_paragraph, splitstr  => format_string 
    6055  IMPLICIT NONE
    6156
    … …  
    6661  PUBLIC :: noerror,error, error_to_string,aborting
    6762  ! from strings
    68 #if ! HAVE_FTNDTSTR
    6963  PUBLIC :: st_slen, st_llen
    70 #endif
    71   PUBLIC :: ap_string, ap_complex, ap_logical, ap_integer, ap_real
    7264  PUBLIC :: stderr, stdout
    7365  ! argparse module
    … …  
    9284  ! PARAMETERS (INTRISIC TYPES)
    9385  ! ===========================
     86
     87  INTEGER, PARAMETER, PUBLIC :: ap_string  = st_string
     88    !! String value type identifier.
     89  INTEGER, PARAMETER, PUBLIC :: ap_complex = st_complex
     90    !! Complex value type identifier.
     91  INTEGER, PARAMETER, PUBLIC :: ap_logical = st_logical
     92    !! Logical value type identifier.
     93  INTEGER, PARAMETER, PUBLIC :: ap_integer = st_integer
     94    !! Integer value type identifier.
     95  INTEGER, PARAMETER, PUBLIC :: ap_real = st_real
     96    !! Real value type identifier.
     97
     98  !> List of all available actions
    9499
    95100  INTEGER, PARAMETER, PUBLIC :: ap_store  = 1
    … …  
    120125   
    121126  !> Add an option to the parser
     127  !!
     128  !! ```
     129  !! FUNCTION argparser_add_option(this,dest,sflag,lflag,type,action,default,nrec,help,meta) RESULT(err)
     130  !!          argparser_add_option(this,dest,flag,type,action,default,nrec,help,meta) RESULT(err)
     131  !! ```
     132  !!
     133  !! The function defines a new argument based on input parameters, checks it and finally sets it
     134  !! in the parser.
     135  !!
     136  !! In its first version both short (`sflag`) and long (`lflag`) options flags are mandatory. In its second
     137  !! form, a single flag (`flag`) is expected: the method will automatically deduce if it belongs to short or
     138  !! a long option flag based on the number of hyphens given.
     139  !!
     140  !! `type` value should be one of the following module constants (which are aliases from [[string_op(module)]]):
     141  !!
     142  !! - `ap_string` ([[string_op(module):st_string(variable)]])
     143  !! - `ap_complex` ([[string_op(module):st_complex(variable)]])
     144  !! - `ap_logical` ([[string_op(module):st_logical(variable)]])
     145  !! - `ap_integer` ([[string_op(module):st_integer(variable)]])
     146  !! - `ap_real` ([[string_op(module):st_real(variable)]])
     147  !!
     148  !! `action` value should be one of the following module constants:
     149  !!
     150  !! - [[argparse(module):ap_store(variable)]]
     151  !! - [[argparse(module):ap_append(variable)]]
     152  !! - [[argparse(module):ap_count(variable)]]
     153  !! - [[argparse(module):ap_help(variable)]]
     154  !!
     155  !! `nrec` string can take the following forms:
     156  !!
     157  !! tag   | description
     158  !! :---: | : -------------
     159  !!  "?"  | zero or one argument's value
     160  !!  "*"  | any number of arguments
     161  !!  "+"  | one or more argument's value(s)
     162  !!  "X"  | Exactly X values. Where X is the string representation of an integer (0 is accepted).
     163  !!
     164  !! On success, `noerror` is returned. Otherwise -9 error code is returned. Errors are only
     165  !! produced by misuse of the function arguments. In such case, the program should be
     166  !! stopped: note that such error should not occur in _released_ programs.
    122167  INTERFACE argparser_add_option
    123168    MODULE PROCEDURE ap_add_option_1, ap_add_option_2
    … …  
    131176  !> Get optional argument value(s)
    132177  !!
    133   !! This is the generic method that can be used to retrieve any kind of argument value(s) from the parser.
     178  !! ```
     179  !! FUNCTION argparser_get_value(this,name,output) RESULT(err)
     180  !! ```
     181  !!
     182  !! This is the generic method that can be used to retrieve any kind of argument value(s) from the parser for a given
     183  !! argument name (as defined by the `dest` argument of [[argparse(module):argparser_add_option(interface)]].
    134184  !! All the methods have the same dummy arguments only `output` dummy argument differs in type and shape.
    135185  !!
    … …  
    137187  !! For string vector, `output` is expected to be an allocatable vector of **assumed length**
    138188  !! strings (thus string length is left to user responsability).
    139   !! A good compromise for strings length is to use the [[strings(module):st_slen(variable)]]
     189  !! A good compromise for strings length is to use the [[string_op(module):st_slen(variable)]]
    140190  !! parameter.
    141191  INTERFACE argparser_get_value
    … …  
    287337    PROCEDURE, PRIVATE :: ap_get_sv_ve
    288338    PROCEDURE, PRIVATE :: ap_check_state
    289     !PROCEDURE, PUBLIC  :: reset_values       => argparser_reset_values
    290     !  !! Resets values stored in the parser
    291339    PROCEDURE, PUBLIC  :: throw_error        => argparser_throw_error
    292340      !! Throw an error and exit the program
    … …  
    415463
    416464  FUNCTION argparser_add_positionals(this,nargs,meta,help) RESULT(err)
    417     !! Add positional arguments definition to the parser
     465    !! Add positional arguments definition to the parser.
     466    !!
    418467    !! The method initializes the entry for positional arguments in the parser.
    419468    !! Positional arguments are always seen by the parser as strings and the
    420469    !! default associated action is 'store'.
    421 
    422470    OBJECT(argparser), INTENT(inout)                     :: this
    423471      !! An argparser object reference
    … …  
    533581    IF (zauto) THEN
    534582      IF (rhelp) CALL argparser_help(this)
    535       IF (err /= 0.AND. err /= 255) CALL argparser_throw_error(this,err,2)
     583      IF (err /= 0) CALL argparser_throw_error(this,err,2)
    536584    ENDIF
    537585    RETURN
    … …  
    751799    !! in the parser. Both **short and long options flags** are mandatory input arguments of the function.
    752800    !!
    753     !!  `type` value should be one of the following module constants (which are aliases from [[strings(module)]]):
    754     !!  - ap_string ([[strings(module):st_string(variable)]])
    755     !!  - ap_complex ([[strings(module):st_complex(variable)]])
    756     !!  - ap_logical ([[strings(module):st_logical(variable)]])
    757     !!  - ap_integer ([[strings(module):st_integer(variable)]])
    758     !!  - ap_real ([[strings(module):st_real(variable)]])
     801    !!  `type` value should be one of the following module constants (which are aliases from [[string_op(module)]]):
     802    !!  - ap_string ([[string_op(module):st_string(variable)]])
     803    !!  - ap_complex ([[string_op(module):st_complex(variable)]])
     804    !!  - ap_logical ([[string_op(module):st_logical(variable)]])
     805    !!  - ap_integer ([[string_op(module):st_integer(variable)]])
     806    !!  - ap_real ([[string_op(module):st_real(variable)]])
    759807    !!
    760808    !!  `action` value should be one of the following module constants:
    … …  
    772820    !!   X  | Exactly X values. Where X is the string representation of an integer (0 is accepted).
    773821    !!
    774     !! See also [[argparse(module):ap_add_option_2(function)]] documentation.
     822    !! See also ap_add_option_2 documentation.
    775823    OBJECT(argparser), INTENT(inout)                     :: this
    776824      !! An argparser object reference
    … …  
    828876    !! Add an argument to the parser (interface #2)
    829877    !!
    830     !! The function is a wrapper to [[argparse(module):ap_add_option_1(function)]]. In this version,
     878    !! The function is a wrapper to ap_add_option_1. In this version,
    831879    !! only one option flag is required. The method only checks for the (trimmed) length of **flag** in
    832880    !! order to choose wether it is a **short** or **long** option flag. Then the function simply calls
    833     !! [[argparse(module):ap_add_option_1(function)]] to set the argument.
     881    !! ap_add_option_1 to set the argument.
    834882    !!
    835     !! Other dummy arguments have the same meaning as in [[argparse(module):ap_add_option_1(function)]].
     883    !! Other dummy arguments have the same meaning as in ap_add_option_1.
    836884    OBJECT(argparser), INTENT(inout)                     :: this
    837885      !! An argparser object reference
    … …  
    886934      !! An argc object to check
    887935    TYPE(error) :: err
    888       !! Error object with -15 id if object is already set, no error otherwise.
     936      !! Error object with -8 id if object is already set, no error otherwise.
    889937    INTEGER :: i
    890938    err = noerror
    … …  
    914962      !! An argparser object reference
    915963    TYPE(words), INTENT(inout)               :: cmd
    916       !! A [[strings(module):words(type)]] object with the command-line to parse
     964      !! A [[string_op(module):words(type)]] object with the command-line to parse
    917965    LOGICAL, INTENT(out)                     :: help_req
    918966      !! An output logical flag with `.true.` if help option has been found, `.false.` otherwise
    … …  
    9871035      !! An argparser object reference
    9881036    TYPE(words), INTENT(inout)       :: cmd
    989       !! A [[strings(module):words(type)]] object with the command-line to parse
     1037      !! A [[string_op(module):words(type)]] object with the command-line to parse
    9901038    TYPE(error) :: err
    9911039      !! Error object with the first error encountered in the process
    … …  
    10681116    ! Gets values as a function of the expected number of records
    10691117    IF (arg%nrec == 0) THEN
    1070       ! parse_args (main parsing method) reset all values: for 0 nrec
     1118      ! argparser_parse (main parsing method) reset all values: for 0 nrec
    10711119      ! we should have at least one value saved which is the default.
    10721120      ! if it is not the case we set default as values of the argument
    … …  
    11361184    !! @warning
    11371185    !! For compilers that does not support allocatable strings in derived types,
    1138     !! computation are highly dependent of [[strings(module):st_slen(variable):
     1186    !! computation are highly dependent of [[string_op(module):st_slen(variable):
    11391187    !! tokens length are limited by this parameter.
    11401188    IMPLICIT NONE
    … …  
    11441192      !! A string to process
    11451193    TYPE(words), INTENT(out)      :: new_cmd
    1146       !! An output [[strings(module):words(type)]] object with the processed command line
     1194      !! An output [[string_op(module):words(type)]] object with the processed command line
    11471195    LOGICAL, INTENT(out)          :: rhelp   
    11481196      !! An output boolean flag with `.true.` if help is requested, `.false.` otherwise
    … …  
    11551203    err = noerror ; rhelp = .false.
    11561204    IF (LEN_TRIM(string) == 0) THEN
    1157       err = error('internal error (empty string)',-2)
     1205      err = error('internal error (empty string)',-255)
    11581206      RETURN
    11591207    ENDIF
    11601208    ! split input command line in words !
    1161     splitted = new_words(string," ",.true.) ! tokens may be truncated :(
     1209    call words_extend(splitted,string," ",.true.)
    11621210    ! reset iterator
    11631211    CALL words_reset(splitted)
    … …  
    13301378
    13311379  SUBROUTINE ap_format_usage(this,optmw)
    1332     !! Format command line usage
     1380    !! Format command line usage.
     1381    !!
    13331382    !! The subroutine creates and formats the command line usage of the
    13341383    !! given argparser object. If [[argparser(type):usg(variable)]] is already set (i.e. not empty)
    … …  
    16931742    !! The function calls all the tests to perform on argc members. Some of these tests can
    16941743    !! alter argc's member values to fit argparser's requirements.
    1695     !! @note
    1696     !! Normally, program should be stopped if returned error is not 0 !
     1744    !!
     1745    !! On success, `noerror` is returned. Otherwise -9 error code is returned. Errors are only
     1746    !! produced by misuse of the function arguments. In such case, the program should be
     1747    !! stopped: note that such ezrror should not occur in _released_ programs.
    16971748    TYPE(argc), INTENT(inout)                            :: this
    16981749      !! An argc object
    … …  
    17401791    !! The method checks if input argument's options are valid and update the argc object
    17411792    !! consequently.
     1793    !!
     1794    !! On success, `noerror` is returned. Otherwise -9 error code is returned. Errors are only
     1795    !! produced by misuse of the function arguments.
    17421796    TYPE(argc), INTENT(inout)  :: this
    17431797      !! An argc object to update
    … …  
    17561810    ret = noerror
    17571811    eprf = 'argparse: '//"Invalid argument `"//TRIM(this%name)//"'"
    1758     uty = error(eprf//" (type)",-2)
    1759     ina = error(eprf//" (inconsistent nargs)",-2)
     1812    uty = error(eprf//" (type)",-9)
     1813    ina = error(eprf//" (inconsistent nargs)",-9)
    17601814    zna = TRIM(na)
    17611815    ! Checks action
    … …  
    17631817      this%paction = ac
    17641818    ELSE
    1765       ret = error(eprf//" (action)",-2) ; RETURN
     1819      ret = error(eprf//" (action)",-9) ; RETURN
    17661820    ENDIF
    17671821    ! Checks and sets type and default as a function of the action
    … …  
    18851939            terr = error(eprf//" (inconsistent default value: expected '"// &
    18861940                           TRIM(st_type_names(this%ptype))//"', found '"// &
    1887                            TRIM(st_type_names(t))//"')",-2)
     1941                           TRIM(st_type_names(t))//"')",-9)
    18881942            RETURN
    18891943          ENDIF
    … …  
    19772031      SELECT CASE(this%nrec)
    19782032        CASE(-3,-2,-1)
    1979           zmeta = str_to_upper(meta(1))
     2033          zmeta = to_upper(meta(1))
    19802034          blk = INDEX(TRIM(zmeta),CHAR(32)) - 1
    19812035          IF (blk <= 0) blk=LEN_TRIM(zmeta)
    … …  
    19872041          DO i=1,this%nrec
    19882042            j=j+1 ; IF (j>ms) j=1
    1989             zmeta = str_to_upper(meta(j))
     2043            zmeta = to_upper(meta(j))
    19902044            blk=INDEX(TRIM(zmeta),CHAR(32))-1
    19912045            IF (blk <= 0) blk=LEN_TRIM(zmeta)
    … …  
    19942048      END SELECT
    19952049    ELSE
    1996       zmeta = str_to_upper(TRIM(this%name))
     2050      zmeta = to_upper(TRIM(this%name))
    19972051      SELECT CASE(this%nrec)
    19982052        CASE(-3,-2,-1)
    … …  
    22232277    !! - -7  : argument not found (i.e. does not set in the parser)
    22242278    !! - -19 : parsing not done yet
    2225     !! - -20 : (previous) parsing failed
     2279    !! - -20 : parsing failed
    22262280    !! - -21 : inconsistent destination type
    22272281    !! @note
    … …  
    24802534  !! @param[in,out] this An argc object
    24812535  !! @param[out] output A scalar with the first value of the argument
    2482   !! @return An errors::error object with -12 if the destination variable's type
     2536  !! @return An errors::error object with -21 if the destination variable's type
    24832537  !! is inconsistent, 0 otherwise.
    24842538  FUNCTION ac_get_dv_sc(this, output) RESULT(ret)
    … …  
    24922546      !! Output value
    24932547    TYPE(error) :: ret
    2494       !! Error object with the -12 if the destination variable's type is inconsistent, 0 otherwise
     2548      !! Error object with the -21 if the destination variable's type is inconsistent, 0 otherwise
    24952549    ret = noerror
    24962550    IF (this%ptype /= ap_real) THEN

  • trunk/LMDZ.TITAN/libf/muphytitan/asciiread.f90

    r1793 r1897  
    1 ! Copyright Jérémie Burgalat (2010-2015)
    2 !
    3 ! burgalat.jeremie@gmail.com
     1! Copyright Jérémie Burgalat (2010-2015,2017)
     2!
     3! jeremie.burgalat@univ-reims.fr
    44!
    55! This software is a computer program whose purpose is to provide configuration
    … …  
    3232! knowledge of the CeCILL-B license and that you accept its terms.
    3333
    34 !! file: asciiread.F90
     34!! file: asciiread.f90
    3535!! summary: ASCII data file reader source file
    3636!! author: burgalat
    37 !! date: 2013-2015
     37!! date: 2013-2015,2017
    3838MODULE ASCIIREAD
    3939  !! ASCII data file reader module
    … …  
    4242  !! data array from ASCII file.
    4343  !!
    44   !! ```fortran
     44  !! ```
    4545  !! FUNCTION read_data(path,data) RESULT(err)
    4646  !! ```
    … …  
    6565  !!
    6666  !! - path does not refer to a existing file (1)
    67   !! - Logical unit 666 is not free (1)
     67  !! - No free logical unit available (1)
    6868  !! - the file does not have regular data-columns number (5)
    6969  !! - at least a value cannot be cast in double precision (5)
    … …  
    7979  !! On success, the shape of the 3D output array will be _data(R,C,D)_.
    8080  USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: IOSTAT_END, IOSTAT_EOR
    81   USE STRINGS, ONLY: tokenize,from_string, st_slen
     81  !USE STRING_OP, ONLY: tokenize,from_string, st_slen
     82  USE STRING_OP
    8283  USE ERRORS
    8384  IMPLICIT NONE
    … …  
    8586  PRIVATE
    8687  PUBLIC :: noerror,error, error_to_string,aborting
    87   PUBLIC :: read_data, OPERATOR(/=), OPERATOR(==)
     88  PUBLIC :: readline,read_data, OPERATOR(/=), OPERATOR(==)
    8889
    8990  !! Global interface to reading methods
    … …  
    110111    !! Error occured when:
    111112    !!    - Path does not refer to a existing file (-11)
    112     !!    - No free logical unit available (-12)
     113    !!    - No free logical unit available (-1)
    113114    !!    - The file does not have regular data-columns number (-5)
    114115    !!    - At least a value cannot be cast in double precision (-10)
    … …  
    120121    !! On success, the shape of the 3D output array will be _output(R,C,D)_.
    121122    !! On error, the 3D output array is __not allocated__.
    122     !!
    123     !! @note
    124     !! The function uses the logical unit 666 !
    125123    CHARACTER(len=*), INTENT(in)                             :: path      !! Path of the input data file
    126124    REAL(kind=8), INTENT(out), DIMENSION(:,:,:), ALLOCATABLE :: data3d    !! 3D-array with the output values (double precision)
    … …  
    130128    INTEGER                                           :: i,lc,tlc
    131129    INTEGER                                           :: ndr,ndc,ndd
    132     INTEGER                                           :: ir,jc,kd
     130    INTEGER                                           :: ir,jc,kd,lu
    133131    REAL(kind=8), DIMENSION(:), ALLOCATABLE           :: tmp
    134132    CHARACTER(len=5)                                  :: slc
    … …  
    144142      err = error(trim(path)//": no such file",-1) ; RETURN
    145143    ENDIF
    146     INQUIRE(unit=666,OPENED=ok)
    147     IF (ok) THEN
    148       err = error("lun 666 is already used",-1) ; RETURN
    149     ENDIF
     144    lu = free_lun()
     145    IF (lu == -1) THEN ; err = error("Cannot find available logical unit...",-1) ; RETURN ; ENDIF
    150146    ! Open file
    151     OPEN(666,FILE=TRIM(path),STATUS='OLD',ACTION='READ')
     147    OPEN(lu,FILE=TRIM(path),STATUS='OLD',ACTION='READ')
    152148
    153149    ! First pass :
    … …  
    158154    lc = 0 ; tlc = 0
    159155    ndr = -1 ; ndc = -1 ; ndd = 1
    160     DO WHILE(readline(666,line))
     156    DO WHILE(readline(lu,line))
    161157      lm1 = line
    162158      ! Read the line
    … …  
    193189      ENDIF
    194190      IF (ndc == -1) ndc = SIZE(wrds)
     191      IF (ALLOCATED(wrds)) DEALLOCATE(wrds)
     192      IF (ALLOCATED(tmp)) DEALLOCATE(tmp)
    195193    ENDDO
    196194
    … …  
    203201
    204202    ! Rewind input data file
    205     REWIND(666)
     203    REWIND(lu)
    206204    ! Allocate memory
    207205    ALLOCATE(data3d(ndr,ndc,ndd))
    208206    ir = 0 ; kd = 1 ;
    209     DO WHILE(readline(666,line))
     207    DO WHILE(readline(lu,line))
    210208      IF (INDEX(TRIM(ADJUSTL(line)),"#") == 1) CYCLE
    211209      ir = ir + 1
    … …  
    216214      ok = tokenize(line,wrds,zdelim,.true.)
    217215      DO jc = 1,ndc ; ok = from_string(wrds(jc),data3d(ir,jc,kd)) ; ENDDO
    218     ENDDO
    219     CLOSE(666)
     216      IF (ALLOCATED(wrds)) DEALLOCATE(wrds)
     217    ENDDO
     218    CLOSE(lu)
    220219  END FUNCTION read_data_3d
    221220
    … …  
    236235    !!
    237236    !! - Path does not refer to a existing file (-1)
    238     !! - Logical unit 666 is not free (-1)
     237    !! - No free logical unit available (-1)
    239238    !! - The file does not have regular data-columns number (-5)
    240239    !! - At least a value cannot be cast in double precision (-5)
    241240    !!
    242241    !! On error, the 2D output array is __not allocated__.
    243     !! @note
    244     !! The function uses the logical unit 666 !
     242    USE FSYSTEM
    245243    CHARACTER(len=*), INTENT(in)                           :: path      !! Path of the input data file
    246244    REAL(kind=8), INTENT(out), DIMENSION(:,:), ALLOCATABLE :: data2d    !! 2D-array with the output values (double precision)
    … …  
    249247    LOGICAL                                           :: ok
    250248    INTEGER                                           :: i,e,vc,lc
    251     INTEGER                                           :: nl,nc
     249    INTEGER                                           :: nl,nc,lu
    252250    REAL(kind=8), DIMENSION(:), ALLOCATABLE           :: tmp
    253251    CHARACTER(len=5)                                  :: slc
    254252    CHARACTER(len=:), ALLOCATABLE                     :: line,zdelim
    255253    CHARACTER(len=st_slen), DIMENSION(:), ALLOCATABLE :: wrds
    256 
    257254    zdelim = CHAR(9)//CHAR(32)
    258255    IF (PRESENT(delimiter)) zdelim = delimiter
    259     ! Gets array size
    260256    INQUIRE(FILE=TRIM(path),EXIST=ok)
    261257    IF (.NOT.ok) THEN
    262258      err = error(trim(path)//": no such file",-1) ; RETURN
    263259    ENDIF
    264     INQUIRE(unit=666,OPENED=ok)
    265     IF (ok) THEN
    266       err = error("lun 666 is already used",-1) ; RETURN
    267     ENDIF
    268     OPEN(666,FILE=TRIM(path),STATUS='OLD',ACTION='READ')
     260    lu = free_lun()
     261    IF (lu == -1) THEN ; err = error("Cannot find available logical unit...",-1) ; RETURN ; ENDIF
     262    OPEN(lu,FILE=TRIM(path),STATUS='OLD',ACTION='READ')
    269263    vc = 0 ; lc=0 ; ok = .true.
    270264    ! Read the file twice :)
    … …  
    273267    DO
    274268      ! Read the line
    275       IF (.NOT.readline(666,line)) EXIT
     269      IF (.NOT.readline(lu,line)) EXIT
    276270      lc = lc + 1 ; WRITE(slc,'(I5)') lc ; slc = ADJUSTL(slc)
    277271      ! skip empty/comment line
    … …  
    279273      ! update row counter
    280274      vc = vc + 1
    281       ! Splits line in words
    282275      IF (.NOT.tokenize(line,wrds,zdelim,.true.)) THEN
    283276        ! cannot tokenize
    … …  
    286279      ELSEIF (.NOT.from_string(wrds,tmp)) THEN
    287280        ! cannot cast values
    288         do i=1,size(wrds) ; write(*,*) trim(wrds(i)) ; enddo
    289         write(1111,'(a)') line
    290281        err = error(trim(path)//": Cannot cast values at line "//TRIM(slc),-5)
    291282        RETURN
    292       ELSEIF (nc > 0 .AND. nc /= SIZE(wrds)) THEN
     283      ELSEIF (nc > 0 .AND. nc /= SIZE(tmp)) THEN
    293284        ! current number of columns not equal to last one
    294285        err = error(trim(path)//": Invalid number of columns (line "//TRIM(slc)//")",-5)
    … …  
    296287      ENDIF
    297288      IF (nc == -1) nc = SIZE(wrds)
     289      IF (ALLOCATED(wrds)) DEALLOCATE(wrds)
     290      IF (ALLOCATED(tmp)) DEALLOCATE(tmp)
    298291    ENDDO
    299292    ! Rewind input data file
    300     REWIND(666)
     293    REWIND(lu)
    301294    nl = vc
    302295    ! allocate memory
    … …  
    306299    DO WHILE(vc <= nl)
    307300      ! Reads the line
    308       IF (.NOT.readline(666,line)) EXIT
     301      IF (.NOT.readline(lu,line)) EXIT
    309302      ! Check if we have comment or null string
    310303      IF (INDEX(TRIM(ADJUSTL(line)),"#") == 1.OR.LEN_TRIM(line) == 0) CYCLE
    … …  
    314307        ok = from_string(wrds(i),data2d(vc,i))
    315308      ENDDO
    316     ENDDO
    317     CLOSE(666)
     309      IF (ALLOCATED(wrds)) DEALLOCATE(wrds)
     310    ENDDO
     311    CLOSE(lu)
    318312    RETURN
    319313  END FUNCTION read_data_2d
    … …  
    327321    !! The function is intended to read a file line by line:
    328322    !!
    329     !! ```fortran
     323    !! ```
    330324    !! lu = 1
    331325    !! open(lu,file="path/to/the/file/to/read")
    … …  
    358352  END FUNCTION readline
    359353
    360 END MODULE
     354END MODULE ASCIIREAD

  • trunk/LMDZ.TITAN/libf/muphytitan/cfgparse.F90

    r1814 r1897  
    1 ! Copyright Jérémie Burgalat (2010-2015)
    2 ! 
    3 ! burgalat.jeremie@gmail.com
    4 ! 
    5 ! This software is a computer program whose purpose is to provide configuration 
     1! Copyright Jérémie Burgalat (2010-2015,2017)
     2!
     3! jeremie.burgalat@univ-reims.fr
     4!
     5! This software is a computer program whose purpose is to provide configuration
    66! file and command line arguments parsing features to Fortran programs.
    7 ! 
     7!
    88! This software is governed by the CeCILL-B license under French law and
    9 ! abiding by the rules of distribution of free software.  You can  use, 
     9! abiding by the rules of distribution of free software.  You can  use,
    1010! modify and/ or redistribute the software under the terms of the CeCILL-B
    1111! license as circulated by CEA, CNRS and INRIA at the following URL
    12 ! "http://www.cecill.info". 
    13 ! 
     12! "http://www.cecill.info".
     13!
    1414! As a counterpart to the access to the source code and  rights to copy,
    1515! modify and redistribute granted by the license, users are provided only
    1616! with a limited warranty  and the software's author,  the holder of the
    1717! economic rights,  and the successive licensors  have only  limited
    18 ! liability. 
    19 ! 
     18! liability.
     19!
    2020! In this respect, the user's attention is drawn to the risks associated
    2121! with loading,  using,  modifying and/or developing or reproducing the
    … …  
    2525! professionals having in-depth computer knowledge. Users are therefore
    2626! encouraged to load and test the software's suitability as regards their
    27 ! requirements in conditions enabling the security of their systems and/or 
    28 ! data to be ensured and,  more generally, to use and operate it in the 
    29 ! same conditions as regards security. 
    30 ! 
     27! requirements in conditions enabling the security of their systems and/or
     28! data to be ensured and,  more generally, to use and operate it in the
     29! same conditions as regards security.
     30!
    3131! The fact that you are presently reading this means that you have had
    3232! knowledge of the CeCILL-B license and that you accept its terms.
    3333
    3434!! file: cfgparse.F90
    35 !! summary: Configuration file parser source file
    36 !! author: burgalat
    37 !! date: 2013-2015, 2017
     35!! summary: Configuration file parser source file.
     36!! author: J. Burgalat
     37!! date: 2013-2015,2017
    3838
    3939#include "defined.h"
    … …  
    4141MODULE CFGPARSE
    4242  !! Configuration file parsing module
    43   !! 
    44   !! This module defines a set of derived types as well as methods to parse configuration files.
     43  !!
     44  !! This module defines a set of derived types as well as methods to parse configuration files.
     45  !!
     46  !! If you only wish to have an overview of cfgparse usage, you'd better go
     47  !! [here](|url|/page/swift/p02_cfgparse.html).
    4548  !! @todo
    46   !! Add interpolation from environment and/or parser options
     49  !! Add interpolation from environment and/or parser options.
    4750  USE, INTRINSIC :: ISO_FORTRAN_ENV
    4851  USE ERRORS
    49   USE STRINGS
     52  USE STRING_OP
    5053  USE FSYSTEM
    5154  IMPLICIT NONE
    … …  
    5659            cfg_get_value, cfg_set_value, cfg_count, cfg_check_name, &
    5760            cfg_has_option, cfg_has_section, &
     61            cfg_option_names,cfg_section_names, &
    5862            cfg_remove_option, cfg_remove_section, &
    5963            cfg_sort_options
    … …  
    6367  ! some public definitions from other modules
    6468  ! from strings
    65   PUBLIC :: str_to_lower,st_slen, st_llen
     69  PUBLIC :: to_lower,st_slen, st_llen
    6670
    6771  PUBLIC :: OPERATOR(==), OPERATOR(/=), ASSIGNMENT(=)
    … …  
    7680  TYPE, PUBLIC :: cfgparser
    7781    !! Define a parser of options
    78     !! 
    79     !! A [[cfgparser(type)]] stores [[option(type)]] objects. 
     82    !!
     83    !! A [[cfgparser(type)]] stores [[option(type)]] objects.
    8084    TYPE(option), DIMENSION(:), ALLOCATABLE  :: options !! list of options.
    8185#if HAVE_FTNPROC
    … …  
    124128    PROCEDURE, PUBLIC :: remove_option  => cfg_remove_option
    125129    !> Remove a section (and all the associated options) from the parser.
    126     PROCEDURE, PUBLIC :: remove_section => cfg_remove_section 
    127     !> Get value(s) of an option in the parser by name 
    128     !! 
     130    PROCEDURE, PUBLIC :: remove_section => cfg_remove_section
     131    !> Get value(s) of an option in the parser by name
     132    !!
    129133    !! ```
    130134    !! FUNCTION cfg_get_value(this,name,output) RESULT(error)
    … …  
    135139    !! On error, __output__ argument is undefined (that is, left unchanged
    136140    !! for scalar versions, **unallocated** for vector version).
    137     !! 
     141    !!
    138142    !! Errors occur in the following situations:
    139143    !! - The option has no value (-6)
    140     !! - The option does not exist (-7) 
     144    !! - The option does not exist (-7)
    141145    !! - The option's value cannot be cast in the desired type (-10)
    142146    GENERIC, PUBLIC :: get_value     => cp_get_rv_sc,cp_get_dv_sc,cp_get_iv_sc, &
    … …  
    144148                                        cp_get_rv_ve,cp_get_dv_ve,cp_get_iv_ve, &
    145149                                        cp_get_lv_ve,cp_get_cv_ve,cp_get_sv_ve
    146     !> Set value(s) of an option in the parser by name 
    147     !! 
     150    !> Set value(s) of an option in the parser by name
     151    !!
    148152    !! ```
    149153    !! FUNCTION cfg_set_value(this,name,input,create) RESULT(error)
    … …  
    167171  END TYPE cfgparser
    168172
    169   !> Get value(s) of an option in the parser by name. 
    170   !! 
     173  !> Get value(s) of an option in the parser by name.
     174  !!
    171175  !! ```
    172176  !! FUNCTION cfg_get_value(parser,name,output) RESULT(error)
    … …  
    177181  !! On error, __output__ argument is undefined (that is, left unchanged
    178182  !! for scalar versions, **unallocated** for vector version).
    179   !! 
     183  !!
    180184  !! Errors occur in the following situations:
    181185  !! - The option has no value (-6)
    182   !! - The option does not exist (-7) 
     186  !! - The option does not exist (-7)
    183187  !! - The option's value cannot be cast in the desired type (-10)
    184188  INTERFACE cfg_get_value
    … …  
    189193  END INTERFACE
    190194
    191     !> Set value(s) of an option in the parser by name 
    192     !! 
     195    !> Set value(s) of an option in the parser by name
     196    !!
    193197    !! ```
    194198    !! FUNCTION set_value(this,name,input,create) RESULT(error)
    … …  
    201205    !! exist in _this_ parser.
    202206    !! @warning
    203     !! In such case, if the given is not valid, an assertion is raised !
     207    !! In such case, if the given __name__ is not valid, an error is raised !
    204208    !!
    205209    !! On error (i.e. no option matches the given _name_), no values are set.
    206     INTERFACE cfg_set_value 
     210    INTERFACE cfg_set_value
    207211      MODULE PROCEDURE :: cp_set_rv_sc,cp_set_dv_sc,cp_set_iv_sc, &
    208212                          cp_set_lv_sc,cp_set_cv_sc,cp_set_sv_sc, &
    209213                          cp_set_rv_ve,cp_set_dv_ve,cp_set_iv_ve, &
    210214                          cp_set_lv_ve,cp_set_cv_ve,cp_set_sv_ve
    211     END INTERFACE 
     215    END INTERFACE
    212216
    213217    !> Derived type assignment operator
    … …  
    230234    this%section = other%section
    231235    this%values = other%values
    232   END SUBROUTINE op_affect_sc 
    233  
     236  END SUBROUTINE op_affect_sc
     237
    234238  FUNCTION op_valid(opt) RESULT(ok)
    235239    !! Check whether or not the option is valid (i.e. has name)
    236     TYPE(option), INTENT(in)      :: opt  !! An option object 
     240    TYPE(option), INTENT(in)      :: opt  !! An option object
    237241    LOGICAL :: ok !! True if the option is valid, false otherwise.
    238242    ok = LEN_TRIM(opt%name) > 0
    239243  END FUNCTION op_valid
    240244
    241   SUBROUTINE op_clear(opt) 
     245  SUBROUTINE op_clear(opt)
    242246    !! Clear and invalid the given option.
    243     TYPE(option), INTENT(inout)      :: opt  !! An option object 
     247    TYPE(option), INTENT(inout)      :: opt  !! An option object
    244248    opt%name = ''
    245249    opt%section = ''
    … …  
    261265    ENDIF
    262266  END FUNCTION op_full_name
    263  
     267
    264268  FUNCTION op_split_name(fname,sname,pname) RESULT(err)
    265269    !> Split a full name in section and option names
    266     !!
    267     !! The method splits a full name into (section,option) names. Output names (if any) are always
    268     !! set to lower case.
     270    !!
     271    !! The method splits a full name into (section,option) names:
     272    !!
     273    !! - Option basename is always set in lower-case.
     274    !! - If any, section name case is left unmodified.
    269275    !!
    270276    !! A full name simply consists in a section name and an option name separated by a single "/".
    271277    !!
    272     !! The method never checks the validity of the output names. Consider using [[cfg_check_name(function)]]
    273     !! to do so.
    274     !! @note
    275     !! If _fname_ does not contains any "/", the method set the special name "\_\_default\_\_" for the output
    276     !! section name.
     278    !! The method never checks the validity of the output names. Consider using [[cfg_check_name(function)]]
     279    !! to do so.
    277280    !! @note
    278     !! On success, option and section names are set to lower case. Otherwise they are set to empty strings.
     281    !! If _fname_ does not contains any "/", the method sets the special name "\_\_default\_\_" for the output
     282    !! section name.
     283    !! @note
     284    !! On failure, output arguments are set to empty strings.
    279285    !! @warning
    280     !! If _fname_ ends with a "/", an error (-6, invalid name) is raised: the method always assumes it can
     286    !! If _fname_ ends with a "/", an error (-9, invalid name) is raised: the method always assumes it can
    281287    !! find an option part in the name.
    282288    CHARACTER(len=*), INTENT(in)               :: fname    !! A name to split
    283289    CHARACTER(len=:), INTENT(out), ALLOCATABLE :: sname, & !! Section part of the name
    284290                                                  pname    !! Option part of the name
    285     TYPE(error) :: err !! Error status of the method
    286     INTEGER     :: idx
     291    TYPE(error)                                :: err      !! Error status of the method
     292    INTEGER                       :: idx
     293    CHARACTER(len=:), ALLOCATABLE :: tfname
    287294    err = noerror ; pname = "" ; sname = ""
     295    tfname = op_format(fname,sname,pname)
     296    IF (LEN_TRIM(tfname) == 0) err = error("Invalid option name ("//TRIM(fname)//")",-9)
     297  END FUNCTION op_split_name
     298
     299  FUNCTION op_format(name,sname,pname) RESULT(oname)
     300    !! Format the input name to be consistent with character case requirements.
     301    !!
     302    !! Given a **name**, the method tries to split in section/option names.
     303    !! Then it converts the option part in lower-case.
     304    !!
     305    !! If no section part is found (not '/' or set as first character of **name**), the
     306    !! special section name `__default__` is set.
     307    !!
     308    !! If **name** ends with a '/', it is an error and the method returns an empty string.
     309    CHARACTER(len=*), INTENT(in)  :: name  !! Name to format.
     310    CHARACTER(len=:), ALLOCATABLE, INTENT(out), OPTIONAL :: sname !! Section part of the name (optional output)
     311    CHARACTER(len=:), ALLOCATABLE, INTENT(out), OPTIONAL :: pname !! Option part of the name (optional output)
     312    CHARACTER(len=:), ALLOCATABLE :: oname                        !! Formatted full option name.
     313    INTEGER                       :: idx
     314    CHARACTER(len=:), ALLOCATABLE :: zsname,zpname
     315    zpname = "" ; zsname = ""
    288316    ! splits input name in sname, pname
    289     idx = INDEX(fname,'/')
    290     IF (idx == LEN_TRIM(fname)) THEN
    291       err = error("Invalid option name ("//TRIM(fname)//")",-9)
     317    idx = INDEX(name,'/')
     318    IF (idx == LEN_TRIM(name)) THEN
     319      oname = ''
     320      IF (PRESENT(sname)) sname = ''
     321      IF (PRESENT(pname)) pname = ''
    292322      RETURN
    293323    ELSE IF (idx <= 1) THEN
    294       sname = "__default__" ; pname = TRIM(fname)
    295       IF (idx == 1) pname=pname(2:)
    296     ELSE
    297       sname = fname(:idx-1)
    298       pname = fname(idx+1:LEN_TRIM(fname))
    299     ENDIF
    300     ! 17/12/2014: set option name to lower
    301     pname = str_to_lower(pname)
    302     sname = str_to_lower(sname)
    303   END FUNCTION op_split_name
     324      zsname = "__default__" ; zpname = to_lower(TRIM(name))
     325      IF (idx == 1) zpname=zpname(2:)
     326    ELSE
     327      zsname = name(:idx-1)
     328      zpname = to_lower(name(idx+1:LEN_TRIM(name)))
     329    ENDIF
     330    oname = zsname//"/"//zpname
     331    IF (PRESENT(sname)) sname = zsname
     332    IF (PRESENT(pname)) pname = zpname
     333  END FUNCTION op_format
    304334
    305335  FUNCTION op_greater_than(left,right) RESULT(ret)
    … …  
    309339    TYPE(option), INTENT(in) :: left  !! LHS option.
    310340    TYPE(option), INTENT(in) :: right !! RHS option.
    311     LOGICAL :: ret 
     341    LOGICAL :: ret
    312342      !! .true. if LHS is _greater_ than RHS (based on section and option name)
    313343    ret = LGT(op_full_name(left),op_full_name(right))
    … …  
    320350    TYPE(option), INTENT(in) :: left  !! LHS option.
    321351    TYPE(option), INTENT(in) :: right !! RHS option.
    322     LOGICAL :: ret 
     352    LOGICAL :: ret
    323353      !! .true. if LHS is _less_ than RHS (based on section and option name)
    324354    ret = LLT(op_full_name(left),op_full_name(right))
    … …  
    327357  FUNCTION op_to_str(opt,num_values) RESULT(str)
    328358    !! Get the string representation of a option object
    329     !! @note 
     359    !! @note
    330360    !! If the object is not valid an empty string is returned.
    331     TYPE(option), INTENT(in) :: opt 
     361    TYPE(option), INTENT(in) :: opt
    332362      !! A option object
    333363    INTEGER, INTENT(in), OPTIONAL :: num_values
    … …  
    343373    str = TRIM(opt%name)//" = " ; np = LEN(str)
    344374    ALLOCATE(CHARACTER(len=np) :: nspcs) ; nspcs(1:) = " "
    345     ! stores the error but do not check... 
     375    ! stores the error but do not check...
    346376    ret = words_to_vector(opt%values,vec)
    347377    IF (.NOT.ALLOCATED(vec)) RETURN
    … …  
    382412
    383413  FUNCTION cfg_check_name(name) RESULT(valid)
    384     !! Check if a name is valid
    385     !!
    386     !! A valid option/section name begins with a letter and is followed by any
    387     !! number of alphanumeric characters and underscore (`[A-Za-z][A-Za-z0-9\_]\*`).
     414    !! Check if a name is valid.
     415    !!
     416    !! If **name** contains a '/' it is assumed to be a full option name. In such case
     417    !! both parts of the name are checked against section/option names requirements (see below).
     418    !!
     419    !! Otherwise it is assumed to be the basename of the option.
     420    !!
     421    !! A valid option (base) name is an alphanumeric sequence in lower-case that always begin by
     422    !! a letter.
     423    !!
     424    !! A valid section name is and alphanumeric sequence (in any case) that always begins by
     425    !! by a letter.
    388426    CHARACTER(len=*), INTENT(in) :: name !! A string with the name to check.
    389427    LOGICAL :: valid                     !! .true. if the name is valid, .false. otherwise
    390428    INTEGER                       :: i
    391     CHARACTER(len=26), PARAMETER  :: alpha = "abcdefghijklmnopqrstuvwxyz"
    392     CHARACTER(len=12), PARAMETER  :: num   = "0123456789_"
     429    CHARACTER(len=26), PARAMETER  :: alpha  = "abcdefghijklmnopqrstuvwxyz"
     430    CHARACTER(len=26), PARAMETER  :: ualpha = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
     431    CHARACTER(len=12), PARAMETER  :: num    = "0123456789_"
    393432    CHARACTER(len=:), ALLOCATABLE :: pname,sname
    394433    TYPE(error)                   :: err
    … …  
    401440      ENDIF
    402441    ELSE
    403       pname = str_to_lower(TRIM(name))
     442      pname = to_lower(TRIM(name))
    404443      sname = "__default__"
    405444    ENDIF
    … …  
    416455      i = INDEX(sname,CHAR(32))
    417456      IF (i /= 0.OR.LEN_TRIM(sname) <= 0) RETURN
    418       valid = (VERIFY(sname(1:1),alpha) == 0 .AND.VERIFY(TRIM(sname),alpha//"/"//num) == 0)
     457      valid = (VERIFY(sname(1:1),ualpha//alpha) == 0 .AND.VERIFY(TRIM(sname),ualpha//alpha//num) == 0)
    419458    ENDIF
    420459  END FUNCTION cfg_check_name
    421460
    422   FUNCTION cfg_count(this) RESULT(num)
     461  FUNCTION cfg_count(this,section) RESULT(num)
    423462    !! Get the total number of option in the parser.
    424463    !!
     464    !! If a section name is given in argument, the method returns the count for the given section only.
     465    !!
     466    !! To get the number of top-level options (i.e. that belongs to the default section) the keyword \_\_default\_\_
     467    !! should be set for the section argument.
     468    !!
     469    !! If __section__ is not defined in the parser, the method returns 0.
     470    !!
    425471    !! @internal
    426     !! If no options are defined, then it implies that the internal vector of options is 
     472    !! If no options are defined, then it implies that the internal vector of options is
    427473    !! not allocated.
    428     OBJECT(cfgparser), INTENT(in) :: this !! A cfgparser object to search in
    429     INTEGER :: num                        !! Number of current options registered in the parser.
     474    OBJECT(cfgparser), INTENT(in)          :: this    !! A cfgparser object to search in
     475    CHARACTER(len=*), INTENT(in), OPTIONAL :: section !! Optional section name to search in.
     476    INTEGER :: num                                    !! Number of current options registered in the parser.
     477    INTEGER :: i
    430478    num = 0
    431479    IF(.NOT.ALLOCATED(this%options)) RETURN
    432     num = SIZE(this%options)
     480    IF (.NOT.PRESENT(section)) THEN
     481      num = SIZE(this%options) 
     482    ELSE
     483      DO i=1, SIZE(this%options)
     484        IF (this%options(i)%section == section) num = num+1
     485      ENDDO
     486    ENDIF
    433487  END FUNCTION cfg_count
    434488
    … …  
    469523        ! Found a match so start looking again
    470524        found = (tmp(j) == this%options(i)%section .OR. &
    471                  this%options(i)%section == "__default__") 
     525                 this%options(i)%section == "__default__")
    472526        IF (found) EXIT
    473527      ENDDO
    … …  
    482536  END FUNCTION cfg_section_names
    483537
    484   FUNCTION cfg_option_names(this) RESULT(list)
     538  FUNCTION cfg_option_names(this,secname) RESULT(list)
    485539    !! Get the list of option names.
    486540    !!
    487541    !! @note
    488542    !! If the parser does not have options, the vector is still allocated but with 0 elements.
    489     OBJECT(cfgparser), INTENT(in) :: this                     !! A cfgparser object to process.
    490     CHARACTER(len=st_slen), DIMENSION(:), ALLOCATABLE :: list !! List of option names.
    491     INTEGER               :: i,no
     543    OBJECT(cfgparser), INTENT(in)                     :: this    !! A cfgparser object to process.
     544    CHARACTER(len=*), INTENT(in), OPTIONAL            :: secname !! Optional section name to search in.
     545    CHARACTER(len=st_slen), DIMENSION(:), ALLOCATABLE :: list    !! List of option names.
     546    INTEGER               :: j,i,no,nso
    492547    no = cfg_count(this)
    493     ALLOCATE(list(no))
    494     IF (no == 0) RETURN
    495     DO i=1,no
    496       IF (this%options(i)%section == "__default__") THEN
    497         list(i) = TRIM(this%options(i)%name)
    498       ELSE
    499         list(i) = TRIM(this%options(i)%section)//"/"//TRIM(this%options(i)%name)
    500       ENDIF
    501     ENDDO
     548    IF (no == 0) THEN
     549       ALLOCATE(list(no)) ; RETURN
     550    ENDIF
     551    IF (PRESENT(secname)) THEN
     552      IF (.NOT.cfg_has_section(this,TRIM(secname))) THEN
     553        ALLOCATE(list(no)) ; RETURN
     554      ELSE
     555        nso = 0
     556        DO i=1,no ; IF (this%options(i)%section == TRIM(secname)) nso = nso + 1 ; ENDDO
     557        ALLOCATE(list(nso))
     558        IF (nso == 0) RETURN
     559        j = 1
     560        DO i=1,no
     561          IF (this%options(i)%section == TRIM(secname)) THEN
     562            list(j) = TRIM(this%options(i)%section)//"/"//TRIM(this%options(i)%name) ; j=j+1
     563          ENDIF
     564        ENDDO
     565      ENDIF
     566    ELSE
     567      ALLOCATE(list(no))
     568      DO i=1,no
     569        IF (this%options(i)%section == "__default__") THEN
     570          list(i) = TRIM(this%options(i)%name)
     571        ELSE
     572          list(i) = TRIM(this%options(i)%section)//"/"//TRIM(this%options(i)%name)
     573        ENDIF
     574      ENDDO
     575    ENDIF
    502576  END FUNCTION cfg_option_names
    503577
    504578  FUNCTION cfg_has_section(this,name) RESULT(yes)
    505579    !! Check if parser has section by name
     580    !!
     581    !! @note
     582    !! Keep in mind that section name in the configuration are case-sensitive.
    506583    OBJECT(cfgparser), INTENT(in) :: this !! cfgparser object
    507584    CHARACTER(len=*), INTENT(in)  :: name !! Name of the section to search
    508585    LOGICAL :: yes                        !! .true. if the section exists, .false. otherwise
    509     CHARACTER(len=:), ALLOCATABLE :: zname
    510586    INTEGER                       :: i,no
    511587    yes = .false.
    512588    no = cfg_count(this)
    513589    IF (no == 0) RETURN
    514     zname = str_to_lower(name)
    515590    DO i = 1,no
    516       IF (this%options(i)%section == zname) THEN
     591      IF (this%options(i)%section == name) THEN
    517592        yes = .true.
    518593        RETURN
    … …  
    527602    LOGICAL :: yes                        !! .true. if the option is found, .false. otherwise
    528603    CHARACTER(len=:), ALLOCATABLE :: pname,zname
    529     INTEGER                       :: i,no
     604    INTEGER                       :: i,no,iscan
    530605    yes = .false.
    531606    no = cfg_count(this)
    532607    IF (no == 0) RETURN
    533     IF (SCAN(name,"/") <= 0) THEN
    534       zname = "__default__"//"/"//str_to_lower(TRIM(name))
    535     ELSE
    536       zname = str_to_lower(TRIM(name))
    537     ENDIF
     608    zname = op_format(name)
     609    IF (LEN_TRIM(zname) == 0) RETURN
    538610    DO i = 1,no
    539       pname = op_full_name(this%options(i)) 
     611      pname = op_full_name(this%options(i))
    540612      IF (pname == zname) THEN
    541613        yes = .true.
    … …  
    545617  END FUNCTION cfg_has_option
    546618
    547   SUBROUTINE cfg_sort_options(this) 
     619  SUBROUTINE cfg_sort_options(this)
    548620    !! Sort the options in the parser (alphabetiCALLy).
    549621    OBJECT(cfgparser), INTENT(inout) :: this !! A cfgparser object
    … …  
    552624    IF (no == 0) RETURN
    553625    CALL insertionSort(this%options)
    554   END SUBROUTINE cfg_sort_options 
     626  END SUBROUTINE cfg_sort_options
    555627
    556628  SUBROUTINE cfg_remove_option(this,name)
    557629    !! Remove an option from parser by name.
    558     OBJECT(cfgparser), INTENT(inout) :: this !! A cfgparser object to search in 
     630    OBJECT(cfgparser), INTENT(inout) :: this !! A cfgparser object to search in
    559631    CHARACTER(len=*), INTENT(in)     :: name !! The name of the option to remove
    560     CHARACTER(len=:), ALLOCATABLE    :: zname,pname
    561632    INTEGER                                 :: no,idx,i,j
    562633    TYPE(option), DIMENSION(:), ALLOCATABLE :: tmp
    563     IF (SCAN(name,"/") <= 0) THEN
    564       zname = "__default__"//"/"//str_to_lower(TRIM(name))
    565     ELSE
    566       zname = str_to_lower(TRIM(name))
    567     ENDIF
    568     idx = cp_get_opt_idx(this,zname)
     634    idx = cp_get_opt_idx(this,name)
     635    IF (idx == -1) RETURN
    569636    no = cfg_count(this)
    570     IF (idx == -1) RETURN
    571637    ! only one opt
    572638    IF (no == 1) THEN
    … …  
    589655      this%options(i) = tmp(i)
    590656      CALL op_clear(tmp(i))
    591     ENDDO 
     657    ENDDO
    592658    DEALLOCATE(tmp)
    593659  END SUBROUTINE cfg_remove_option
    … …  
    597663    !!
    598664    !! The method removes all the options that belong to the given section name.
    599     OBJECT(cfgparser), INTENT(inout) :: this 
    600       !! A cfgparser object to search in 
     665    OBJECT(cfgparser), INTENT(inout) :: this
     666      !! A cfgparser object to search in
    601667    CHARACTER(len=*), INTENT(in)     :: name
    602668      !! The name of the section to remove
    603     CHARACTER(len=:), ALLOCATABLE           :: zname
    604669    INTEGER                                 :: no,i,j,icount
    605670    INTEGER, DIMENSION(:), ALLOCATABLE      :: idxs,itmp
    606671    TYPE(option), DIMENSION(:), ALLOCATABLE :: tmp
    607      
    608672    no = cfg_count(this)
    609673    IF (no == 0) RETURN
    610     zname = str_to_lower(TRIM(name))
    611674    ALLOCATE(itmp(no))
    612675    itmp(:) = -1
    613676    icount = 0
    614677    DO i=1,no
    615       IF (TRIM(this%options(i)%section) == zname) THEN
     678      IF (TRIM(this%options(i)%section) == TRIM(name)) THEN
    616679        itmp(icount+1) = i
    617680        icount = icount + 1
    … …  
    627690       DEALLOCATE(this%options)
    628691       RETURN
    629     ENDIF 
     692    ENDIF
    630693    ALLOCATE(tmp(icount))
    631694    j = 1
    … …  
    650713    !! Read configuration file
    651714    !!
    652     !! @note 
     715    !! @note
    653716    !! If the library support C bindings, the method can read included files which are defined
    654717    !! by the __#include <...>__ directive (see [p_cfgparse](here) from more details).
    … …  
    662725      !! An error with the first error encountered
    663726    INTEGER                       :: i
    664     LOGICAL                       :: zoverride,ok 
    665     TYPE(words)                   :: incfiles 
     727    LOGICAL                       :: zoverride,ok
     728    TYPE(words)                   :: incfiles
    666729    CHARACTER(len=:), ALLOCATABLE :: name
    667730    CHARACTER(len=st_slen)        :: isec
    668     err = noerror 
     731    err = noerror
    669732    zoverride = .false. ; IF (PRESENT(override)) zoverride = override
    670733    isec = "__default__"
    671734    name = TRIM(path)
    672     i = INDEX(name,'/',.true.) ; IF (i /= 0) name = name(i+1:) 
     735    i = INDEX(name,'/',.true.) ; IF (i /= 0) name = name(i+1:)
    673736    IF (i == 0) THEN
    674737      name = fs_realpath("./"//path)
    … …  
    710773    no = cfg_count(this)
    711774    IF (no == 0) THEN
    712       err = error("No options to write",-7) 
     775      err = error("No options to write",-7)
    713776      RETURN
    714777    ENDIF
    … …  
    728791      WRITE(lu,'(a)') op_to_str(this%options(i),nv)
    729792    ENDDO
    730   END FUNCTION cfg_write_config 
     793  END FUNCTION cfg_write_config
    731794
    732795  ! internal (private methods)
    … …  
    751814  FUNCTION cp_get_opt_idx(this,name) RESULT(idx)
    752815    !! Get the index of an option by name in the parser.
    753     !! 
     816    !!
    754817    !! The method searches in the parser for the option with the given (full) __name__.
    755818    !! If found, it returns the index of the option in the internal vector of options. Otherwise
    … …  
    763826    no = cfg_count(this)
    764827    IF (no == 0) RETURN
    765     IF (SCAN(name,"/") <= 0) THEN
    766       zname = "__default__"//"/"//str_to_lower(TRIM(name))
    767     ELSE
    768       zname = str_to_lower(TRIM(name))
    769     ENDIF
     828    zname = op_format(name) ! prepare the name to search.
     829    IF (LEN_TRIM(zname) == 0) RETURN
    770830    DO i=1,no
    771831      pname = op_full_name(this%options(i))
    … …  
    780840    !! Update an option in the parser.
    781841    !!
    782     !! The attempts to update the option in the parser that matches __opt__ name.
    783     !!
    784     !! If __name__ is given it is used instead of __opt__ name.
    785     !!
    786     !! If no option is found, __opt__ is appended in the parser. Otherwise the matched
    787     !! option is updated (i.e. its values are set to __opt__ values).
    788     !!
    789     !! If the option is not valid, the method does nothing and -X error status is returned.
     842    !! The method attempts to update the option in the parser.
     843    !!
     844    !! If __sname__ is set to empty string, the method searches for the option
     845    !! in the default section.
     846    !!
     847    !! If no option is found, The the option is appended in the parser. Otherwise it is updated
     848    !! with the content of __values__.
     849    !!
     850    !! If the option name is not valid, the method does nothing and -9 error status is returned.
    790851    !!
    791852    !! @internal
    792853    !! The method performs the same kind of operations than the setters except that it
    793     !! expects raw data ([[strings(module):words(type)]]).
     854    !! expects raw data ([[string_op(module):words(type)]]).
    794855    OBJECT(cfgparser), INTENT(inout) :: this   !! cfgparser object to process.
    795856    CHARACTER(len=*), INTENT(in)     :: sname  !! Name of the section.
    796     CHARACTER(len=*), INTENT(in)     :: pname  !! Name of the option.
     857    CHARACTER(len=*), INTENT(in)     :: pname  !! Basename of the option.
    797858    TYPE(words), INTENT(in)          :: values !! Raw values.
    798     TYPE(error) :: err !! Error status.
     859    TYPE(error)                      :: err    !! Error status.
    799860    CHARACTER(len=:), ALLOCATABLE :: zsname,fname
    800861    INTEGER                       :: i
    801862    err = noerror
    802     zsname = str_to_lower(TRIM(sname))
    803     IF (LEN_TRIM(zsname) == 0 ) zsname = "__default__"
    804     fname = zsname//"/"//str_to_lower(TRIM(pname))
     863    zsname = TRIM(sname)
     864    IF (LEN_TRIM(sname) == 0) zsname = "__default__"
     865    fname = zsname//"/"//to_lower(TRIM(pname))
    805866    IF (.NOT.cfg_check_name(fname)) THEN
    806867       err = error("Invalid option (no name)",-9)
    … …  
    816877  END FUNCTION cp_update_opt
    817878
    818 
    819   FUNCTION cp_add_opt(this,sname,pname,values) RESULT(err)
     879  FUNCTION cp_add_opt(this,sname,pname,values) RESULT(err)
    820880    !! Add an option to the parser.
    821881    !!
    822882    !! In order to add an option to the default section, _sname_ should be left empty or set to "\_\_default\_\_".
    823     !!
    824     !! If given, _opt_ points to the new option on output. If an error occured the pointer is null.
    825883    !!
    826884    !! The following error code can be returned:
    … …  
    828886    !!  - -8, the option already exists.
    829887    !!  - -9, option name is not valid.
    830     OBJECT(cfgparser), INTENT(inout) :: this   
     888    OBJECT(cfgparser), INTENT(inout) :: this
    831889      !! A cfgparser object to process.
    832890    CHARACTER(len=*), INTENT(in)     :: sname
    833891      !! Section name.
    834892    CHARACTER(len=*), INTENT(in)     :: pname
    835       !! Option name.
     893      !! Option basename.
    836894    TYPE(words), INTENT(in)          :: values
    837895      !! Values to set.
    … …  
    839897      !! Return error status.
    840898    CHARACTER(len=:), ALLOCATABLE           :: zsname,fname
    841     TYPE(option), DIMENSION(:), ALLOCATABLE :: tmp 
     899    TYPE(option), DIMENSION(:), ALLOCATABLE :: tmp
    842900    INTEGER                                 :: no,i
    843 
    844     TYPE(option) :: sca
     901    TYPE(option)                            :: sca
    845902
    846903    err = noerror
    … …  
    848905    no = cfg_count(this)
    849906    IF (LEN_TRIM(zsname) == 0) zsname = "__default__"
    850     fname = TRIM(zsname)//"/"//TRIM(pname)
     907    fname = TRIM(zsname)//"/"//to_lower(TRIM(pname))
    851908    ! check name
    852909    IF (.NOT.cfg_check_name(fname)) THEN
    … …  
    864921    ! build option
    865922    CALL op_clear(sca)
    866     sca%name = pname
     923    sca%name = to_lower(TRIM(pname))
    867924    sca%section = zsname
    868925    sca%values = values
    … …  
    874931      ! parser has options: increase this%options size (ugly copy).
    875932      ALLOCATE(tmp(no))
    876       DO i =1,no 
    877         tmp(i) = this%options(i) 
     933      DO i =1,no
     934        tmp(i) = this%options(i)
    878935        CALL op_clear(this%options(i))
    879936      ENDDO
    880937      DEALLOCATE(this%options)
    881938      ALLOCATE(this%options(no+1))
    882       DO i =1,no 
    883         this%options(i) = tmp(i) 
     939      DO i =1,no
     940        this%options(i) = tmp(i)
    884941        CALL op_clear(tmp(i))
    885942      ENDDO
    … …  
    898955    !!  - -6, the option does not have value(s).
    899956    !!  - -10, the value cannot be converted in the output type.
    900     OBJECT(cfgparser), INTENT(in) :: this   !! Cfgparser object 
     957    OBJECT(cfgparser), INTENT(in) :: this   !! Cfgparser object
    901958    CHARACTER(len=*), INTENT(in)  :: name   !! (Full) Name of the option to get
    902959    REAL(kind=4), INTENT(out)     :: output !! Output value
    903     TYPE(error) :: err 
     960    TYPE(error) :: err
    904961      !! Error status
    905     INTEGER :: idx 
     962    INTEGER :: idx
    906963    CHARACTER(len=:), ALLOCATABLE :: tmp
    907964    err = noerror
    … …  
    918975        err = error("Option "//TRIM(name)//" has no value",-6)
    919976      ELSE
    920         IF(.NOT.from_string(tmp,output)) & 
     977        IF(.NOT.from_string(tmp,output)) &
    921978        err = error(TRIM(name)//": Cannot convert "//tmp//" to real.",-10)
    922979      ENDIF
    … …  
    931988    !!  - -6, the option does not have value(s).
    932989    !!  - -10, the value cannot be converted in the output type.
    933     OBJECT(cfgparser), INTENT(in) :: this   !! Cfgparser object 
     990    OBJECT(cfgparser), INTENT(in) :: this   !! Cfgparser object
    934991    CHARACTER(len=*), INTENT(in)  :: name   !! (Full) Name of the option to get
    935992    REAL(kind=8), INTENT(out)     :: output !! Output value
    936     TYPE(error) :: err 
     993    TYPE(error) :: err
    937994      !! Error status
    938     INTEGER :: idx 
     995    INTEGER :: idx
    939996    CHARACTER(len=:), ALLOCATABLE :: tmp
    940997    err = noerror
    … …  
    9511008        err = error("Option "//TRIM(name)//" has no value",-6)
    9521009      ELSE
    953         IF(.NOT.from_string(tmp,output)) & 
     1010        IF(.NOT.from_string(tmp,output)) &
    9541011        err = error(TRIM(name)//": Cannot convert "//tmp//" to double.",-10)
    9551012      ENDIF
    … …  
    9641021    !!  - -6, the option does not have value(s).
    9651022    !!  - -10, the value cannot be converted in the output type.
    966     OBJECT(cfgparser), INTENT(in) :: this   !! Cfgparser object 
     1023    OBJECT(cfgparser), INTENT(in) :: this   !! Cfgparser object
    9671024    CHARACTER(len=*), INTENT(in)  :: name   !! (Full) Name of the option to get
    9681025    INTEGER, INTENT(out)          :: output !! Output value
    969     TYPE(error) :: err 
     1026    TYPE(error) :: err
    9701027      !! Error status
    971     INTEGER :: idx 
     1028    INTEGER :: idx
    9721029    CHARACTER(len=:), ALLOCATABLE :: tmp
    9731030    err = noerror
    … …  
    9841041        err = error("Option "//TRIM(name)//" has no value",-6)
    9851042      ELSE
    986         IF(.NOT.from_string(tmp,output)) & 
     1043        IF(.NOT.from_string(tmp,output)) &
    9871044        err = error(TRIM(name)//": Cannot convert "//tmp//" to integer.",-10)
    9881045      ENDIF
    … …  
    9971054    !!  - -6, the option does not have value(s).
    9981055    !!  - -10, the value cannot be converted in the output type.
    999     OBJECT(cfgparser), INTENT(in) :: this   !! Cfgparser object 
     1056    OBJECT(cfgparser), INTENT(in) :: this   !! Cfgparser object
    10001057    CHARACTER(len=*), INTENT(in)  :: name   !! (Full) Name of the option to get
    10011058    LOGICAL, INTENT(out)          :: output !! Output value
    1002     TYPE(error) :: err 
     1059    TYPE(error) :: err
    10031060      !! Error status
    1004     INTEGER :: idx 
     1061    INTEGER :: idx
    10051062    CHARACTER(len=:), ALLOCATABLE :: tmp
    10061063    err = noerror
    … …  
    10171074        err = error("Option "//TRIM(name)//" has no value",-6)
    10181075      ELSE
    1019         IF(.NOT.from_string(tmp,output)) & 
     1076        IF(.NOT.from_string(tmp,output)) &
    10201077        err = error(TRIM(name)//": Cannot convert "//tmp//" to logical.",-10)
    10211078      ENDIF
    … …  
    10301087    !!  - -6, the option does not have value(s).
    10311088    !!  - -10, the value cannot be converted in the output type.
    1032     OBJECT(cfgparser), INTENT(in) :: this   !! Cfgparser object 
     1089    OBJECT(cfgparser), INTENT(in) :: this   !! Cfgparser object
    10331090    CHARACTER(len=*), INTENT(in)  :: name   !! (Full) Name of the option to get
    10341091    COMPLEX, INTENT(out)          :: output !! Output value
    1035     TYPE(error) :: err 
     1092    TYPE(error) :: err
    10361093      !! Error status
    1037     INTEGER :: idx 
     1094    INTEGER :: idx
    10381095    CHARACTER(len=:), ALLOCATABLE :: tmp
    10391096    err = noerror
    … …  
    10501107        err = error("Option "//TRIM(name)//" has no value",-6)
    10511108      ELSE
    1052         IF(.NOT.from_string(tmp,output)) & 
     1109        IF(.NOT.from_string(tmp,output)) &
    10531110        err = error(TRIM(name)//": Cannot convert "//tmp//" to complex.",-10)
    10541111      ENDIF
    … …  
    10621119    !!  - -7, no option matches the given name.
    10631120    !!  - -6, the option does not have value(s).
    1064     OBJECT(cfgparser), INTENT(in) :: this   !! Cfgparser object 
     1121    OBJECT(cfgparser), INTENT(in) :: this   !! Cfgparser object
    10651122    CHARACTER(len=*), INTENT(in)  :: name   !! (Full) Name of the option to get
    10661123    CHARACTER(len=*), INTENT(out) :: output !! Output value
    1067     TYPE(error) :: err 
     1124    TYPE(error) :: err
    10681125      !! Error status
    1069     INTEGER :: idx 
     1126    INTEGER :: idx
    10701127    !CHARACTER(len=:), ALLOCATABLE :: tmp
    10711128    err = noerror
    … …  
    10871144    !!
    10881145    !! On error, the output vector is not allocated.
    1089     OBJECT(cfgparser), INTENT(in)                        :: this   !! Cfgparser object 
     1146    OBJECT(cfgparser), INTENT(in)                        :: this   !! Cfgparser object
    10901147    CHARACTER(len=*), INTENT(in)                         :: name   !! (Full) Name of the option to get
    10911148    REAL(kind=4), INTENT(out), DIMENSION(:), ALLOCATABLE :: output !! Output values
    1092     TYPE(error) :: err                                                 
     1149    TYPE(error) :: err
    10931150      !! Error status of the method (see [[cfgparser(type):get_value(bound)]] documentation)
    10941151    CHARACTER(len=st_slen), DIMENSION(:), ALLOCATABLE :: tmp
    … …  
    11141171        ELSE IF (.NOT.from_string(tmp(i), output(i))) THEN
    11151172          err = error("Cannot convert value #"//TRIM(i2s)//" from option "//TRIM(name),-10)
    1116           DEALLOCATE(output) ; EXIT 
     1173          DEALLOCATE(output) ; EXIT
    11171174        ENDIF
    11181175      ENDDO
    11191176    ENDIF
    11201177    DEALLOCATE(tmp)
    1121     RETURN 
     1178    RETURN
    11221179  END FUNCTION cp_get_rv_ve
    11231180
    … …  
    11261183    !!
    11271184    !! On error, the output vector is not allocated.
    1128     OBJECT(cfgparser), INTENT(in)                        :: this   !! Cfgparser object 
     1185    OBJECT(cfgparser), INTENT(in)                        :: this   !! Cfgparser object
    11291186    CHARACTER(len=*), INTENT(in)                         :: name   !! (Full) Name of the option to get
    11301187    REAL(kind=8), INTENT(out), DIMENSION(:), ALLOCATABLE :: output !! Output values
    1131     TYPE(error) :: err                                                 
     1188    TYPE(error) :: err
    11321189      !! Error status of the method (see [[cfgparser(type):get_value(bound)]] documentation)
    11331190    CHARACTER(len=st_slen), DIMENSION(:), ALLOCATABLE :: tmp
    … …  
    11531210        ELSE IF (.NOT.from_string(tmp(i), output(i))) THEN
    11541211          err = error("Cannot convert value #"//TRIM(i2s)//" from option "//TRIM(name),-10)
    1155           DEALLOCATE(output) ; EXIT 
     1212          DEALLOCATE(output) ; EXIT
    11561213        ENDIF
    11571214      ENDDO
    11581215    ENDIF
    11591216    DEALLOCATE(tmp)
    1160     RETURN 
     1217    RETURN
    11611218  END FUNCTION cp_get_dv_ve
    11621219
    … …  
    11651222    !!
    11661223    !! On error, the output vector is not allocated.
    1167     OBJECT(cfgparser), INTENT(in)                   :: this   !! Cfgparser object 
     1224    OBJECT(cfgparser), INTENT(in)                   :: this   !! Cfgparser object
    11681225    CHARACTER(len=*), INTENT(in)                    :: name   !! (Full) Name of the option to get
    11691226    INTEGER, INTENT(out), DIMENSION(:), ALLOCATABLE :: output !! Output values
    1170     TYPE(error) :: err                                                 
     1227    TYPE(error) :: err
    11711228      !! Error status of the method (see [[cfgparser(type):get_value(bound)]] documentation)
    11721229    CHARACTER(len=st_slen), DIMENSION(:), ALLOCATABLE :: tmp
    … …  
    11921249        ELSE IF (.NOT.from_string(tmp(i), output(i))) THEN
    11931250          err = error("Cannot convert value #"//TRIM(i2s)//" from option "//TRIM(name),-10)
    1194           DEALLOCATE(output) ; EXIT 
     1251          DEALLOCATE(output) ; EXIT
    11951252        ENDIF
    11961253      ENDDO
    11971254    ENDIF
    11981255    DEALLOCATE(tmp)
    1199     RETURN 
     1256    RETURN
    12001257  END FUNCTION cp_get_iv_ve
    12011258
    … …  
    12041261    !!
    12051262    !! On error, the output vector is not allocated.
    1206     OBJECT(cfgparser), INTENT(in)                   :: this   !! Cfgparser object 
     1263    OBJECT(cfgparser), INTENT(in)                   :: this   !! Cfgparser object
    12071264    CHARACTER(len=*), INTENT(in)                    :: name   !! (Full) Name of the option to get
    12081265    LOGICAL, INTENT(out), DIMENSION(:), ALLOCATABLE :: output !! Output values
    1209     TYPE(error) :: err                                                 
     1266    TYPE(error) :: err
    12101267      !! Error status of the method (see [[cfgparser(type):get_value(bound)]] documentation)
    12111268    CHARACTER(len=st_slen), DIMENSION(:), ALLOCATABLE :: tmp
    … …  
    12311288        ELSE IF (.NOT.from_string(tmp(i), output(i))) THEN
    12321289          err = error("Cannot convert value #"//TRIM(i2s)//" from option "//TRIM(name),-10)
    1233           DEALLOCATE(output) ; EXIT 
     1290          DEALLOCATE(output) ; EXIT
    12341291        ENDIF
    12351292      ENDDO
    12361293    ENDIF
    12371294    DEALLOCATE(tmp)
    1238     RETURN 
     1295    RETURN
    12391296  END FUNCTION cp_get_lv_ve
    12401297
    … …  
    12431300    !!
    12441301    !! On error, the output vector is not allocated.
    1245     OBJECT(cfgparser), INTENT(in)                   :: this   !! Cfgparser object 
     1302    OBJECT(cfgparser), INTENT(in)                   :: this   !! Cfgparser object
    12461303    CHARACTER(len=*), INTENT(in)                    :: name   !! (Full) Name of the option to get
    12471304    COMPLEX, INTENT(out), DIMENSION(:), ALLOCATABLE :: output !! Output values
    1248     TYPE(error) :: err                                                 
     1305    TYPE(error) :: err
    12491306      !! Error status of the method (see [[cfgparser(type):get_value(bound)]] documentation)
    12501307    CHARACTER(len=st_slen), DIMENSION(:), ALLOCATABLE :: tmp
    … …  
    12701327        ELSE IF (.NOT.from_string(tmp(i), output(i))) THEN
    12711328          err = error("Cannot convert value #"//TRIM(i2s)//" from option "//TRIM(name),-10)
    1272           DEALLOCATE(output) ; EXIT 
     1329          DEALLOCATE(output) ; EXIT
    12731330        ENDIF
    12741331      ENDDO
    12751332    ENDIF
    12761333    DEALLOCATE(tmp)
    1277     RETURN 
     1334    RETURN
    12781335  END FUNCTION cp_get_cv_ve
    12791336
    … …  
    12821339    !!
    12831340    !! On error, the output vector is not allocated.
    1284     OBJECT(cfgparser), INTENT(in)                            :: this   !! Cfgparser object 
     1341    OBJECT(cfgparser), INTENT(in)                            :: this   !! Cfgparser object
    12851342    CHARACTER(len=*), INTENT(in)                             :: name   !! (Full) Name of the option to get
    12861343    CHARACTER(len=*), INTENT(out), DIMENSION(:), ALLOCATABLE :: output !! Output values
    1287     TYPE(error) :: err                                                 
    1288       !! Error status of the method (see [[cfgparser(type):get_value(bound)]] documentation)
     1344    TYPE(error) :: err                                                 !! Error status of the method (see [[cfgparser(type):get_value(bound)]] documentation)
    12891345    LOGICAL :: ok
    12901346    INTEGER :: idx
    … …  
    13071363    !!
    13081364    !! If _create_ is given to .true., the method will add a new option if it does not exist in
    1309     !! the parser. 
    1310     !! In such case, an error (-6, invalid name) is raised if the option name is not valid.
     1365    !! the parser.
     1366    !! In such case, an error ((-9, invalid name)) is raised if the option name is not valid.
    13111367    !!
    13121368    !! In other case, if the option is not defined in the parser the error status is set to -7.
    1313     OBJECT(cfgparser), INTENT(inout) :: this   !! Cfgparser object 
     1369    OBJECT(cfgparser), INTENT(inout) :: this   !! Cfgparser object
    13141370    CHARACTER(len=*), INTENT(in)     :: name   !! (Full) Name of the option to set
    13151371    REAL(kind=4), INTENT(in)         :: input  !! Input value
    1316     LOGICAL, INTENT(in), OPTIONAL    :: create !! .true. to create option if it does not exist (default to false). 
     1372    LOGICAL, INTENT(in), OPTIONAL    :: create !! .true. to create option if it does not exist (default to false).
    13171373    TYPE(error)                      :: err    !! Error status
    13181374    LOGICAL                       :: zcreate
    1319     INTEGER                       :: idx 
     1375    INTEGER                       :: idx
    13201376    CHARACTER(len=:), ALLOCATABLE :: sname,pname
    13211377    TYPE(words) :: values
    … …  
    13321388      ENDIF
    13331389    ELSE
    1334       this%options(idx)%values = values 
     1390      this%options(idx)%values = values
    13351391    ENDIF
    13361392    CALL words_clear(values)
    … …  
    13411397    !!
    13421398    !! If _create_ is given to .true., the method will add a new option if it does not exist in
    1343     !! the parser. 
    1344     !! In such case, an error (-6, invalid name) is raised if the option name is not valid.
     1399    !! the parser.
     1400    !! In such case, an error ((-9, invalid name)) is raised if the option name is not valid.
    13451401    !!
    13461402    !! In other case, if the option is not defined in the parser the error status is set to -7.
    1347     OBJECT(cfgparser), INTENT(inout) :: this   !! Cfgparser object 
     1403    OBJECT(cfgparser), INTENT(inout) :: this   !! Cfgparser object
    13481404    CHARACTER(len=*), INTENT(in)     :: name   !! (Full) Name of the option to set
    13491405    REAL(kind=8), INTENT(in)         :: input  !! Input value
    1350     LOGICAL, INTENT(in), OPTIONAL    :: create !! .true. to create option if it does not exist (default to false). 
     1406    LOGICAL, INTENT(in), OPTIONAL    :: create !! .true. to create option if it does not exist (default to false).
    13511407    TYPE(error)                      :: err    !! Error status
    13521408    LOGICAL                       :: zcreate
    1353     INTEGER                       :: idx 
     1409    INTEGER                       :: idx
    13541410    CHARACTER(len=:), ALLOCATABLE :: sname,pname
    13551411    TYPE(words) :: values
    … …  
    13661422      ENDIF
    13671423    ELSE
    1368       this%options(idx)%values = values 
     1424      this%options(idx)%values = values
    13691425    ENDIF
    13701426    CALL words_clear(values)
    … …  
    13761432    !! If _create_ is given to .true., the method will add a new option if it does not exist in
    13771433    !! the parser.
    1378     !! In such case, an error (-6, invalid name) is raised if the option name is not valid.
     1434    !! In such case, an error ((-9, invalid name)) is raised if the option name is not valid.
    13791435    !!
    13801436    !! In other case, if the option is not defined in the parser the error status is set to -7.
    1381     OBJECT(cfgparser), INTENT(inout) :: this   !! Cfgparser object 
     1437    OBJECT(cfgparser), INTENT(inout) :: this   !! Cfgparser object
    13821438    CHARACTER(len=*), INTENT(in)     :: name   !! (Full) Name of the option to set
    13831439    INTEGER, INTENT(in)              :: input  !! Input value
    1384     LOGICAL, INTENT(in), OPTIONAL    :: create !! .true. to create option if it does not exist (default to false). 
     1440    LOGICAL, INTENT(in), OPTIONAL    :: create !! .true. to create option if it does not exist (default to false).
    13851441    TYPE(error)                      :: err    !! Error status
    13861442    LOGICAL                       :: zcreate
    1387     INTEGER                       :: idx 
     1443    INTEGER                       :: idx
    13881444    CHARACTER(len=:), ALLOCATABLE :: sname,pname
    13891445    TYPE(words) :: values
    … …  
    13951451      IF (zcreate) THEN
    13961452        err = op_split_name(name,sname,pname)
    1397         !IF (err == 0) err = cp_add_opt(this,sname,pname,values)
    1398         err = cp_add_opt(this,sname,pname,values)
     1453        IF (err == 0) err = cp_add_opt(this,sname,pname,values)
    13991454      ELSE
    14001455        err = error("Option "//TRIM(name)//" does not exist",-7)
    14011456      ENDIF
    14021457    ELSE
    1403       this%options(idx)%values = values 
     1458      this%options(idx)%values = values
    14041459    ENDIF
    14051460    CALL words_clear(values)
    … …  
    14111466    !! If _create_ is given to .true., the method will add a new option if it does not exist in
    14121467    !! the parser.
    1413     !! In such case, an error (-6, invalid name) is raised if the option name is not valid.
     1468    !! In such case, an error ((-9, invalid name)) is raised if the option name is not valid.
    14141469    !!
    14151470    !! In other case, if the option is not defined in the parser the error status is set to -7.
    1416     OBJECT(cfgparser), INTENT(inout) :: this   !! Cfgparser object 
     1471    OBJECT(cfgparser), INTENT(inout) :: this   !! Cfgparser object
    14171472    CHARACTER(len=*), INTENT(in)     :: name   !! (Full) Name of the option to set
    14181473    LOGICAL, INTENT(in)              :: input  !! Input value
    1419     LOGICAL, INTENT(in), OPTIONAL    :: create !! .true. to create option if it does not exist (default to false). 
     1474    LOGICAL, INTENT(in), OPTIONAL    :: create !! .true. to create option if it does not exist (default to false).
    14201475    TYPE(error)                      :: err    !! Error status
    14211476    LOGICAL                       :: zcreate
    1422     INTEGER                       :: idx 
     1477    INTEGER                       :: idx
    14231478    CHARACTER(len=:), ALLOCATABLE :: sname,pname
    14241479    TYPE(words) :: values
    … …  
    14351490      ENDIF
    14361491    ELSE
    1437       this%options(idx)%values = values 
     1492      this%options(idx)%values = values
    14381493    ENDIF
    14391494    CALL words_clear(values)
    … …  
    14451500    !! If _create_ is given to .true., the method will add a new option if it does not exist in
    14461501    !! the parser.
    1447     !! In such case, an error (-6, invalid name) is raised if the option name is not valid.
     1502    !! In such case, an error ((-9, invalid name)) is raised if the option name is not valid.
    14481503    !!
    14491504    !! In other case, if the option is not defined in the parser the error status is set to -7.
    1450     OBJECT(cfgparser), INTENT(inout) :: this   !! Cfgparser object 
     1505    OBJECT(cfgparser), INTENT(inout) :: this   !! Cfgparser object
    14511506    CHARACTER(len=*), INTENT(in)     :: name   !! (Full) Name of the option to set
    14521507    COMPLEX, INTENT(in)              :: input  !! Input value
    1453     LOGICAL, INTENT(in), OPTIONAL    :: create !! .true. to create option if it does not exist (default to false). 
     1508    LOGICAL, INTENT(in), OPTIONAL    :: create !! .true. to create option if it does not exist (default to false).
    14541509    TYPE(error)                      :: err    !! Error status
    14551510    LOGICAL                       :: zcreate
    1456     INTEGER                       :: idx 
     1511    INTEGER                       :: idx
    14571512    CHARACTER(len=:), ALLOCATABLE :: sname,pname
    14581513    TYPE(words) :: values
    … …  
    14691524      ENDIF
    14701525    ELSE
    1471       this%options(idx)%values = values 
     1526      this%options(idx)%values = values
    14721527    ENDIF
    14731528    CALL words_clear(values)
    … …  
    14791534    !! If _create_ is given to .true., the method will add a new option if it does not exist in
    14801535    !! the parser.
    1481     !! In such case, an error (-6, invalid name) is raised if the option name is not valid.
     1536    !! In such case, an error ((-9, invalid name)) is raised if the option name is not valid.
    14821537    !!
    14831538    !! In other case, if the option is not defined in the parser the error status is set to -7.
    1484     OBJECT(cfgparser), INTENT(inout) :: this   !! Cfgparser object 
     1539    OBJECT(cfgparser), INTENT(inout) :: this   !! Cfgparser object
    14851540    CHARACTER(len=*), INTENT(in)     :: name   !! (Full) Name of the option to set
    14861541    CHARACTER(len=*), INTENT(in)     :: input  !! Input value
    1487     LOGICAL, INTENT(in), OPTIONAL    :: create !! .true. to create option if it does not exist (default to false). 
     1542    LOGICAL, INTENT(in), OPTIONAL    :: create !! .true. to create option if it does not exist (default to false).
    14881543    TYPE(error)                      :: err    !! Error status
    14891544    LOGICAL                       :: zcreate
    1490     INTEGER                       :: idx 
     1545    INTEGER                       :: idx
    14911546    CHARACTER(len=:), ALLOCATABLE :: sname,pname
    14921547    TYPE(words) :: values
    … …  
    15031558      ENDIF
    15041559    ELSE
    1505       this%options(idx)%values = values 
     1560      this%options(idx)%values = values
    15061561    ENDIF
    15071562    CALL words_clear(values)
    … …  
    15121567    !!
    15131568    !! If _create_ is given to .true., the method will add a new option if it does not exist in
    1514     !! the parser. 
    1515     !! In such case, an error (-6, invalid name) is raised if the option name is not valid.
     1569    !! the parser.
     1570    !! In such case, an error ((-9, invalid name)) is raised if the option name is not valid.
    15161571    !!
    15171572    !! In other case, if the option is not defined in the parser the error status is set to -7.
    1518     OBJECT(cfgparser), INTENT(inout)       :: this   !! Cfgparser object 
     1573    OBJECT(cfgparser), INTENT(inout)       :: this   !! Cfgparser object
    15191574    CHARACTER(len=*), INTENT(in)           :: name   !! (Full) Name of the option to get
    15201575    REAL(kind=4), INTENT(in), DIMENSION(:) :: input  !! Input values
    … …  
    15371592      ENDIF
    15381593    ELSE
    1539       this%options(idx)%values = values 
     1594      this%options(idx)%values = values
    15401595    ENDIF
    15411596    CALL words_clear(values)
    … …  
    15471602    !! If _create_ is given to .true., the method will add a new option if it does not exist in
    15481603    !! the parser.
    1549     !! In such case, an error (-6, invalid name) is raised if the option name is not valid.
     1604    !! In such case, an error ((-9, invalid name)) is raised if the option name is not valid.
    15501605    !!
    15511606    !! In other case, if the option is not defined in the parser the error status is set to -7.
    1552     OBJECT(cfgparser), INTENT(inout)       :: this   !! Cfgparser object 
     1607    OBJECT(cfgparser), INTENT(inout)       :: this   !! Cfgparser object
    15531608    CHARACTER(len=*), INTENT(in)           :: name   !! (Full) Name of the option to get
    15541609    REAL(kind=8), INTENT(in), DIMENSION(:) :: input  !! Input values
    … …  
    15711626      ENDIF
    15721627    ELSE
    1573       this%options(idx)%values = values 
     1628      this%options(idx)%values = values
    15741629    ENDIF
    15751630    CALL words_clear(values)
    … …  
    15801635    !!
    15811636    !! If _create_ is given to .true., the method will add a new option if it does not exist in
    1582     !! the parser. 
    1583     !! In such case, an error (-6, invalid name) is raised if the option name is not valid.
     1637    !! the parser.
     1638    !! In such case, an error ((-9, invalid name)) is raised if the option name is not valid.
    15841639    !!
    15851640    !! In other case, if the option is not defined in the parser the error status is set to -7.
    1586     OBJECT(cfgparser), INTENT(inout)  :: this   !! Cfgparser object 
     1641    OBJECT(cfgparser), INTENT(inout)  :: this   !! Cfgparser object
    15871642    CHARACTER(len=*), INTENT(in)      :: name   !! (Full) Name of the option to get
    15881643    INTEGER, INTENT(in), DIMENSION(:) :: input  !! Input values
    … …  
    16051660      ENDIF
    16061661    ELSE
    1607       this%options(idx)%values = values 
     1662      this%options(idx)%values = values
    16081663    ENDIF
    16091664    CALL words_clear(values)
    … …  
    16151670    !! If _create_ is given to .true., the method will add a new option if it does not exist in
    16161671    !! the parser.
    1617     !! In such case, an error (-6, invalid name) is raised if the option name is not valid.
     1672    !! In such case, an error ((-9, invalid name)) is raised if the option name is not valid.
    16181673    !!
    16191674    !! In other case, if the option is not defined in the parser the error status is set to -7.
    1620     OBJECT(cfgparser), INTENT(inout)  :: this   !! Cfgparser object 
     1675    OBJECT(cfgparser), INTENT(inout)  :: this   !! Cfgparser object
    16211676    CHARACTER(len=*), INTENT(in)      :: name   !! (Full) Name of the option to get
    16221677    LOGICAL, INTENT(in), DIMENSION(:) :: input  !! Input values
    … …  
    16391694      ENDIF
    16401695    ELSE
    1641       this%options(idx)%values = values 
     1696      this%options(idx)%values = values
    16421697    ENDIF
    16431698    CALL words_clear(values)
    … …  
    16481703    !!
    16491704    !! If _create_ is given to .true., the method will add a new option if it does not exist in
    1650     !! the parser. 
    1651     !! In such case, an error (-6, invalid name) is raised if the option name is not valid.
     1705    !! the parser.
     1706    !! In such case, an error ((-9, invalid name)) is raised if the option name is not valid.
    16521707    !!
    16531708    !! In other case, if the option is not defined in the parser the error status is set to -7.
    1654     OBJECT(cfgparser), INTENT(inout)  :: this   !! Cfgparser object 
     1709    OBJECT(cfgparser), INTENT(inout)  :: this   !! Cfgparser object
    16551710    CHARACTER(len=*), INTENT(in)      :: name   !! (Full) Name of the option to get
    16561711    COMPLEX, INTENT(in), DIMENSION(:) :: input  !! Input values
    … …  
    16731728      ENDIF
    16741729    ELSE
    1675       this%options(idx)%values = values 
     1730      this%options(idx)%values = values
    16761731    ENDIF
    16771732    CALL words_clear(values)
    … …  
    16831738    !! If _create_ is given to .true., the method will add a new option if it does not exist in
    16841739    !! the parser.
    1685     !! In such case, an error (-6, invalid name) is raised if the option name is not valid.
     1740    !! In such case, an error ((-9, invalid name)) is raised if the option name is not valid.
    16861741    !!
    16871742    !! In other case, if the option is not defined in the parser the error status is set to -7.
    1688     OBJECT(cfgparser), INTENT(inout)           :: this   !! Cfgparser object 
     1743    OBJECT(cfgparser), INTENT(inout)           :: this   !! Cfgparser object
    16891744    CHARACTER(len=*), INTENT(in)               :: name   !! (Full) Name of the option to get
    16901745    CHARACTER(len=*), INTENT(in), DIMENSION(:) :: input  !! Input values
    … …  
    17071762      ENDIF
    17081763    ELSE
    1709       this%options(idx)%values = values 
     1764      this%options(idx)%values = values
    17101765    ENDIF
    17111766    CALL words_clear(values)
    … …  
    17341789    LOGICAL                       :: zoverride,ok,has_opt
    17351790    INTEGER                       :: lineno,lu,i
    1736     CHARACTER(len=2), PARAMETER   :: space = CHAR(32)//","    ! check if , is really wanted..
     1791    CHARACTER(len=2), PARAMETER   :: space = CHAR(32)//","    ! check if , is really wanted... A: YES space are the delimiter of the words internal object !
    17371792    CHARACTER(len=2), PARAMETER   :: blanks = CHAR(9)//CHAR(32) ! currently not used because blanks truncate.
    17381793    CHARACTER(len=15)             :: sln
    … …  
    17461801    zoverride = .false. ; IF (PRESENT(override)) zoverride = override
    17471802    ! initialize local variables
    1748     curval = '' ; line   = '' ; name  = '' ; value = '' 
    1749     lineno = 0  ; lu = free_lun() 
     1803    curval = '' ; line   = '' ; name  = '' ; value = ''
     1804    lineno = 0  ; lu = free_lun()
    17501805    IF (LEN_TRIM(isec) == 0) isec = "__default__"
    17511806    i = INDEX(TRIM(path),"/",.true.)
    1752     IF (i == 0) THEN 
     1807    IF (i == 0) THEN
    17531808      fulp = fs_realpath("./"//TRIM(ADJUSTL(path)))
    17541809    ELSE
    … …  
    17631818      RETURN
    17641819    ENDIF
    1765     ! check for lun 
     1820    ! check for lun
    17661821    IF (lu == -1) THEN ; err = error("No available logical unit",-12) ; RETURN ; ENDIF
    17671822    OPEN(lu,FILE=TRIM(path),STATUS='old',ACTION='READ')
    … …  
    17751830          ! 1) get relative path
    17761831          ipath = fs_relpath(ipath,dirp)
    1777           ! 2) compute asbolute path)
     1832          ! 2) compute asbolute path
    17781833          ipath = TRIM(dirp)//"/"//TRIM(ipath)
    17791834          ipath = fs_realpath(ipath)
    … …  
    17931848            CALL op_clear(curopt); curval = ''
    17941849          ENDIF
    1795           err = read_include(parser,ipath,isec,ipaths,zoverride) 
     1850          err = read_include(parser,ipath,isec,ipaths,zoverride)
    17961851          IF (err /= 0) EXIT
    17971852        ENDIF
    … …  
    17991854      ENDIF
    18001855      ! continuation line ?
    1801       IF (SCAN(line(1:1),blanks) /= 0 .AND. op_valid(curopt)) THEN 
     1856      IF (SCAN(line(1:1),blanks) /= 0 .AND. op_valid(curopt)) THEN
    18021857          IF (LEN(curval) == 0) THEN
    18031858            curval = strip_comment(line)
    … …  
    18061861          ENDIF
    18071862      ELSE
    1808        ! 1. Remove comment part and left adjust line 
     1863       ! 1. Remove comment part and left adjust line
    18091864       line = strip_comment(line)
    18101865       ! a section header or option header?
    … …  
    18371892           ! 3. curval is set to value
    18381893           ! 4. update curval
    1839            IF (op_valid(curopt)) THEN 
     1894           IF (op_valid(curopt)) THEN
    18401895              IF (LEN(curval) > 0) &
    18411896              CALL words_extend(curopt%values,TRIM(ADJUSTL(curval)),space,.true.,.true.)
    … …  
    18471902           ENDIF
    18481903           CALL op_clear(curopt) ; curval = ''
    1849            has_opt = cfg_has_option(parser,TRIM(isec)//"/"//TRIM(name)) 
     1904           has_opt = cfg_has_option(parser,TRIM(isec)//"/"//TRIM(name))
    18501905
    18511906           IF (has_opt.AND..NOT.zoverride) THEN
    1852              ! it is an error: no duplicate allowed 
     1907             ! it is an error: no duplicate allowed
    18531908             err = error(basp//'(L'//TRIM(sln)//"): Duplicate option '"//TRIM(name)//"' in "//isec,-8)
    18541909             EXIT
    … …  
    18591914           curval = value
    18601915         CASE(cfg_UNKNOWN)
    1861            ! unknown handles also invalid name: it is a critical error 
     1916           ! unknown handles also invalid name: it is a critical error
    18621917           IF (err == -9) EXIT
    1863        END SELECT 
     1918       END SELECT
    18641919      ENDIF
    18651920    ENDDO
    1866     IF (op_valid(curopt)) THEN 
     1921    IF (op_valid(curopt)) THEN
    18671922      IF (LEN(curval) > 0) &
    18681923      CALL words_extend(curopt%values,TRIM(ADJUSTL(curval)),space,.true.,.true.)
    … …  
    18861941      !!   it is a section header.
    18871942      !! - Otherwise, if line has '=', without '#' before '=', it is an option.
    1888       !! 
    1889       !! Then the method returns an integer with the kind flag of the statement which is one of 
     1943      !!
     1944      !! Then the method returns an integer with the kind flag of the statement which is one of
    18901945      !! -1 (cfg_UNKNOWN), 0 (cfg_SECTION) or 1 (cfg_OPTION).
    18911946      CHARACTER(len=*), INTENT(in)               :: string  !! Input string to process
    … …  
    18981953      kind = cfg_UNKNOWN
    18991954      ! get a trimmed (and left adjusted) copy
    1900       copy = TRIM(string) 
     1955      copy = TRIM(string)
    19011956      ! Is it a section ?
    19021957      !   ---> search for subscripts of '[' and ']'
    19031958      !   ---> check that '[' is 1st char and ']' is last char
    1904       bi = INDEX(copy,'[') ; ei = INDEX(copy,']') 
     1959      bi = INDEX(copy,'[') ; ei = INDEX(copy,']')
    19051960      IF (bi == 1 .AND. ei == LEN(copy) .AND. bi < ei) THEN
    19061961        ! it is a section header
    19071962        kind = cfg_SECTION
    19081963        ! get section name: adjust and trim to remove extra blank spaces
    1909         name = str_to_lower(TRIM(ADJUSTL(copy(bi+1:ei-1))))
    1910         IF (TRIM(name) /= "__default__" .AND. .NOT.cfg_check_name(name)) THEN
     1964        name = TRIM(ADJUSTL(copy(bi+1:ei-1)))
     1965        ! hack cfg_check_name: append '/a' to get a valid option part to test
     1966        IF (TRIM(name) /= "__default__" .AND. .NOT.cfg_check_name(name//"/a")) THEN
    19111967          kind = cfg_UNKNOWN
    19121968          err = error("Invalid section name ("//name//")",-9)
    … …  
    19161972      ELSE
    19171973        ! Is it an option ?
    1918         !   --> search for '=' and check if it is set before 
     1974        !   --> search for '=' and check if it is set before
    19191975        !       1st quote (if any)
    1920         bi = INDEX(copy,"=") 
     1976        bi = INDEX(copy,"=")
    19211977        ! search for quotes
    19221978        ei = SCAN(copy,quotes) ; IF (ei==0) ei = LEN(copy)+1
    19231979        IF (bi /= 0 .AND. bi < ei) THEN
    19241980          kind = cfg_OPTION
    1925           name = str_to_lower(TRIM(copy(1:bi-1)))
    1926           IF (.NOT.cfg_check_name(name)) THEN 
     1981          name = to_lower(TRIM(copy(1:bi-1)))
     1982          IF (.NOT.cfg_check_name(name)) THEN
    19271983            kind = cfg_UNKNOWN
    19281984            err = error("Invalid option name ("//TRIM(name)//")",-9)
    … …  
    19442000    FUNCTION strip_comment(line) RESULT(stripped)
    19452001      !! Replace comments part of a string by blank spaces
    1946       !! The method replaces every characters after '#' (included) by spaces. 
    1947       !! @note 
     2002      !! The method replaces every characters after '#' (included) by spaces.
     2003      !! @note
    19482004      !! Output string is also left adjusted, thus only trailing blank can be present.
    19492005      CHARACTER(len=*), INTENT(in) :: line !! A string to process
    19502006      CHARACTER(len=LEN(line)) :: stripped !! A string of same length than 'line' but without comment(s)
    1951      
     2007
    19522008      INTEGER :: idx
    19532009      stripped = ADJUSTL(line)
    … …  
    19602016      !! Read a complete line
    19612017      !!
    1962       !! Each time it is CALLed, the function reads a complete of the file opened in 'lun' logical 
     2018      !! Each time it is CALLed, the function reads a complete of the file opened in 'lun' logical
    19632019      !! unit and returns .false. if EOF has been reached, .true. otherwise.
    19642020      !!
    19652021      !! The function is intended to read a file line by line:
    1966       !! 
    1967       !! ```fortran
     2022      !!
     2023      !! ```
    19682024      !! lu = 1
    19692025      !! open(lu,file="path/to/the/file/to/read")
    … …  
    19752031      !! CLOSE(1)
    19762032      !! ```
    1977       INTEGER, INTENT(in)                        :: lun     !! Logical unit with the opened file to read. 
    1978       CHARACTER(len=:), INTENT(out), ALLOCATABLE :: string  !! Output processed line 
     2033      INTEGER, INTENT(in)                        :: lun     !! Logical unit with the opened file to read.
     2034      CHARACTER(len=:), INTENT(out), ALLOCATABLE :: string  !! Output processed line
    19792035      LOGICAL                                    :: not_eof !! .true. if EOF has NOT been reached yet, .false. otherwise
    19802036      CHARACTER(len=50) :: buf
    19812037      INTEGER           :: e,sz
    1982       not_eof = .true. ; string = '' 
     2038      not_eof = .true. ; string = ''
    19832039      DO
    19842040        READ(lun,'(a)',ADVANCE="no",SIZE=sz,IOSTAT=e) buf
    … …  
    20062062      CHARACTER(len=:), INTENT(out), ALLOCATABLE :: incpath
    20072063        !! A string with the filepath to be included if '#include' statement is found, empty string otherwise
    2008       LOGICAL :: res 
     2064      LOGICAL :: res
    20092065        !! .true. if line is a comment or an empty string, .false. otherwise
    20102066      CHARACTER(len=:), ALLOCATABLE :: copy
    … …  
    20172073        ! search for include statement
    20182074        ! IMPORTANT: assume that there is only a path after include statement
    2019         IF (INDEX(copy,"#include ") == 1) incpath = TRIM(ADJUSTL(copy(10:)))
     2075        IF (INDEX(copy,"#include ") == 1) incpath = remove_quotes(TRIM(ADJUSTL(copy(10:))))
    20202076      ENDIF
    20212077      RETURN
    … …  
    20462102  SUBROUTINE insertionSort(opts)
    20472103    !! Sort an array of Options using insertion sort algorithm
    2048     TYPE(option), INTENT(inout), DIMENSION(:) :: opts !! Array to sort. 
     2104    TYPE(option), INTENT(inout), DIMENSION(:) :: opts !! Array to sort.
    20492105    TYPE(option) :: temp
    20502106    INTEGER :: i, j
    … …  
    20582114        ELSE
    20592115          EXIT
    2060         ENDIF 
     2116        ENDIF
    20612117      ENDDO
    20622118      opts(j+1) = temp
    … …  
    20652121  END SUBROUTINE insertionSort
    20662122
    2067   FUNCTION free_lun() RESULT(lu)
    2068     !> Get the first free logical unit
    2069     !!
    2070     !! The function loops from 7 to 9999 and returns the first free logical unit.
    2071     !! @note
    2072     !! According to Fortran standard, the maximum value for a lun is processor
    2073     !! dependent. I just assume that [7,9999] is a valid range and I believe that
    2074     !! 9992 files to be opened is far enough for any program !
    2075     !! @note
    2076     !! If you intend to use loggers object from this library, you should keep in
    2077     !! mind that loggers open files with the first free logical unit. Consequently
    2078     !! if you need to perform I/O operations you should use this function to get a
    2079     !! free lun instead of just randomly set a lun !
    2080     INTEGER :: lu
    2081       !! First free logical unit in the range [7,999]  or -1 if no lun is available
    2082     INTEGER, PARAMETER :: mxlu = 9999
    2083     LOGICAL :: notfree
    2084     lu = 6 ; notfree = .true.
    2085     DO WHILE(notfree.AND.lu<=mxlu)
    2086       lu=lu+1 ; INQUIRE(unit=lu,OPENED=notfree)
    2087     ENDDO
    2088     IF (lu >= mxlu) lu = -1
    2089   END FUNCTION free_lun
    2090 
    20912123END MODULE CFGPARSE
    20922124

  • trunk/LMDZ.TITAN/libf/muphytitan/csystem.c

    r1793 r1897  
    1 /* Copyright Jérémie Burgalat (2010-2015)
    2  *
    3  * burgalat.jeremie@gmail.com
     1/* Copyright Jérémie Burgalat (2010-2015,2017)
     2 *
     3 * jeremie.burgalat@univ-reims.fr
    44 *
    55 * This software is a computer program whose purpose is to provide configuration
    … …  
    3838#include <stdio.h>
    3939#include <limits.h>
     40#include <string.h>
    4041#include <libgen.h>
    4142#include <sys/param.h>  // MAXPATHLEN
    … …  
    4950#include <time.h>
    5051#include <unistd.h>
    51 
    5252#include "csystem.h"
    5353
    … …  
    270270}
    271271
     272
     273int c_copy(const char *to, const char *from) {
     274  int fd_to, fd_from;
     275  char buf[4096];
     276  ssize_t nread;
     277  int saved_errno;
     278
     279  fd_from = open(from, O_RDONLY);
     280  if (fd_from < 0)
     281    return -1;
     282
     283  fd_to = open(to, O_WRONLY | O_CREAT | O_EXCL, 0666);
     284  if (fd_to < 0)
     285    goto out_error;
     286
     287  while (nread = read(fd_from, buf, sizeof buf), nread > 0) {
     288    char *out_ptr = buf;
     289    ssize_t nwritten;
     290
     291    do {
     292      nwritten = write(fd_to, out_ptr, nread);
     293
     294      if (nwritten >= 0) {
     295        nread -= nwritten;
     296        out_ptr += nwritten;
     297      } else if (errno != EINTR) {
     298        goto out_error;
     299      }
     300    } while (nread > 0);
     301  }
     302
     303  if (nread == 0) {
     304    if (close(fd_to) < 0) {
     305      fd_to = -1;
     306      goto out_error;
     307    }
     308    close(fd_from);
     309    /* Success! */
     310    return 0;
     311  }
     312
     313out_error:
     314  saved_errno = errno;
     315
     316  close(fd_from);
     317  if (fd_to >= 0)
     318    close(fd_to);
     319
     320  errno = saved_errno;
     321  return 1;
     322}
     323
    272324/* Remove file from filesytem */
    273325int c_remove(const char *path){
    … …  
    490542}
    491543
    492 /* This verison of realpath was a dumb attempt to get a resolved path
    493  * that may not exist. As a matter of fact, it cannot cover all range
    494  * of possibilities.
    495  * Thus it has been removed. The current verison of c_realpath simply
    496  * uses POSIX realpath and returns CWD if no path is given...
     544/*
     545 * Author:  David Robert Nadeau
     546 * Site:    http://NadeauSoftware.com/
     547 * License: Creative Commons Attribution 3.0 Unported License
     548 *          http://creativecommons.org/licenses/by/3.0/deed.en_US
     549 *
     550 * Cross-plateform way to get memory usage at a given time in fucking bytes !!
     551 *
     552 * Usage:
     553 *
     554 * size_t currentSize = getCurrentRSS( );
     555 * size_t peakSize    = getPeakRSS( );
    497556 */
    498557
    499 /* Get the realpath of input path and saves it in output path */
    500 /*
    501 char* c_realpath(const char *input){
    502   char *in,*output, *cur,*tmp,*res,*cwd ;
    503   int c,om,rm,im;
    504   output = NULL;
    505   cwd = c_getcwd();
    506   if(!strlen(input))
    507     return cwd;
    508   // check (ugly) if path is absolute
    509   if (input[0] == '/') {
    510     in = strdup(input);
    511   }else{
    512     fprintf(stderr,"+++ C( in): %s\n",input);
    513     in = malloc((strlen(input)+strlen(cwd)+2)*sizeof(char));
    514     strncpy(in, cwd, strlen(cwd));
    515     strncpy(&in[strlen(cwd)+1], input, strlen(input));
    516     in[strlen(cwd)] = '/';
    517     in[strlen(input)+strlen(cwd)+1] = '\0';
    518   }
    519   fprintf(stderr,"C( in): %s\n",in);
    520   c = om = im = strlen(in);
    521   tmp = malloc((c+1)*sizeof(char));
    522   tmp[c] ='\0';
    523   // search for the deepest existing directory in "input" path
    524   while(c != 0 && (res = realpath(tmp,NULL)) == NULL){
    525     // search for the next / from the right (i.e. parent directory)
    526     for (cur=tmp+strlen(tmp) ; *cur != '/' && cur != tmp ; cur--, c--);
    527     free(tmp) ; tmp = malloc((c+1)*sizeof(char));
    528     strncpy(tmp, in, c); tmp[c] ='\0';
    529   }
    530   free(tmp);
    531   // On error: null string
    532   if (c == 0 || (res==NULL)) {
    533     output = (char *)malloc(sizeof(char));
    534     output[0]='\0';
    535     return output;
    536   }
    537   // no error: allocate output string
    538   rm = strlen(res);
    539   om += rm-c;
    540   output = (char *)malloc(om*sizeof(char));
    541   strncpy(output,res,rm);
    542   // Here we could have a bug:
    543   //    If the path does not exist and contains .. or . references after the deepest
    544   //    existing directory, it will simply be appended !
    545   //    Thus we can never resolve the path.
    546   if (c != im)
    547     strncpy(output+rm,in+c,im-c);
    548     //strncpy(output+rm,in+c,im-c-1);
    549   output[om] = '\0';
    550   fprintf(stderr,"C(tmp): %s\n",res);
    551   fprintf(stderr,"C(out): %s\n",output);
    552   free(res) ;
    553   return output;
    554 }
    555 */
     558#if defined(_WIN32)
     559#include <windows.h>
     560#include <psapi.h>
     561#elif defined(__unix__) || defined(__unix) || defined(unix) || (defined(__APPLE__) && defined(__MACH__))
     562#include <sys/resource.h>
     563#if defined(__APPLE__) && defined(__MACH__)
     564#include <mach/mach.h>
     565#elif(defined(_AIX) || defined(__TOS__AIX__)) ||                                                                               \
     566    (defined(__sun__) || defined(__sun) || defined(sun) && (defined(__SVR4) || defined(__svr4__)))
     567#include <procfs.h>
     568#endif
     569#endif
     570
     571/**
     572 * Returns the peak (maximum so far) resident set size (physical
     573 * memory use) measured in bytes, or zero if the value cannot be
     574 * determined on this OS.
     575 */
     576size_t c_getPeakRSS() {
     577#if defined(_WIN32)
     578    /* Windows -------------------------------------------------- */
     579    PROCESS_MEMORY_COUNTERS info;
     580    GetProcessMemoryInfo(GetCurrentProcess(), &info, sizeof(info));
     581    return (size_t)info.PeakWorkingSetSize;
     582
     583#elif(defined(_AIX) || defined(__TOS__AIX__)) ||                                                                               \
     584    (defined(__sun__) || defined(__sun) || defined(sun) && (defined(__SVR4) || defined(__svr4__)))
     585    /* AIX and Solaris ------------------------------------------ */
     586    struct psinfo psinfo;
     587    int fd = -1;
     588    if ((fd = open("/proc/self/psinfo", O_RDONLY)) == -1)
     589        return (size_t)0L; /* Can't open? */
     590    if (read(fd, &psinfo, sizeof(psinfo)) != sizeof(psinfo)) {
     591        close(fd);
     592        return (size_t)0L; /* Can't read? */
     593    }
     594    close(fd);
     595    return (size_t)(psinfo.pr_rssize * 1024L);
     596
     597#elif defined(__unix__) || defined(__unix) || defined(unix) || (defined(__APPLE__) && defined(__MACH__))
     598    /* BSD, Linux, and OSX -------------------------------------- */
     599    struct rusage rusage;
     600    getrusage(RUSAGE_SELF, &rusage);
     601#if defined(__APPLE__) && defined(__MACH__)
     602    return (size_t)rusage.ru_maxrss;
     603#else
     604    return (size_t)(rusage.ru_maxrss * 1024L);
     605#endif
     606
     607#else
     608    /* Unknown OS ----------------------------------------------- */
     609    return (size_t)0L; /* Unsupported. */
     610#endif
     611}
     612
     613/**
     614 * Returns the current resident set size (physical memory use) measured
     615 * in bytes, or zero if the value cannot be determined on this OS.
     616 */
     617size_t c_getCurrentRSS() {
     618#if defined(_WIN32)
     619    /* Windows -------------------------------------------------- */
     620    PROCESS_MEMORY_COUNTERS info;
     621    GetProcessMemoryInfo(GetCurrentProcess(), &info, sizeof(info));
     622    return (size_t)info.WorkingSetSize;
     623
     624#elif defined(__APPLE__) && defined(__MACH__)
     625    /* OSX ------------------------------------------------------ */
     626    struct mach_task_basic_info info;
     627    mach_msg_type_number_t infoCount = MACH_TASK_BASIC_INFO_COUNT;
     628    if (task_info(mach_task_self(), MACH_TASK_BASIC_INFO, (task_info_t)&info, &infoCount) != KERN_SUCCESS)
     629        return (size_t)0L; /* Can't access? */
     630    return (size_t)info.resident_size;
     631
     632#elif defined(__linux__) || defined(__linux) || defined(linux) || defined(__gnu_linux__)
     633    /* Linux ---------------------------------------------------- */
     634    long rss = 0L;
     635    FILE *fp = NULL;
     636    if ((fp = fopen("/proc/self/statm", "r")) == NULL)
     637        return (size_t)0L; /* Can't open? */
     638    if (fscanf(fp, "%*s%ld", &rss) != 1) {
     639        fclose(fp);
     640        return (size_t)0L; /* Can't read? */
     641    }
     642    fclose(fp);
     643    return (size_t)rss * (size_t)sysconf(_SC_PAGESIZE);
     644
     645#else
     646    /* AIX, BSD, Solaris, and Unknown OS ------------------------ */
     647    return (size_t)0L; /* Unsupported. */
     648#endif
     649}
     650
     651
     652 
     653/* Get some informatiosn about the OS memory usage (from /proc/meminfo) */
     654int c_getSystemMemory(long long int *m_total,long long int *m_available,long long int *m_free){
     655    FILE* fp;
     656    char buf[1024];
     657    char *tmp,*p;
     658    int ts;
     659    long long int mem1 = 0L,mem2 = 0L,mem3 = 0L;
     660    if (m_total) (*m_total) = mem1;
     661    if (m_available) (*m_free) = mem2;
     662    if (m_free) (*m_free) = mem3;
     663    if ((fp = fopen("/proc/meminfo", "r")) == NULL) 
     664        return 1;
     665    while (fgets(buf, sizeof(buf), fp) != NULL){
     666        ts = strlen(buf) - 1; buf[ts] = '\0';
     667        tmp = strndup(&buf[0],ts);
     668        // check our 3 cases
     669        if (ts >= 9 && !strncmp(tmp,"MemTotal:",9)){
     670            // extract the two first tokens.
     671            p=strtok(tmp, " "); p=strtok(NULL, " ");
     672            // convert the value.
     673            mem1 = strtoll(p,NULL,10);
     674        }
     675        if (ts >= 13 && !strncmp(tmp,"MemAvailable:",13)){
     676            p=strtok(tmp, " "); p=strtok(NULL, " ");
     677            mem2 = strtoll(p,NULL,10);
     678        }   
     679        if (ts >= 8 && !strncmp(tmp,"MemFree:",8)){
     680            p=strtok(tmp, " "); p=strtok(NULL, " ");
     681            mem3 = strtoll(p,NULL,10);
     682        }
     683        free(tmp);
     684    }
     685    fclose(fp);
     686    if (m_total) (*m_total) = mem1;
     687    if (m_available) (*m_available) = mem2;
     688    if (m_free) (*m_free) = mem3;
     689    return 0;
     690}

  • trunk/LMDZ.TITAN/libf/muphytitan/csystem.h

    r1793 r1897  
    1 /* Copyright Jérémie Burgalat (2010-2015)
    2  *
    3  * burgalat.jeremie@gmail.com
     1/* Copyright Jérémie Burgalat (2010-2015,2017)
     2 *
     3 * jeremie.burgalat@univ-reims.fr
    44 *
    55 * This software is a computer program whose purpose is to provide configuration
    … …  
    3131 * The fact that you are presently reading this means that you have had
    3232 * knowledge of the CeCILL-B license and that you accept its terms.
    33  *//* csystem.h */
     33 */
    3434
    3535
    … …  
    172172 */
    173173int c_mkdir(const char *path, mode_t mode);
     174
     175
     176/**
     177 * Copy file to another.
     178 * @param to A C string with the new filepath
     179 * @param from A C string with the filepath to copy
     180 * @return An integer with 0 on success, 1 on failure.
     181 */
     182int c_copy(const char *to, const char *from);
    174183
    175184/**
    … …  
    255264int c_termsize(int *rows,int *cols);
    256265
     266/**
     267 * Get the current resident set size memory used by the program.
     268 */
     269size_t c_getCurrentRSS();
     270
     271/**
     272 * Get the peak resident set size memory used by the program.
     273 */
     274size_t c_getPeakRSS();
     275
     276/**
     277 * Get global memory usage informations.
     278 *
     279 * Note: The method attempts to read /proc/meminfo. If the file does not exists, all the given output arguments are
     280 * set to zero.
     281 */
     282int c_getSystemMemory(long long int *m_total,long long int *m_available,long long int *m_free);

  • trunk/LMDZ.TITAN/libf/muphytitan/datasets.F90

    r1793 r1897  
    3636!! summary: Dataset module definition file
    3737!! author: J. Burgalat
    38 !! date: 2014
    39 
    40 #if HAVE_CONFIG_H
    41 #include "config.h"
    42 #endif
     38!! date: 2014,2017
    4339
    4440MODULE DATASETS
    … …  
    6561  !! Note that for ASCII file, data must be ordered so first dimensions vary first. Same requirement
    6662  !! is needed for NetCDF file but in most cases, it is implicitly done (if dimensions are ordered).
    67   USE LINT_PREC
    68 #if HAVE_NC_FTN
    6963  USE NETCDF
    70 #endif
    7164  IMPLICIT NONE
    7265
    7366  PRIVATE
    7467
    75   PUBLIC :: read_dset, clear_dset, is_in, debug
     68  PUBLIC :: read_dset, write_dset, clear_dset, is_in, has_data, debug
    7669
    7770  LOGICAL :: debug = .false.  !! A control flag to enable verbose mode
    78 
    79 #if HAVE_NC_FTN
    80   LOGICAL, PUBLIC, PARAMETER ::nc_supported = .true. !! NetCDF input files are supported
    81 #else
    82   LOGICAL, PUBLIC, PARAMETER ::nc_supported = .false. !! NetCDF input files are not supported
    83 #endif
    8471
    8572  !> Initialize a data set from either an ASCII or a NetCDF file
    … …  
    9178  !! Netcdf reader interface is available only if the library has been compiled with NetCDF support.
    9279  INTERFACE read_dset
    93 #if HAVE_NC_FTN
    9480    MODULE PROCEDURE ncdf_rd_1d,ncdf_rd_2d,ncdf_rd_3d,ncdf_rd_4d,ncdf_rd_5d
    9581#if HAVE_NC4_FTN
    9682    MODULE PROCEDURE ncdf4_rd_1d,ncdf4_rd_2d,ncdf4_rd_3d,ncdf4_rd_4d,ncdf4_rd_5d
    9783#endif
    98 #endif
    9984    MODULE PROCEDURE ascii_rd_1d,ascii_rd_2d,ascii_rd_3d,ascii_rd_4d,ascii_rd_5d
     85  END INTERFACE
     86
     87  !> Write a dataset in a netcdf (classic) file.
     88  INTERFACE write_dset
     89    MODULE PROCEDURE nc_wr_1d,nc_wr_2d,nc_wr_3d,nc_wr_4d,nc_wr_5d
    10090  END INTERFACE
    10191
    … …  
    111101
    112102  !> Private interface to netcdf informations getters
    113 #if HAVE_NC_FTN
    114103  INTERFACE get_nc_info
    115104    MODULE PROCEDURE get_nc3_info
    … …  
    118107#endif
    119108  END INTERFACE
    120 #endif
     109
     110  INTERFACE has_data
     111    MODULE PROCEDURE has_d_1d,has_d_2d,has_d_3d,has_d_4d,has_d_5d
     112  END INTERFACE
     113
    121114
    122115  TYPE, PUBLIC :: DSET1D
    123116    !! A 1D data set
    124     REAL(kind=wp), DIMENSION(:), ALLOCATABLE :: x    !! X coordinate tabulated values
    125     REAL(kind=wp), DIMENSION(:), ALLOCATABLE :: data !! Tabulated function's value at each coordinate
     117    REAL(kind=8), DIMENSION(:), ALLOCATABLE :: x              !! X coordinate tabulated values
     118    REAL(kind=8), DIMENSION(:), ALLOCATABLE :: data           !! Tabulated function's value at each coordinate
     119    CHARACTER(len=NF90_MAX_NAME)            :: xname = "X"    !! Name of the X coordinate
     120    CHARACTER(len=NF90_MAX_NAME)            :: dname = "data" !! Name of the data block
    126121  END TYPE DSET1D
    127122
    128123  TYPE, PUBLIC :: DSET2D
    129124    !! A 2D data set
    130     REAL(kind=wp), DIMENSION(:), ALLOCATABLE   :: x    !! X coordinate tabulated values
    131     REAL(kind=wp), DIMENSION(:), ALLOCATABLE   :: y    !! Y coordinate tabulated values
    132     REAL(kind=wp), DIMENSION(:,:), ALLOCATABLE :: data !! Tabulated function's value at each coordinate
     125    REAL(kind=8), DIMENSION(:), ALLOCATABLE   :: x              !! X coordinate tabulated values
     126    REAL(kind=8), DIMENSION(:), ALLOCATABLE   :: y              !! Y coordinate tabulated values
     127    REAL(kind=8), DIMENSION(:,:), ALLOCATABLE :: data           !! Tabulated function's value at each coordinate
     128    CHARACTER(len=NF90_MAX_NAME)              :: xname = "X"    !! Name of the X coordinate
     129    CHARACTER(len=NF90_MAX_NAME)              :: yname = "Y"    !! Name of the Y coordinate
     130    CHARACTER(len=NF90_MAX_NAME)              :: dname = "data" !! Name of the data block
    133131  END TYPE DSET2D
    134132
    135133  TYPE, PUBLIC :: DSET3D
    136134    !! A 3D data set
    137     REAL(kind=wp), DIMENSION(:), ALLOCATABLE     :: x    !! X coordinate tabulated values
    138     REAL(kind=wp), DIMENSION(:), ALLOCATABLE     :: y    !! Y coordinate tabulated values
    139     REAL(kind=wp), DIMENSION(:), ALLOCATABLE     :: z    !! Z coordinate tabulated values
    140     REAL(kind=wp), DIMENSION(:,:,:), ALLOCATABLE :: data !! Tabulated function's value at each coordinate
     135    REAL(kind=8), DIMENSION(:), ALLOCATABLE     :: x              !! X coordinate tabulated values
     136    REAL(kind=8), DIMENSION(:), ALLOCATABLE     :: y              !! Y coordinate tabulated values
     137    REAL(kind=8), DIMENSION(:), ALLOCATABLE     :: z              !! Z coordinate tabulated values
     138    REAL(kind=8), DIMENSION(:,:,:), ALLOCATABLE :: data           !! Tabulated function's value at each coordinate
     139    CHARACTER(len=NF90_MAX_NAME)                :: xname = "X"    !! Name of the X coordinate
     140    CHARACTER(len=NF90_MAX_NAME)                :: yname = "Y"    !! Name of the Y coordinate
     141    CHARACTER(len=NF90_MAX_NAME)                :: zname = "Z"    !! Name of the Z coordinate
     142    CHARACTER(len=NF90_MAX_NAME)                :: dname = "data" !! Name of the data block
    141143  END TYPE DSET3D
    142144
    143145  TYPE, PUBLIC :: DSET4D
    144146    !! A 4D data set
    145     REAL(kind=wp), DIMENSION(:), ALLOCATABLE       :: x    !! X coordinate tabulated values
    146     REAL(kind=wp), DIMENSION(:), ALLOCATABLE       :: y    !! Y coordinate tabulated values
    147     REAL(kind=wp), DIMENSION(:), ALLOCATABLE       :: z    !! Z coordinate tabulated values
    148     REAL(kind=wp), DIMENSION(:), ALLOCATABLE       :: t    !! T coordinate tabulated values
    149     REAL(kind=wp), DIMENSION(:,:,:,:), ALLOCATABLE :: data !! Tabulated function's value at each coordinate
     147    REAL(kind=8), DIMENSION(:), ALLOCATABLE       :: x              !! X coordinate tabulated values
     148    REAL(kind=8), DIMENSION(:), ALLOCATABLE       :: y              !! Y coordinate tabulated values
     149    REAL(kind=8), DIMENSION(:), ALLOCATABLE       :: z              !! Z coordinate tabulated values
     150    REAL(kind=8), DIMENSION(:), ALLOCATABLE       :: t              !! T coordinate tabulated values
     151    REAL(kind=8), DIMENSION(:,:,:,:), ALLOCATABLE :: data           !! Tabulated function's value at each coordinate
     152    CHARACTER(len=NF90_MAX_NAME)                  :: xname = "X"    !! Name of the X coordinate
     153    CHARACTER(len=NF90_MAX_NAME)                  :: yname = "Y"    !! Name of the Y coordinate
     154    CHARACTER(len=NF90_MAX_NAME)                  :: zname = "Z"    !! Name of the Z coordinate
     155    CHARACTER(len=NF90_MAX_NAME)                  :: tname = "T"    !! Name of the T coordinate
     156    CHARACTER(len=NF90_MAX_NAME)                  :: dname = "data" !! Name of the data block
    150157  END TYPE DSET4D
    151158
    152159  TYPE, PUBLIC :: DSET5D
    153160    !! A 5D data set
    154     REAL(kind=wp), DIMENSION(:), ALLOCATABLE         :: x    !! X coordinate tabulated values
    155     REAL(kind=wp), DIMENSION(:), ALLOCATABLE         :: y    !! Y coordinate tabulated values
    156     REAL(kind=wp), DIMENSION(:), ALLOCATABLE         :: z    !! Z coordinate tabulated values
    157     REAL(kind=wp), DIMENSION(:), ALLOCATABLE         :: t    !! T coordinate tabulated values
    158     REAL(kind=wp), DIMENSION(:), ALLOCATABLE         :: w    !! W coordinate tabulated values
    159     REAL(kind=wp), DIMENSION(:,:,:,:,:), ALLOCATABLE :: data !! Tabulated function's value at each coordinate
     161    REAL(kind=8), DIMENSION(:), ALLOCATABLE         :: x              !! X coordinate tabulated values
     162    REAL(kind=8), DIMENSION(:), ALLOCATABLE         :: y              !! Y coordinate tabulated values
     163    REAL(kind=8), DIMENSION(:), ALLOCATABLE         :: z              !! Z coordinate tabulated values
     164    REAL(kind=8), DIMENSION(:), ALLOCATABLE         :: t              !! T coordinate tabulated values
     165    REAL(kind=8), DIMENSION(:), ALLOCATABLE         :: w              !! W coordinate tabulated values
     166    REAL(kind=8), DIMENSION(:,:,:,:,:), ALLOCATABLE :: data           !! Tabulated function's value at each coordinate
     167    CHARACTER(len=NF90_MAX_NAME)                    :: xname = "X"    !! Name of the X coordinate
     168    CHARACTER(len=NF90_MAX_NAME)                    :: yname = "Y"    !! Name of the Y coordinate
     169    CHARACTER(len=NF90_MAX_NAME)                    :: zname = "Z"    !! Name of the Z coordinate
     170    CHARACTER(len=NF90_MAX_NAME)                    :: tname = "T"    !! Name of the T coordinate
     171    CHARACTER(len=NF90_MAX_NAME)                    :: wname = "W"    !! Name of the W coordinate
     172    CHARACTER(len=NF90_MAX_NAME)                    :: dname = "data" !! Name of the data block
    160173  END TYPE DSET5D
    161174
    … …  
    165178  FUNCTION is_in_1d(set,x) RESULT(ret)
    166179    !! Check if point is in the 1D data set
    167     TYPE(DSET1D), INTENT(in)  :: set !! Dataset object to search in
    168     REAL(kind=wp), INTENT(in) :: x   !! coordinate of the point to check
     180    TYPE(DSET1D), INTENT(in) :: set !! Dataset object to search in
     181    REAL(kind=8), INTENT(in) :: x   !! coordinate of the point to check
    169182    LOGICAL :: ret                   !! .true. if the point is in the data set, .false. otherwise
    170     REAL(kind=wp) :: l,u
     183    REAL(kind=8) :: l,u
    171184    ret=.true.
    172185    l  = set%x(1) ; u= set%x(size(set%x))
    … …  
    177190  FUNCTION is_in_2d(set,x,y) RESULT(ret)
    178191    !! Check if point is in the 2D data set
    179     TYPE(DSET2D), INTENT(in)  :: set !! Dataset object to search in
    180     REAL(kind=wp), INTENT(in) :: x   !! X coordinate of the point to check
    181     REAL(kind=wp), INTENT(in) :: y   !! Y coordinate of the point to check
     192    TYPE(DSET2D), INTENT(in) :: set !! Dataset object to search in
     193    REAL(kind=8), INTENT(in) :: x   !! X coordinate of the point to check
     194    REAL(kind=8), INTENT(in) :: y   !! Y coordinate of the point to check
    182195    LOGICAL :: ret                   !! .true. if the point is in the data set, .false. otherwise
    183     REAL(kind=wp) :: l,u
     196    REAL(kind=8) :: l,u
    184197    ret=.false.
    185198    l  = set%x(1) ; u= set%x(size(set%x))
    … …  
    194207  FUNCTION is_in_3d(set,x,y,z) RESULT(ret)
    195208    !! Check if point is in the 3D data set
    196     TYPE(DSET3D), INTENT(in)  :: set !! Dataset object to search in
    197     REAL(kind=wp), INTENT(in) :: x   !! X coordinate of the point to check
    198     REAL(kind=wp), INTENT(in) :: y   !! Y coordinate of the point to check
    199     REAL(kind=wp), INTENT(in) :: z   !! Z coordinate of the point to check
     209    TYPE(DSET3D), INTENT(in) :: set !! Dataset object to search in
     210    REAL(kind=8), INTENT(in) :: x   !! X coordinate of the point to check
     211    REAL(kind=8), INTENT(in) :: y   !! Y coordinate of the point to check
     212    REAL(kind=8), INTENT(in) :: z   !! Z coordinate of the point to check
    200213    LOGICAL :: ret                   !! .true. if the point is in the data set, .false. otherwise
    201     REAL(kind=wp) :: l,u
     214    REAL(kind=8) :: l,u
    202215    ret=.false.
    203216    l  = set%x(1) ; u= set%x(size(set%x))
    … …  
    213226  FUNCTION is_in_4d(set,x,y,z,t) RESULT(ret)
    214227    !! Check if point is in the 4D data set
    215     TYPE(DSET4D), INTENT(in)  :: set !! Dataset object to search in
    216     REAL(kind=wp), INTENT(in) :: x   !! X coordinate of the point to check
    217     REAL(kind=wp), INTENT(in) :: y   !! Y coordinate of the point to check
    218     REAL(kind=wp), INTENT(in) :: z   !! Z coordinate of the point to check
    219     REAL(kind=wp), INTENT(in) :: t   !! T coordinate of the point to check
     228    TYPE(DSET4D), INTENT(in) :: set !! Dataset object to search in
     229    REAL(kind=8), INTENT(in) :: x   !! X coordinate of the point to check
     230    REAL(kind=8), INTENT(in) :: y   !! Y coordinate of the point to check
     231    REAL(kind=8), INTENT(in) :: z   !! Z coordinate of the point to check
     232    REAL(kind=8), INTENT(in) :: t   !! T coordinate of the point to check
    220233    LOGICAL :: ret                   !! .true. if the point is in the data set, .false. otherwise
    221     REAL(kind=wp) :: l,u
     234    REAL(kind=8) :: l,u
    222235    ret=.false.
    223236    l  = set%x(1) ; u= set%x(size(set%x))
    … …  
    235248  FUNCTION is_in_5d(set,x,y,z,t,w) RESULT(ret)
    236249    !! Check if point is in the 4D data set
    237     TYPE(DSET5D), INTENT(in)  :: set !! Dataset object to search in
    238     REAL(kind=wp), INTENT(in) :: x   !! X coordinate of the point to check
    239     REAL(kind=wp), INTENT(in) :: y   !! Y coordinate of the point to check
    240     REAL(kind=wp), INTENT(in) :: z   !! Z coordinate of the point to check
    241     REAL(kind=wp), INTENT(in) :: t   !! T coordinate of the point to check
    242     REAL(kind=wp), INTENT(in) :: w   !! W coordinate of the point to check
     250    TYPE(DSET5D), INTENT(in) :: set !! Dataset object to search in
     251    REAL(kind=8), INTENT(in) :: x   !! X coordinate of the point to check
     252    REAL(kind=8), INTENT(in) :: y   !! Y coordinate of the point to check
     253    REAL(kind=8), INTENT(in) :: z   !! Z coordinate of the point to check
     254    REAL(kind=8), INTENT(in) :: t   !! T coordinate of the point to check
     255    REAL(kind=8), INTENT(in) :: w   !! W coordinate of the point to check
    243256    LOGICAL :: ret                   !! .true. if the point is in the data set, .false. otherwise
    244     REAL(kind=wp) :: l,u
     257    REAL(kind=8) :: l,u
    245258    ret=.false.
    246259    l  = set%x(1) ; u= set%x(size(set%x))
    … …  
    300313  END FUNCTION ascii_header
    301314
    302 #if HAVE_NC_FTN
    303   FUNCTION nc_get_dim(fid,did,var,values,ds) RESULT(ret)
    304     !! Get dimensions information of a NetCDF variable
     315  FUNCTION nc_get_dim_by_name(fid,dn,values,ds,did) RESULT(ret)
     316    !! Get informations about a dimension.
    305317    !!
    306318    !! The method gets the values and size of a given dimension.
    307     INTEGER, INTENT(in)                                   :: fid
     319    !!
     320    !! Errors occur if:
     321    !!
     322    !! - the given name is not a dimension name.
     323    !! - the size of the dimension is less than 2 (the method assumes dimension has an afferent variable with values).
     324    !! - the method can not retrieve the values of the afferent variable.
     325    INTEGER, INTENT(in)                                  :: fid
    308326      !! Id of the NetCDF file
    309     INTEGER, INTENT(in)                                   :: did
     327    CHARACTER(len=NF90_MAX_NAME), INTENT(in)             :: dn
     328      !! Name of the dimension.
     329    REAL(kind=8), INTENT(out), DIMENSION(:), ALLOCATABLE :: values
     330      !! Values of the dimension
     331    INTEGER, INTENT(out)                                 :: ds
     332      !! Size of __values__
     333    INTEGER, INTENT(out)                                 :: did
    310334      !! Id of the NetCDF dimension
    311     CHARACTER(len=*), INTENT(in)                          :: var
    312       !! Name of the related NetCDF variable
    313     REAL(kind=wp), INTENT(out), DIMENSION(:), ALLOCATABLE :: values
    314       !! Values of the dimension
    315     INTEGER, INTENT(out)                                  :: ds
    316       !! Size of __values__
    317335    LOGICAL :: ret
    318336      !! .true. if no error(s) occured, .false. otherwise
    319337    INTEGER                      :: vid,err
    320     CHARACTER(len=NF90_MAX_NAME) :: dn
    321338    CHARACTER(len=15)            :: i2s
    322339    ret = .false.
    323340    ! --- Get dimension informations
    324     IF (NF90_INQUIRE_DIMENSION(fid,did,dn,ds) /= NF90_NOERR) THEN
    325       IF (debug) THEN
    326         WRITE(i2s,*) did ; i2s=TRIM(i2s)
    327         WRITE(*,'(a)') "ERROR:"//TRIM(var)//": Cannot find "// &
    328                  "dimension #"//TRIM(i2s)//" name"
    329       ENDIF
    330       err = NF90_CLOSE(fid) ; RETURN
    331     ENDIF
    332     IF (ds < 2) THEN
    333       IF (debug) WRITE(*,'(a)') "ERROR:"//TRIM(dn)//": Invalid dimension "// &
    334                  "size (<2)"
    335       err = NF90_CLOSE(fid) ; RETURN
    336     ENDIF
    337     IF (NF90_INQ_VARID(fid,TRIM(dn),vid) /= NF90_NOERR) THEN
    338       IF (debug) WRITE(*,'(a)') "ERROR:"//TRIM(dn)//": Cannot get ID"
    339       err = NF90_CLOSE(fid) ; RETURN
    340     ENDIF
     341    err = NF90_INQ_DIMID(fid,dn,did)
     342    IF (err /= NF90_NOERR) RETURN
     343    err = NF90_INQUIRE_DIMENSION(fid,did,len=ds)
     344    IF (err /= NF90_NOERR) RETURN
     345    IF (ds < 2) RETURN
     346    err = NF90_INQ_VARID(fid,TRIM(dn),vid)
     347    IF (err /= NF90_NOERR) RETURN
    341348    ALLOCATE(values(ds))
    342     IF (NF90_GET_VAR(fid,vid,values) /= NF90_NOERR) THEN
    343       IF (debug) WRITE(*,'(a)') "ERROR:"//TRIM(dn)//": Cannot get values"
    344       err = NF90_CLOSE(fid) ; RETURN
    345     ENDIF
    346     ret = .true.
    347   END FUNCTION nc_get_dim
    348 
    349   FUNCTION get_nc3_info(path,variable,ncid,vid,dimids) RESULT(ret)
     349    err = NF90_GET_VAR(fid,vid,values)
     350    IF (err /= NF90_NOERR) RETURN
     351    ret = .true.
     352  END FUNCTION nc_get_dim_by_name
     353
     354  FUNCTION nc_get_dim_by_id(fid,did,values,ds,dn) RESULT(ret)
     355    !! Get informations about a dimension.
     356    !!
     357    !! The method gets the values and size of a given dimension.
     358    !!
     359    !! Errors occur if:
     360    !!
     361    !! - the given id is not a dimension identifier.
     362    !! - the size of the dimension is less than 2 (the method assumes dimension has an afferent variable with values).
     363    !! - the method can not retrieve the values of the afferent variable.
     364    INTEGER, INTENT(in)                                  :: fid
     365      !! Id of the NetCDF file
     366    INTEGER, INTENT(in)                                  :: did
     367      !! Id of the NetCDF dimension
     368    REAL(kind=8), INTENT(out), DIMENSION(:), ALLOCATABLE :: values
     369      !! Values of the dimension
     370    INTEGER, INTENT(out)                                 :: ds
     371      !! Size of __values__
     372    CHARACTER(len=NF90_MAX_NAME), INTENT(out)            :: dn
     373      !! Name of the dimension.
     374    LOGICAL :: ret
     375      !! .true. if no error(s) occured, .false. otherwise
     376    INTEGER                      :: vid,err
     377    CHARACTER(len=15)            :: i2s
     378    ret = .false.
     379    ! --- Get dimension informations
     380    IF (NF90_INQUIRE_DIMENSION(fid,did,dn,ds) /= NF90_NOERR) RETURN
     381    IF (ds < 2) RETURN
     382    IF (NF90_INQ_VARID(fid,TRIM(dn),vid) /= NF90_NOERR) RETURN
     383    ALLOCATE(values(ds))
     384    IF (NF90_GET_VAR(fid,vid,values) /= NF90_NOERR) RETURN
     385    ret = .true.
     386  END FUNCTION nc_get_dim_by_id
     387
     388  FUNCTION get_nc3_info(path,variable,ncid,vid,dimids,verbose) RESULT(ret)
    350389    !! Get variable informations from NetCDF file
    351390    !!
    … …  
    358397    !! - variable's dimensions sizes
    359398    !!
    360     !! If no error occured (i.e. the function has returned .true.) then the
    361     !! NetCDF file remains open. In other case, the file is closed.
     399    !! The method always opens and closes the file. If the file cannot be opened,
     400    !! __ncid__ is set to -1.
    362401    CHARACTER(len=*), INTENT(in)                    :: path
    363402      !! Path of the NetCDF file
    … …  
    370409    INTEGER, INTENT(out), DIMENSION(:), ALLOCATABLE :: dimids
    371410      !! Id of the variable's dimensions. __dimids__ is not allocated on error.
     411    LOGICAL, INTENT(in), OPTIONAL                   :: verbose
     412      !! True to print out message on error (default to False).
    372413    LOGICAL :: ret
    373414      !! .true. if no errors occured, .false. otherwise
    374415    INTEGER :: fid,ty,nc,err
    375     ret = .false.
     416    LOGICAL :: zlog
     417    zlog = .false. ; IF (PRESENT(verbose)) zlog = verbose
     418    ret = .false.
     419    ncid = -1
    376420    ! Opens file
    377421    IF (NF90_OPEN(TRIM(path),NF90_NOWRITE,fid) /= NF90_NOERR) THEN
    378       WRITE(*,'(a)') 'ERROR: Cannot open '//trim(path)
     422      IF (zlog) WRITE(*,'(a)') 'ERROR: Cannot open '//trim(path)
    379423      RETURN
    380424    ENDIF
    … …  
    382426    ! Searches for variable
    383427    IF (NF90_INQ_VARID(ncid,TRIM(variable),vid) /= NF90_NOERR) THEN
    384       WRITE(*,'(a)') 'Cannot find '//TRIM(variable)//' in '//trim(path)
     428      IF (zlog) WRITE(*,'(a)') 'Cannot find '//TRIM(variable)//' in '//trim(path)
    385429      nc = NF90_CLOSE(fid)
    386430      RETURN
    … …  
    389433    ! 1st call to get type and number of dimensions)
    390434    IF (NF90_INQUIRE_VARIABLE(ncid,vid,xtype=ty,ndims=nc) /= NF90_NOERR) THEN
    391       WRITE(*,'(a)') 'Cannot access to '//TRIM(variable)//' informations'
     435      IF (zlog) WRITE(*,'(a)') 'Cannot access to '//TRIM(variable)//' informations'
    392436      nc = NF90_CLOSE(fid)
    393437      RETURN
    … …  
    395439      ! Checks type
    396440      IF (ty == NF90_CHAR) THEN
    397         WRITE(*,'(a)') 'Inconsistent variable type (should be numeric)'
     441        IF (zlog) WRITE(*,'(a)') 'Inconsistent variable type (should be numeric)'
    398442        nc = NF90_CLOSE(fid)
    399443        RETURN
    … …  
    404448    ! first get dimensions id
    405449    IF (NF90_INQUIRE_VARIABLE(ncid,vid,dimids=dimids) /= NF90_NOERR) THEN
    406       WRITE(*,'(a)') 'Cannot access to '//TRIM(variable)//' informations'
     450      IF (zlog) WRITE(*,'(a)') 'Cannot access to '//TRIM(variable)//' informations'
    407451      nc = NF90_CLOSE(fid)
    408452      DEALLOCATE(dimids)
    409453      RETURN
    410454    ENDIF
     455    nc = NF90_CLOSE(fid)
    411456    ret = .true.
    412457  END FUNCTION get_nc3_info
    413458
    414459#if HAVE_NC4_FTN
    415   FUNCTION get_nc4_info(path,variable,group,ncid,vid,dimids) RESULT(ret)
     460  FUNCTION get_nc4_info(path,variable,group,ncid,vid,dimids,verbose) RESULT(ret)
    416461    !! Get variable informations from NetCDF4 file
    417462    !!
    … …  
    424469    !! - variable's dimensions sizes
    425470    !!
    426     !! If no error occured (i.e. the function has returned .true.) then the
    427     !! NetCDF file remains open. In other case, the file is closed.
     471    !! The method always opens and closes the file. If the file cannot be opened,
     472    !! __ncid__ is set to -1.
    428473    CHARACTER(len=*), INTENT(in)                    :: path
    429474      !! Path of the NetCDF file
    … …  
    438483    INTEGER, INTENT(out), DIMENSION(:), ALLOCATABLE :: dimids
    439484      !! Id of the variable's dimensions. On error, __dimids__ is not allocated.
     485    LOGICAL, INTENT(in), OPTIONAL                   :: verbose
     486      !! True to print out message on error (default to False).
    440487    LOGICAL :: ret
    441488      !! .true. if no errors occured, .false. otherwise
    442489    INTEGER :: fid,ty,nc,err
    443     ret = .false.
     490    LOGICAL :: zlog
     491    zlog = .false. ; IF (PRESENT(verbose)) zlog = verbose
     492    ret = .false.
     493    ncid = -1
    444494    ! Opens file
    445495    IF (NF90_OPEN(TRIM(path),NF90_NOWRITE,fid) /= NF90_NOERR) THEN
    446       WRITE(*,'(a)') 'ERROR: Cannot open '//trim(path)
     496      IF (zlog) WRITE(*,'(a)') 'ERROR: Cannot open '//trim(path)
    447497      RETURN
    448498    ENDIF
    … …  
    456506      ! NF90_ENOGRP is missing from Netcdf-Fortran4.2 : its value=-125
    457507      CASE(-125)
    458         WRITE(*,'(a)') TRIM(group)//' does not exist in '//TRIM(path)
     508        IF (zlog) WRITE(*,'(a)') TRIM(group)//' does not exist in '//TRIM(path)
    459509        nc = NF90_CLOSE(fid) ; RETURN
    460510      CASE(NF90_ENOTNC4,NF90_ESTRICTNC3)
    461         WRITE(*,'(a)') TRIM(path)//' is not a NetCDF-4 file with "group" feature'
     511        IF (zlog) WRITE(*,'(a)') TRIM(path)//' is not a NetCDF-4 file with "group" feature'
    462512        nc = NF90_CLOSE(fid) ; RETURN
    463513      CASE(NF90_EHDFERR)
    464         WRITE(*,'(a)') "Too bad, an HDF5 error has been reported..."
     514        IF (zlog) WRITE(*,'(a)') "Too bad, an HDF5 error has been reported..."
    465515        nc = NF90_CLOSE(fid) ; RETURN
    466516    END SELECT
    467517    ! Searches for variable
    468518    IF (NF90_INQ_VARID(ncid,TRIM(variable),vid) /= NF90_NOERR) THEN
    469       WRITE(*,'(a)') 'Cannot find '//TRIM(variable)//' in '//trim(path)
     519      IF (zlog) WRITE(*,'(a)') 'Cannot find '//TRIM(variable)//' in '//trim(path)
    470520      nc = NF90_CLOSE(fid)
    471521      RETURN
    … …  
    474524    ! 1st call to get type and number of dimensions)
    475525    IF (NF90_INQUIRE_VARIABLE(ncid,vid,xtype=ty,ndims=nc) /= NF90_NOERR) THEN
    476       WRITE(*,'(a)') 'Cannot access to '//TRIM(variable)//' informations'
     526      IF (zlog) WRITE(*,'(a)') 'Cannot access to '//TRIM(variable)//' informations'
    477527      nc = NF90_CLOSE(fid)
    478528      RETURN
    … …  
    480530      ! Checks type
    481531      IF (ty == NF90_CHAR) THEN
    482         WRITE(*,'(a)') 'Inconsistent variable type (should be numeric)'
     532        IF (zlog) WRITE(*,'(a)') 'Inconsistent variable type (should be numeric)'
    483533        nc = NF90_CLOSE(fid)
    484534        RETURN
    … …  
    489539    ! first get dimensions id
    490540    IF (NF90_INQUIRE_VARIABLE(ncid,vid,dimids=dimids) /= NF90_NOERR) THEN
    491       WRITE(*,'(a)') 'Cannot access to '//TRIM(variable)//' informations'
     541      IF (zlog) WRITE(*,'(a)') 'Cannot access to '//TRIM(variable)//' informations'
    492542      nc = NF90_CLOSE(fid)
    493543      DEALLOCATE(dimids)
    494544      RETURN
    495545    ENDIF
     546    nc = NF90_CLOSE(fid)
    496547    ret = .true.
    497548  END FUNCTION get_nc4_info
    498549#endif
    499 #endif
    500550
    501551  !-------------------------
    502552  ! NetCDF data file readers
    503553  !-------------------------
    504 
    505 #if HAVE_NC_FTN
    506 
    507554
    508555  FUNCTION ncdf_rd_1d(path,variable,set) RESULT(ret)
    … …  
    512559    TYPE(DSET1D), INTENT(out)    :: set      !! Output dataset object
    513560    LOGICAL :: ret                           !! .true. if no errors occured, .false. otherwise
    514     INTEGER                            :: fi,vi,nd
     561    INTEGER                            :: fi,vi,nd,iret
    515562    INTEGER, DIMENSION(:), ALLOCATABLE :: di,ds
    516563    CHARACTER(len=NF90_MAX_NAME)       :: dn
    … …  
    521568    ! --- Check NetCDF file info
    522569    IF (.NOT.get_nc_info(path,variable,fi,vi,di)) RETURN
     570    iret = NF90_OPEN(path,NF90_NOWRITE,fi)
    523571    ! --- Check dimension size
    524572    nd = SIZE(di)
    … …  
    533581    ALLOCATE(ds(nd))
    534582    ! ------ X coordinate
    535     IF (.NOT.nc_get_dim(fi,di(1),variable,set%x,ds(1))) THEN
    536       CALL clear_dset(set) ; RETURN
     583    IF (.NOT.nc_get_dim_by_id(fi,di(1),set%x,ds(1),set%xname)) THEN
     584      nd = NF90_CLOSE(fi) ; CALL clear_dset(set) ; RETURN
    537585    ENDIF
    538586    ! --- Read data
    … …  
    543591    ENDIF
    544592    nd = NF90_CLOSE(fi)
     593    set%dname = variable
    545594    ret = .true.
    546595    RETURN
    … …  
    553602    TYPE(DSET2D), INTENT(out)    :: set      !! Output dataset object
    554603    LOGICAL :: ret                           !! .true. if no errors occured, .false. otherwise
    555     INTEGER                            :: fi,vi,nd
     604    INTEGER                            :: fi,vi,nd,iret
    556605    INTEGER, DIMENSION(:), ALLOCATABLE :: di,ds
    557606    CHARACTER(len=15)                  :: i2s
    … …  
    561610    ! --- Check NetCDF file info
    562611    IF (.NOT.get_nc_info(path,variable,fi,vi,di)) RETURN
     612    iret = NF90_OPEN(path,NF90_NOWRITE,fi)
    563613    ! --- Check dimension size
    564614    nd = SIZE(di)
    … …  
    573623    ALLOCATE(ds(nd))
    574624    ! ------ X coordinate
    575     IF (.NOT.nc_get_dim(fi,di(1),variable,set%x,ds(1))) THEN
    576       CALL clear_dset(set) ; RETURN
     625    IF (.NOT.nc_get_dim_by_id(fi,di(1),set%x,ds(1),set%xname)) THEN
     626      nd = NF90_CLOSE(fi) ; CALL clear_dset(set) ; RETURN
    577627    ENDIF
    578628    ! ------ Y coordinate
    579     IF (.NOT.nc_get_dim(fi,di(2),variable,set%y,ds(2))) THEN
    580       CALL clear_dset(set) ; RETURN
     629    IF (.NOT.nc_get_dim_by_id(fi,di(2),set%y,ds(2),set%yname)) THEN
     630      nd = NF90_CLOSE(fi) ; CALL clear_dset(set) ; RETURN
    581631    ENDIF
    582632    ! --- Read data
    … …  
    587637    ENDIF
    588638    nd = NF90_CLOSE(fi)
     639    set%dname = variable
    589640    ret = .true.
    590641    RETURN
    … …  
    597648    TYPE(DSET3D), INTENT(out)    :: set      !! Output dataset object
    598649    LOGICAL :: ret                           !! .true. if no errors occured, .false. otherwise
    599     INTEGER                            :: fi,vi,nd
     650    INTEGER                            :: fi,vi,nd,iret
    600651    INTEGER, DIMENSION(:), ALLOCATABLE :: di,ds
    601652    CHARACTER(len=15)                  :: i2s
    … …  
    605656    ! --- Check NetCDF file info
    606657    IF (.NOT.get_nc_info(path,variable,fi,vi,di)) RETURN
     658    iret = NF90_OPEN(path,NF90_NOWRITE,fi)
    607659    ! --- Check dimension size
    608660    nd = SIZE(di)
    … …  
    617669    ALLOCATE(ds(nd))
    618670    ! ------ X coordinate
    619     IF (.NOT.nc_get_dim(fi,di(1),variable,set%x,ds(1))) THEN
    620       CALL clear_dset(set) ; RETURN
     671    IF (.NOT.nc_get_dim_by_id(fi,di(1),set%x,ds(1),set%xname)) THEN
     672      nd = NF90_CLOSE(fi) ; CALL clear_dset(set) ; RETURN
    621673    ENDIF
    622674    ! ------ Y coordinate
    623     IF (.NOT.nc_get_dim(fi,di(2),variable,set%y,ds(2))) THEN
    624       CALL clear_dset(set) ; RETURN
     675    IF (.NOT.nc_get_dim_by_id(fi,di(2),set%y,ds(2),set%yname)) THEN
     676      nd = NF90_CLOSE(fi) ; CALL clear_dset(set) ; RETURN
    625677    ENDIF
    626678    ! ------ Z coordinate
    627     IF (.NOT.nc_get_dim(fi,di(3),variable,set%z,ds(3))) THEN
    628       CALL clear_dset(set) ; RETURN
     679    IF (.NOT.nc_get_dim_by_id(fi,di(3),set%z,ds(3),set%zname)) THEN
     680      nd = NF90_CLOSE(fi) ; CALL clear_dset(set) ; RETURN
    629681    ENDIF
    630682    ! --- Read data
    … …  
    635687    ENDIF
    636688    nd = NF90_CLOSE(fi)
     689    set%dname = variable
    637690    ret = .true.
    638691    RETURN
    … …  
    645698    TYPE(DSET4D), INTENT(out)    :: set      !! Output dataset object
    646699    LOGICAL :: ret                           !! .true. if no errors occured, .false. otherwise
    647     INTEGER                            :: fi,vi,nd
     700    INTEGER                            :: fi,vi,nd,iret
    648701    INTEGER, DIMENSION(:), ALLOCATABLE :: di,ds
    649702    CHARACTER(len=15)                  :: i2s
    … …  
    653706    ! --- Check NetCDF file info
    654707    IF (.NOT.get_nc_info(path,variable,fi,vi,di)) RETURN
     708    iret = NF90_OPEN(path,NF90_NOWRITE,fi)
    655709    ! --- Check dimension size
    656710    nd = SIZE(di)
    … …  
    665719    ALLOCATE(ds(nd))
    666720    ! ------ X coordinate
    667     IF (.NOT.nc_get_dim(fi,di(1),variable,set%x,ds(1))) THEN
    668       CALL clear_dset(set) ; RETURN
     721    IF (.NOT.nc_get_dim_by_id(fi,di(1),set%x,ds(1),set%xname)) THEN
     722      nd = NF90_CLOSE(fi) ; CALL clear_dset(set) ; RETURN
    669723    ENDIF
    670724    ! ------ Y coordinate
    671     IF (.NOT.nc_get_dim(fi,di(2),variable,set%y,ds(2))) THEN
    672       CALL clear_dset(set) ; RETURN
     725    IF (.NOT.nc_get_dim_by_id(fi,di(2),set%y,ds(2),set%yname)) THEN
     726      nd = NF90_CLOSE(fi) ; CALL clear_dset(set) ; RETURN
    673727    ENDIF
    674728    ! ------ Z coordinate
    675     IF (.NOT.nc_get_dim(fi,di(3),variable,set%z,ds(3))) THEN
    676       CALL clear_dset(set) ; RETURN
     729    IF (.NOT.nc_get_dim_by_id(fi,di(3),set%z,ds(3),set%zname)) THEN
     730      nd = NF90_CLOSE(fi) ; CALL clear_dset(set) ; RETURN
    677731    ENDIF
    678732    ! ------ T coordinate
    679     IF (.NOT.nc_get_dim(fi,di(4),variable,set%t,ds(4))) THEN
    680       CALL clear_dset(set) ; RETURN
     733    IF (.NOT.nc_get_dim_by_id(fi,di(4),set%t,ds(4),set%tname)) THEN
     734      nd = NF90_CLOSE(fi) ; CALL clear_dset(set) ; RETURN
    681735    ENDIF
    682736    ! --- Read data
    … …  
    687741    ENDIF
    688742    nd = NF90_CLOSE(fi)
     743    set%dname = variable
    689744    ret = .true.
    690745    RETURN
    … …  
    697752    TYPE(DSET5D), INTENT(out)    :: set      !! Output dataset object
    698753    LOGICAL :: ret                           !! .true. if no errors occured, .false. otherwise
    699     INTEGER                            :: fi,vi,nd
     754    INTEGER                            :: fi,vi,nd,iret
    700755    INTEGER, DIMENSION(:), ALLOCATABLE :: di,ds
    701756    CHARACTER(len=15)                  :: i2s
    … …  
    705760    ! --- Check NetCDF file info
    706761    IF (.NOT.get_nc_info(path,variable,fi,vi,di)) RETURN
     762    iret = NF90_OPEN(path,NF90_NOWRITE,fi)
    707763    ! --- Check dimension size
    708764    nd = SIZE(di)
    … …  
    717773    ALLOCATE(ds(nd))
    718774    ! ------ X coordinate
    719     IF (.NOT.nc_get_dim(fi,di(1),variable,set%x,ds(1))) THEN
    720       CALL clear_dset(set) ; RETURN
     775    IF (.NOT.nc_get_dim_by_id(fi,di(1),set%x,ds(1),set%xname)) THEN
     776      nd = NF90_CLOSE(fi) ; CALL clear_dset(set) ; RETURN
    721777    ENDIF
    722778    ! ------ Y coordinate
    723     IF (.NOT.nc_get_dim(fi,di(2),variable,set%y,ds(2))) THEN
    724       CALL clear_dset(set) ; RETURN
     779    IF (.NOT.nc_get_dim_by_id(fi,di(2),set%y,ds(2),set%yname)) THEN
     780      nd = NF90_CLOSE(fi) ; CALL clear_dset(set) ; RETURN
    725781    ENDIF
    726782    ! ------ Z coordinate
    727     IF (.NOT.nc_get_dim(fi,di(3),variable,set%z,ds(3))) THEN
    728       CALL clear_dset(set) ; RETURN
     783    IF (.NOT.nc_get_dim_by_id(fi,di(3),set%z,ds(3),set%zname)) THEN
     784      nd = NF90_CLOSE(fi) ; CALL clear_dset(set) ; RETURN
    729785    ENDIF
    730786    ! ------ T coordinate
    731     IF (.NOT.nc_get_dim(fi,di(4),variable,set%t,ds(4))) THEN
    732       CALL clear_dset(set) ; RETURN
     787    IF (.NOT.nc_get_dim_by_id(fi,di(4),set%t,ds(4),set%tname)) THEN
     788      nd = NF90_CLOSE(fi) ; CALL clear_dset(set) ; RETURN
    733789    ENDIF
    734790    ! ------ W coordinate
    735     IF (.NOT.nc_get_dim(fi,di(5),variable,set%w,ds(5))) THEN
    736       CALL clear_dset(set) ; RETURN
     791    IF (.NOT.nc_get_dim_by_id(fi,di(5),set%w,ds(5),set%wname)) THEN
     792      nd = NF90_CLOSE(fi) ; CALL clear_dset(set) ; RETURN
    737793    ENDIF
    738794    ! --- Read data
    … …  
    743799    ENDIF
    744800    nd = NF90_CLOSE(fi)
     801    set%dname = variable
    745802    ret = .true.
    746803    RETURN
    … …  
    757814    TYPE(DSET1D), INTENT(out)    :: set      !! Output dataset
    758815    LOGICAL :: ret                           !! .true. if no errors occured, .false. otherwise
    759     INTEGER                            :: fi,vi,nd
     816    INTEGER                            :: fi,vi,nd,iret
    760817    INTEGER, DIMENSION(:), ALLOCATABLE :: di,ds
    761818    CHARACTER(len=NF90_MAX_NAME)       :: dn
    … …  
    766823    ! --- Check NetCDF file info
    767824    IF (.NOT.get_nc_info(path,group,variable,fi,vi,di)) RETURN
     825    iret = NF90_OPEN(path,NF90_NOWRITE,fi)
    768826    ! --- Check dimension size
    769827    nd = SIZE(di)
    … …  
    778836    ALLOCATE(ds(nd))
    779837    ! ------ X coordinate
    780     IF (.NOT.nc_get_dim(fi,di(1),variable,set%x,ds(1))) THEN
    781       CALL clear_dset(set) ; RETURN
     838    IF (.NOT.nc_get_dim_by_id(fi,di(1),set%x,ds(1),set%xname)) THEN
     839      nd = NF90_CLOSE(fi) ; CALL clear_dset(set) ; RETURN
    782840    ENDIF
    783841    ! --- Read data
    … …  
    788846    ENDIF
    789847    nd = NF90_CLOSE(fi)
     848    set%dname = variable
    790849    ret = .true.
    791850    RETURN
    … …  
    799858    TYPE(DSET2D), INTENT(out)    :: set      !! Output dataset
    800859    LOGICAL :: ret                           !! .true. if no errors occured, .false. otherwise
    801     INTEGER                            :: fi,vi,nd
     860    INTEGER                            :: fi,vi,nd,iret
    802861    INTEGER, DIMENSION(:), ALLOCATABLE :: di,ds
    803862    CHARACTER(len=15)                  :: i2s
    … …  
    807866    ! --- Check NetCDF file info
    808867    IF (.NOT.get_nc_info(path,group,variable,fi,vi,di)) rETURN
     868    iret = NF90_OPEN(path,NF90_NOWRITE,fi)
    809869    ! --- Check dimension size
    810870    nd = SIZE(di)
    … …  
    819879    ALLOCATE(ds(nd))
    820880    ! ------ X coordinate
    821     IF (.NOT.nc_get_dim(fi,di(1),variable,set%x,ds(1))) THEN
    822       CALL clear_dset(set) ; RETURN
     881    IF (.NOT.nc_get_dim_by_id(fi,di(1),set%x,ds(1),set%xname)) THEN
     882      nd = NF90_CLOSE(fi) ; CALL clear_dset(set) ; RETURN
    823883    ENDIF
    824884    ! ------ Y coordinate
    825     IF (.NOT.nc_get_dim(fi,di(2),variable,set%y,ds(2))) THEN
    826       CALL clear_dset(set) ; RETURN
     885    IF (.NOT.nc_get_dim_by_id(fi,di(2),set%y,ds(2),set%yname)) THEN
     886      nd = NF90_CLOSE(fi) ; CALL clear_dset(set) ; RETURN
    827887    ENDIF
    828888    ! --- Read data
    … …  
    833893    ENDIF
    834894    nd = NF90_CLOSE(fi)
     895    set%dname = variable
    835896    ret = .true.
    836897    RETURN
    … …  
    844905    TYPE(DSET3D), INTENT(out)    :: set      !! Output dataset
    845906    LOGICAL :: ret                           !! .true. if no errors occured, .false. otherwise
    846     INTEGER                            :: fi,vi,nd
     907    INTEGER                            :: fi,vi,nd,iret
    847908    INTEGER, DIMENSION(:), ALLOCATABLE :: di,ds
    848909    CHARACTER(len=15)                  :: i2s
    … …  
    852913    ! --- Check NetCDF file info
    853914    IF (.NOT.get_nc_info(path,group,variable,fi,vi,di)) RETURN
     915    iret = NF90_OPEN(path,NF90_NOWRITE,fi)
    854916    ! --- Check dimension size
    855917    nd = SIZE(di)
    … …  
    864926    ALLOCATE(ds(nd))
    865927    ! ------ X coordinate
    866     IF (.NOT.nc_get_dim(fi,di(1),variable,set%x,ds(1))) THEN
    867       CALL clear_dset(set) ; RETURN
     928    IF (.NOT.nc_get_dim_by_id(fi,di(1),set%x,ds(1),set%xname)) THEN
     929      nd = NF90_CLOSE(fi) ; CALL clear_dset(set) ; RETURN
    868930    ENDIF
    869931    ! ------ Y coordinate
    870     IF (.NOT.nc_get_dim(fi,di(2),variable,set%y,ds(2))) THEN
    871       CALL clear_dset(set) ; RETURN
     932    IF (.NOT.nc_get_dim_by_id(fi,di(2),set%y,ds(2),set%yname)) THEN
     933      nd = NF90_CLOSE(fi) ; CALL clear_dset(set) ; RETURN
    872934    ENDIF
    873935    ! ------ Z coordinate
    874     IF (.NOT.nc_get_dim(fi,di(3),variable,set%z,ds(3))) THEN
    875       CALL clear_dset(set) ; RETURN
     936    IF (.NOT.nc_get_dim_by_id(fi,di(3),set%z,ds(3),set%zname)) THEN
     937      nd = NF90_CLOSE(fi) ; CALL clear_dset(set) ; RETURN
    876938    ENDIF
    877939    ! --- Read data
    … …  
    882944    ENDIF
    883945    nd = NF90_CLOSE(fi)
     946    set%dname = variable
    884947    ret = .true.
    885948    RETURN
    … …  
    893956    TYPE(DSET4D), INTENT(out)    :: set      !! Output dataset
    894957    LOGICAL :: ret                           !! .true. if no errors occured, .false. otherwise
    895     INTEGER                            :: fi,vi,nd
     958    INTEGER                            :: fi,vi,nd,iret
    896959    INTEGER, DIMENSION(:), ALLOCATABLE :: di,ds
    897960    CHARACTER(len=15)                  :: i2s
    … …  
    901964    ! --- Check NetCDF file info
    902965    IF (.NOT.get_nc_info(path,group,variable,fi,vi,di)) RETURN
     966    iret = NF90_OPEN(path,NF90_NOWRITE,fi)
    903967    ! --- Check dimension size
    904968    nd = SIZE(di)
    … …  
    913977    ALLOCATE(ds(nd))
    914978    ! ------ X coordinate
    915     IF (.NOT.nc_get_dim(fi,di(1),variable,set%x,ds(1))) THEN
    916       CALL clear_dset(set) ; RETURN
     979    IF (.NOT.nc_get_dim_by_id(fi,di(1),set%x,ds(1),set%xname)) THEN
     980      nd = NF90_CLOSE(fi) ; CALL clear_dset(set) ; RETURN
    917981    ENDIF
    918982    ! ------ Y coordinate
    919     IF (.NOT.nc_get_dim(fi,di(2),variable,set%y,ds(2))) THEN
    920       CALL clear_dset(set) ; RETURN
     983    IF (.NOT.nc_get_dim_by_id(fi,di(2),set%y,ds(2),set%yname)) THEN
     984      nd = NF90_CLOSE(fi) ; CALL clear_dset(set) ; RETURN
    921985    ENDIF
    922986    ! ------ Z coordinate
    923     IF (.NOT.nc_get_dim(fi,di(3),variable,set%z,ds(3))) THEN
    924       CALL clear_dset(set) ; RETURN
     987    IF (.NOT.nc_get_dim_by_id(fi,di(3),set%z,ds(3),set%zname)) THEN
     988      nd = NF90_CLOSE(fi) ; CALL clear_dset(set) ; RETURN
    925989    ENDIF
    926990    ! ------ T coordinate
    927     IF (.NOT.nc_get_dim(fi,di(4),variable,set%t,ds(4))) THEN
    928       CALL clear_dset(set) ; RETURN
     991    IF (.NOT.nc_get_dim_by_id(fi,di(4),set%t,ds(4),set%tname)) THEN
     992      nd = NF90_CLOSE(fi) ; CALL clear_dset(set) ; RETURN
    929993    ENDIF
    930994    ! --- Read data
    … …  
    935999    ENDIF
    9361000    nd = NF90_CLOSE(fi)
     1001    set%dname = variable
    9371002    ret = .true.
    9381003    RETURN
    … …  
    9461011    TYPE(DSET5D), INTENT(out)    :: set      !! Output dataset
    9471012    LOGICAL :: ret                           !! .true. if no errors occured, .false. otherwise
    948     INTEGER                            :: fi,vi,nd
     1013    INTEGER                            :: fi,vi,nd,iret
    9491014    INTEGER, DIMENSION(:), ALLOCATABLE :: di,ds
    9501015    CHARACTER(len=15)                  :: i2s
    … …  
    9541019    ! --- Check NetCDF file info
    9551020    IF (.NOT.get_nc_info(path,group,variable,fi,vi,di)) RETURN
     1021    iret = NF90_OPEN(path,NF90_NOWRITE,fi)
    9561022    ! --- Check dimension size
    9571023    nd = SIZE(di)
    … …  
    9661032    ALLOCATE(ds(nd))
    9671033    ! ------ X coordinate
    968     IF (.NOT.nc_get_dim(fi,di(1),variable,set%x,ds(1))) THEN
    969       CALL clear_dset(set) ; RETURN
     1034    IF (.NOT.nc_get_dim_by_id(fi,di(1),set%x,ds(1),set%xname)) THEN
     1035      nd = NF90_CLOSE(fi) ; CALL clear_dset(set) ; RETURN
    9701036    ENDIF
    9711037    ! ------ Y coordinate
    972     IF (.NOT.nc_get_dim(fi,di(2),variable,set%y,ds(2))) THEN
    973       CALL clear_dset(set) ; RETURN
     1038    IF (.NOT.nc_get_dim_by_id(fi,di(2),set%y,ds(2),set%yname)) THEN
     1039      nd = NF90_CLOSE(fi) ; CALL clear_dset(set) ; RETURN
    9741040    ENDIF
    9751041    ! ------ Z coordinate
    976     IF (.NOT.nc_get_dim(fi,di(3),variable,set%z,ds(3))) THEN
    977       CALL clear_dset(set) ; RETURN
     1042    IF (.NOT.nc_get_dim_by_id(fi,di(3),set%z,ds(3),set%zname)) THEN
     1043      nd = NF90_CLOSE(fi) ; CALL clear_dset(set) ; RETURN
    9781044    ENDIF
    9791045    ! ------ T coordinate
    980     IF (.NOT.nc_get_dim(fi,di(4),variable,set%t,ds(4))) THEN
    981       CALL clear_dset(set) ; RETURN
     1046    IF (.NOT.nc_get_dim_by_id(fi,di(4),set%t,ds(4),set%tname)) THEN
     1047      nd = NF90_CLOSE(fi) ; CALL clear_dset(set) ; RETURN
    9821048    ENDIF
    9831049    ! ------ W coordinate
    984     IF (.NOT.nc_get_dim(fi,di(5),variable,set%w,ds(5))) THEN
     1050    IF (.NOT.nc_get_dim_by_id(fi,di(5),set%w,ds(5),set%wname)) THEN
     1051      nd = NF90_CLOSE(fi) ; CALL clear_dset(set) ; RETURN
    9851052      CALL clear_dset(set) ; RETURN
    9861053    ENDIF
    … …  
    9921059    ENDIF
    9931060    nd = NF90_CLOSE(fi)
     1061    set%dname = variable
    9941062    ret = .true.
    9951063    RETURN
    9961064  END FUNCTION ncdf4_rd_5d
    997 #endif
    9981065#endif
    9991066
    … …  
    10071074    TYPE(dset1d), INTENT(out)    :: set  !! output 1D dataset
    10081075    LOGICAL :: ret                       !! .true. if no error occured, .false. otherwise
    1009     INTEGER                     :: i,e
    1010     REAL(kind=wp), DIMENSION(2) :: vl
    1011     INTEGER, DIMENSION(1)       :: cc,ds,dp
     1076    INTEGER                    :: i,e
     1077    REAL(kind=8), DIMENSION(2) :: vl
     1078    INTEGER, DIMENSION(1)      :: cc,ds,dp
    10121079    ret = .false.
    10131080    CALL clear_dset(set)
    … …  
    10371104    TYPE(dset2d), INTENT(out)    :: set  !! output 2D dataset
    10381105    LOGICAL :: ret                       !! .true. if no error occured, .false. otherwise
    1039     INTEGER                     :: i,e
    1040     REAL(kind=wp), DIMENSION(3) :: vl
    1041     INTEGER, DIMENSION(2)       :: cc,ds,dp
     1106    INTEGER                    :: i,e
     1107    REAL(kind=8), DIMENSION(3) :: vl
     1108    INTEGER, DIMENSION(2)      :: cc,ds,dp
    10421109    ret = .false.
    10431110    CALL clear_dset(set)
    … …  
    10771144    TYPE(dset3d), INTENT(out)    :: set  !! output 3D dataset
    10781145    LOGICAL :: ret                       !! .true. if no error occured, .false. otherwise
    1079     INTEGER                     :: i,e
    1080     REAL(kind=wp), DIMENSION(4) :: vl
    1081     INTEGER, DIMENSION(3)       :: cc,ds,dp
     1146    INTEGER                    :: i,e
     1147    REAL(kind=8), DIMENSION(4) :: vl
     1148    INTEGER, DIMENSION(3)      :: cc,ds,dp
    10821149    ret = .false.
    10831150    CALL clear_dset(set)
    … …  
    11201187    TYPE(dset4d), INTENT(out)    :: set  !! output 4D dataset
    11211188    LOGICAL :: ret                       !! .true. if no error occured, .false. otherwise
    1122     INTEGER                     :: i,e
    1123     REAL(kind=wp), DIMENSION(5) :: vl
    1124     INTEGER, DIMENSION(4)       :: cc,ds,dp
     1189    INTEGER                    :: i,e
     1190    REAL(kind=8), DIMENSION(5) :: vl
     1191    INTEGER, DIMENSION(4)      :: cc,ds,dp
    11251192    ret = .false.
    11261193    CALL clear_dset(set)
    … …  
    11661233    TYPE(dset5d), INTENT(out)    :: set  !! output 5D dataset
    11671234    LOGICAL :: ret                       !! .true. if no error occured, .false. otherwise
    1168     INTEGER                     :: i,e
    1169     REAL(kind=wp), DIMENSION(6) :: vl
    1170     INTEGER, DIMENSION(5)       :: cc,ds,dp
     1235    INTEGER                    :: i,e
     1236    REAL(kind=8), DIMENSION(6) :: vl
     1237    INTEGER, DIMENSION(5)      :: cc,ds,dp
    11711238    ret = .false.
    11721239    CALL clear_dset(set)
    … …  
    12601327  END SUBROUTINE clr_5d_set
    12611328
     1329  FUNCTION has_d_1d(dset) RESULT(yes)
     1330    !! Check whether or not the dataset has data.
     1331    TYPE(DSET1D), INTENT(in)     :: dset !! Dataset to check
     1332    LOGICAL                      :: yes  !! return status
     1333    yes =  (ALLOCATED(dset%data).AND. &
     1334            ALLOCATED(dset%x))
     1335  END FUNCTION has_d_1d
     1336
     1337  FUNCTION has_d_2d(dset) RESULT(yes)
     1338    !! Check whether or not the dataset has data.
     1339    TYPE(DSET2D), INTENT(in)     :: dset !! Dataset to check
     1340    LOGICAL                      :: yes  !! return status
     1341    yes =  (ALLOCATED(dset%data).AND. &
     1342            ALLOCATED(dset%x)   .AND. &   
     1343            ALLOCATED(dset%y))
     1344  END FUNCTION has_d_2d
     1345
     1346  FUNCTION has_d_3d(dset) RESULT(yes)
     1347    !! Check whether or not the dataset has data.
     1348    TYPE(DSET3D), INTENT(in)     :: dset !! Dataset to check
     1349    LOGICAL                      :: yes  !! return status
     1350    yes =  (ALLOCATED(dset%data).AND. &
     1351            ALLOCATED(dset%x)   .AND. &   
     1352            ALLOCATED(dset%y)   .AND. &
     1353            ALLOCATED(dset%z))
     1354  END FUNCTION has_d_3d
     1355
     1356  FUNCTION has_d_4d(dset) RESULT(yes)
     1357    !! Check whether or not the dataset has data.
     1358    TYPE(DSET4D), INTENT(in)     :: dset !! Dataset to check
     1359    LOGICAL                      :: yes  !! return status
     1360    yes =  (ALLOCATED(dset%data).AND. &
     1361            ALLOCATED(dset%x)   .AND. &   
     1362            ALLOCATED(dset%y)   .AND. &
     1363            ALLOCATED(dset%z)   .AND. &
     1364            ALLOCATED(dset%t))
     1365  END FUNCTION has_d_4d
     1366
     1367  FUNCTION has_d_5d(dset) RESULt(yes)
     1368    !! Check whether or not the dataset has data.
     1369    TYPE(DSET5D), INTENT(in)     :: dset !! Dataset to check
     1370    LOGICAL                      :: yes  !! return status
     1371    yes =  (ALLOCATED(dset%data).AND. &
     1372            ALLOCATED(dset%x)   .AND. &   
     1373            ALLOCATED(dset%y)   .AND. &
     1374            ALLOCATED(dset%z)   .AND. &
     1375            ALLOCATED(dset%t)   .AND. &
     1376            ALLOCATED(dset%w))
     1377  END FUNCTION has_d_5d
     1378
     1379  FUNCTION nc_wr_1d(path,dset) RESULT(ret)
     1380    CHARACTER(len=*), INTENT(in) :: path !! Path of the netcdf file.
     1381    TYPE(DSET1D), INTENT(in)     :: dset !! Dataset to write
     1382    LOGICAL                      :: ret  !! Return status
     1383    INTEGER                                 :: fi,vi,nd,ds,iret
     1384    INTEGER, DIMENSION(:), ALLOCATABLE      :: di
     1385    REAL(kind=8), DIMENSION(:), ALLOCATABLE :: tv
     1386    CHARACTER(len=15)                       :: i2s
     1387    LOGICAL                                 :: hxd,ok
     1388    INTEGER                                 :: xid,vid
     1389    ret = has_data(dset)
     1390    IF (.NOT.ret) RETURN
     1391    ret = .false.
     1392    INQUIRE(FILE=TRIM(path),EXIST=ok)
     1393    IF (ok) THEN
     1394      IF (NF90_OPEN(TRIM(path), NF90_WRITE, fi) /= NF90_NOERR) RETURN
     1395    ELSE
     1396      IF (NF90_CREATE(TRIM(path), NF90_NOCLOBBER, fi) /= NF90_NOERR) RETURN
     1397    ENDIF
     1398    iret = NF90_CLOSE(fi)
     1399    ! if variable already exist: get out of here !
     1400    IF (get_nc_info(path,dset%dname,fi,vi,di)) RETURN
     1401
     1402    iret = NF90_OPEN(path,NF90_WRITE,fi)
     1403
     1404    hxd = nc_get_dim_by_name(fi,dset%xname,tv,ds,xid)
     1405    IF (hxd) THEN
     1406      IF(.NOT.compare(dset%x,tv)) THEN ; ret = .false. ; RETURN ; ENDIF
     1407    ENDIF
     1408
     1409    IF (.NOT.hxd) THEN
     1410      ret = nc_set_dim(fi,dset%xname,dset%x,xid)
     1411      IF (.NOT.ret) THEN ; iret= NF90_CLOSE(fi) ; RETURN ; ENDIF
     1412    ENDIF
     1413    ret = .false.
     1414    iret = nf90_redef(fi)
     1415    iret = nf90_def_var(fi, TRIM(dset%dname), nf90_double,(/xid/),vid)
     1416    IF (iret /= 0) THEN ; iret = NF90_CLOSE(fi) ; RETURN ; ENDIF
     1417    iret = nf90_enddef(fi)
     1418    iret = nf90_put_var(fi,vid,dset%data)
     1419    ret = (iret == 0)
     1420    iret=NF90_CLOSE(fi)
     1421    ret = .true.
     1422    RETURN
     1423  END FUNCTION nc_wr_1d
     1424
     1425  FUNCTION nc_wr_2d(path,dset) RESULT(ret)
     1426    CHARACTER(len=*), INTENT(in) :: path !! Path of the netcdf file.
     1427    TYPE(DSET2D), INTENT(in)     :: dset !! Dataset to write
     1428    LOGICAL                      :: ret  !! Return status
     1429    INTEGER                                 :: fi,vi,nd,ds,iret,nferr
     1430    INTEGER, DIMENSION(:), ALLOCATABLE      :: di
     1431    REAL(kind=8), DIMENSION(:), ALLOCATABLE :: tv
     1432    CHARACTER(len=15)                       :: i2s
     1433    LOGICAL                                 :: hxd,hyd,ok
     1434    INTEGER                                 :: xid,yid,vid
     1435    ret = has_data(dset)
     1436    IF (.NOT.ret) RETURN
     1437    ret = .false.
     1438    INQUIRE(FILE=TRIM(path),EXIST=ok)
     1439    IF (ok) THEN
     1440      IF (NF90_OPEN(TRIM(path), NF90_WRITE, fi) /= NF90_NOERR) RETURN
     1441    ELSE
     1442      IF (NF90_CREATE(TRIM(path), NF90_NOCLOBBER, fi) /= NF90_NOERR) RETURN
     1443    ENDIF
     1444    iret = NF90_CLOSE(fi)
     1445
     1446    ! if variable already exist: get out of here !
     1447    IF (get_nc_info(path,dset%dname,fi,vi,di)) RETURN
     1448
     1449    iret = NF90_OPEN(path,NF90_WRITE,fi)
     1450
     1451    hxd = nc_get_dim_by_name(fi,dset%xname,tv,ds,xid)
     1452    IF (hxd) THEN
     1453      IF(.NOT.compare(dset%x,tv)) THEN ; ret = .false. ; RETURN ; ENDIF
     1454    ENDIF
     1455    hyd = nc_get_dim_by_name(fi,dset%yname,tv,ds,yid)
     1456    IF (hyd) THEN
     1457      IF(.NOT.compare(dset%y,tv)) THEN ; ret = .false. ; RETURN ; ENDIF
     1458    ENDIF
     1459
     1460    IF (.NOT.hxd) THEN
     1461      ret = nc_set_dim(fi,dset%xname,dset%x,xid)
     1462      IF (.NOT.ret) THEN ; iret= NF90_CLOSE(fi) ; RETURN ; ENDIF
     1463    ENDIF
     1464    IF (.NOT.hyd) THEN
     1465      ret = nc_set_dim(fi,dset%yname,dset%y,yid)
     1466      IF (.NOT.ret) THEN ; iret = NF90_CLOSE(fi) ; RETURN ; ENDIF
     1467    ENDIF
     1468    ret = .false.
     1469    iret = nf90_redef(fi)
     1470    iret = nf90_def_var(fi, TRIM(dset%dname), nf90_double,(/xid,yid/),vid)
     1471    IF (iret /= 0) THEN ; iret = NF90_CLOSE(fi) ; RETURN ; ENDIF
     1472    iret = nf90_enddef(fi)
     1473    iret = nf90_put_var(fi,vid,dset%data)
     1474    ret = (iret == 0)
     1475    iret=NF90_CLOSE(fi)
     1476    ret = .true.
     1477    RETURN
     1478  END FUNCTION nc_wr_2d
     1479
     1480  FUNCTION nc_wr_3d(path,dset) RESULT(ret)
     1481    CHARACTER(len=*), INTENT(in) :: path !! Path of the netcdf file.
     1482    TYPE(DSET3D), INTENT(in)     :: dset !! Dataset to write
     1483    LOGICAL                      :: ret  !! Return status
     1484    INTEGER                                 :: fi,vi,nd,ds,iret
     1485    INTEGER, DIMENSION(:), ALLOCATABLE      :: di
     1486    REAL(kind=8), DIMENSION(:), ALLOCATABLE :: tv
     1487    CHARACTER(len=15)                       :: i2s
     1488    LOGICAL                                 :: hxd,hyd,hzd,ok
     1489    INTEGER                                 :: xid,yid,zid,vid
     1490    ret = has_data(dset)
     1491    IF (.NOT.ret) RETURN
     1492    ret = .false.
     1493    INQUIRE(FILE=TRIM(path),EXIST=ok)
     1494    IF (ok) THEN
     1495      IF (NF90_OPEN(TRIM(path), NF90_WRITE, fi) /= NF90_NOERR) RETURN
     1496    ELSE
     1497      IF (NF90_CREATE(TRIM(path), NF90_NOCLOBBER, fi) /= NF90_NOERR) RETURN
     1498    ENDIF
     1499    iret = NF90_CLOSE(fi)
     1500
     1501    ! if variable already exist: get out of here !
     1502    IF (get_nc_info(path,dset%dname,fi,vi,di)) RETURN
     1503
     1504    iret = NF90_OPEN(path,NF90_WRITE,fi)
     1505
     1506    hxd = nc_get_dim_by_name(fi,dset%xname,tv,ds,xid)
     1507    IF (hxd) THEN
     1508      IF(.NOT.compare(dset%x,tv)) THEN ; ret = .false. ; RETURN ; ENDIF
     1509    ENDIF
     1510    hyd = nc_get_dim_by_name(fi,dset%yname,tv,ds,yid)
     1511    IF (hyd) THEN
     1512      IF(.NOT.compare(dset%y,tv)) THEN ; ret = .false. ; RETURN ; ENDIF
     1513    ENDIF
     1514    hzd = nc_get_dim_by_name(fi,dset%zname,tv,ds,zid)
     1515    IF (hzd) THEN
     1516      IF(.NOT.compare(dset%z,tv)) THEN ; ret = .false. ; RETURN ; ENDIF
     1517    ENDIF
     1518
     1519    IF (.NOT.hxd) THEN
     1520      ret = nc_set_dim(fi,dset%xname,dset%x,xid)
     1521      IF (.NOT.ret) THEN ; iret= NF90_CLOSE(fi) ; RETURN ; ENDIF
     1522    ENDIF
     1523    IF (.NOT.hyd) THEN
     1524      ret = nc_set_dim(fi,dset%yname,dset%y,yid)
     1525      IF (.NOT.ret) THEN ; iret = NF90_CLOSE(fi) ; RETURN ; ENDIF
     1526    ENDIF
     1527    IF (.NOT.hzd) THEN
     1528      ret = nc_set_dim(fi,dset%zname,dset%z,zid)
     1529      IF (.NOT.ret) THEN ; iret = NF90_CLOSE(fi) ; RETURN ; ENDIF
     1530    ENDIF
     1531    ret = .false.
     1532    iret = nf90_redef(fi)
     1533    iret = nf90_def_var(fi, TRIM(dset%dname), nf90_double,(/xid,yid,zid/),vid)
     1534    IF (iret /= 0) THEN ; iret = NF90_CLOSE(fi) ; RETURN ; ENDIF
     1535    iret = nf90_enddef(fi)
     1536    iret = nf90_put_var(fi,vid,dset%data)
     1537    ret = (iret == 0)
     1538    iret=NF90_CLOSE(fi)
     1539    ret = .true.
     1540    RETURN
     1541  END FUNCTION nc_wr_3d
     1542
     1543  FUNCTION nc_wr_4d(path,dset) RESULT(ret)
     1544    CHARACTER(len=*), INTENT(in) :: path !! Path of the netcdf file.
     1545    TYPE(DSET4D), INTENT(in)     :: dset !! Dataset to write
     1546    LOGICAL                      :: ret  !! Return status
     1547    INTEGER                                 :: fi,vi,nd,ds,iret
     1548    INTEGER, DIMENSION(:), ALLOCATABLE      :: di
     1549    REAL(kind=8), DIMENSION(:), ALLOCATABLE :: tv
     1550    CHARACTER(len=15)                       :: i2s
     1551    LOGICAL                                 :: hxd,hyd,hzd,htd,ok
     1552    INTEGER                                 :: xid,yid,zid,tid,vid
     1553    ret = has_data(dset)
     1554    IF (.NOT.ret) RETURN
     1555    ret = .false.
     1556    INQUIRE(FILE=TRIM(path),EXIST=ok)
     1557    IF (ok) THEN
     1558      IF (NF90_OPEN(TRIM(path), NF90_WRITE, fi) /= NF90_NOERR) RETURN
     1559    ELSE
     1560      IF (NF90_CREATE(TRIM(path), NF90_NOCLOBBER, fi) /= NF90_NOERR) RETURN
     1561    ENDIF
     1562    iret = NF90_CLOSE(fi)
     1563
     1564    ! if variable already exist: get out of here !
     1565    IF (get_nc_info(path,dset%dname,fi,vi,di)) RETURN
     1566
     1567    iret = NF90_OPEN(path,NF90_WRITE,fi)
     1568
     1569    hxd = nc_get_dim_by_name(fi,dset%xname,tv,ds,xid)
     1570    IF (hxd) THEN
     1571      IF(.NOT.compare(dset%x,tv)) THEN ; ret = .false. ; RETURN ; ENDIF
     1572    ENDIF
     1573    hyd = nc_get_dim_by_name(fi,dset%yname,tv,ds,yid)
     1574    IF (hyd) THEN
     1575      IF(.NOT.compare(dset%y,tv)) THEN ; ret = .false. ; RETURN ; ENDIF
     1576    ENDIF
     1577    hzd = nc_get_dim_by_name(fi,dset%zname,tv,ds,zid)
     1578    IF (hzd) THEN
     1579      IF(.NOT.compare(dset%z,tv)) THEN ; ret = .false. ; RETURN ; ENDIF
     1580    ENDIF
     1581    htd = nc_get_dim_by_name(fi,dset%tname,tv,ds,tid)
     1582    IF (htd) THEN
     1583      IF(.NOT.compare(dset%t,tv)) THEN ; ret = .false. ; RETURN ; ENDIF
     1584    ENDIF
     1585
     1586    IF (.NOT.hxd) THEN
     1587      ret = nc_set_dim(fi,dset%xname,dset%x,xid)
     1588      IF (.NOT.ret) THEN ; iret= NF90_CLOSE(fi) ; RETURN ; ENDIF
     1589    ENDIF
     1590    IF (.NOT.hyd) THEN
     1591      ret = nc_set_dim(fi,dset%yname,dset%y,yid)
     1592      IF (.NOT.ret) THEN ; iret = NF90_CLOSE(fi) ; RETURN ; ENDIF
     1593    ENDIF
     1594    IF (.NOT.hzd) THEN
     1595      ret = nc_set_dim(fi,dset%zname,dset%z,zid)
     1596      IF (.NOT.ret) THEN ; iret = NF90_CLOSE(fi) ; RETURN ; ENDIF
     1597    ENDIF
     1598    IF (.NOT.htd) THEN
     1599      ret = nc_set_dim(fi,dset%tname,dset%t,tid)
     1600      IF (.NOT.ret) THEN ; iret = NF90_CLOSE(fi) ; RETURN ; ENDIF
     1601    ENDIF
     1602    ret = .false.
     1603    iret = nf90_redef(fi)
     1604    iret = nf90_def_var(fi, TRIM(dset%dname), nf90_double,(/xid,yid,zid,tid/),vid)
     1605    IF (iret /= 0) THEN ; iret = NF90_CLOSE(fi) ; RETURN ; ENDIF
     1606    iret = nf90_enddef(fi)
     1607    iret = nf90_put_var(fi,vid,dset%data)
     1608    ret = (iret == 0)
     1609    iret=NF90_CLOSE(fi)
     1610    ret = .true.
     1611    RETURN
     1612  END FUNCTION nc_wr_4d
     1613
     1614  FUNCTION nc_wr_5d(path,dset) RESULT(ret)
     1615    CHARACTER(len=*), INTENT(in) :: path !! Path of the netcdf file.
     1616    TYPE(DSET5D), INTENT(in)     :: dset !! Dataset to write
     1617    LOGICAL                      :: ret  !! Return status
     1618    INTEGER                                 :: fi,vi,nd,ds,iret
     1619    INTEGER, DIMENSION(:), ALLOCATABLE      :: di
     1620    REAL(kind=8), DIMENSION(:), ALLOCATABLE :: tv
     1621    CHARACTER(len=15)                       :: i2s
     1622    LOGICAL                                 :: hxd,hyd,hzd,htd,hwd,ok
     1623    INTEGER                                 :: xid,yid,zid,tid,wid,vid
     1624    ret = has_data(dset)
     1625    IF (.NOT.ret) RETURN
     1626    ret = .false.
     1627    INQUIRE(FILE=TRIM(path),EXIST=ok)
     1628    IF (ok) THEN
     1629      IF (NF90_OPEN(TRIM(path), NF90_WRITE, fi) /= NF90_NOERR) RETURN
     1630    ELSE
     1631      IF (NF90_CREATE(TRIM(path), NF90_NOCLOBBER, fi) /= NF90_NOERR) RETURN
     1632    ENDIF
     1633    iret = NF90_CLOSE(fi)
     1634
     1635    ! if variable already exist: get out of here !
     1636    IF (get_nc_info(path,dset%dname,fi,vi,di)) RETURN
     1637
     1638    iret = NF90_OPEN(path,NF90_WRITE,fi)
     1639
     1640    hxd = nc_get_dim_by_name(fi,dset%xname,tv,ds,xid)
     1641    IF (hxd) THEN
     1642      IF(.NOT.compare(dset%x,tv)) THEN ; ret = .false. ; RETURN ; ENDIF
     1643    ENDIF
     1644    hyd = nc_get_dim_by_name(fi,dset%yname,tv,ds,yid)
     1645    IF (hyd) THEN
     1646      IF(.NOT.compare(dset%y,tv)) THEN ; ret = .false. ; RETURN ; ENDIF
     1647    ENDIF
     1648    hzd = nc_get_dim_by_name(fi,dset%zname,tv,ds,zid)
     1649    IF (hzd) THEN
     1650      IF(.NOT.compare(dset%z,tv)) THEN ; ret = .false. ; RETURN ; ENDIF
     1651    ENDIF
     1652    htd = nc_get_dim_by_name(fi,dset%tname,tv,ds,tid)
     1653    IF (htd) THEN
     1654      IF(.NOT.compare(dset%t,tv)) THEN ; ret = .false. ; RETURN ; ENDIF
     1655    ENDIF
     1656    hwd = nc_get_dim_by_name(fi,dset%wname,tv,ds,wid)
     1657    IF (hwd) THEN
     1658      IF (.NOT.compare(dset%w,tv)) THEN ; ret = .false. ; RETURN ; ENDIF
     1659    ENDIF
     1660
     1661    IF (.NOT.hxd) THEN
     1662      ret = nc_set_dim(fi,dset%xname,dset%x,xid)
     1663      IF (.NOT.ret) THEN ; iret= NF90_CLOSE(fi) ; RETURN ; ENDIF
     1664    ENDIF
     1665    IF (.NOT.hyd) THEN
     1666      ret = nc_set_dim(fi,dset%yname,dset%y,yid)
     1667      IF (.NOT.ret) THEN ; iret = NF90_CLOSE(fi) ; RETURN ; ENDIF
     1668    ENDIF
     1669    IF (.NOT.hzd) THEN
     1670      ret = nc_set_dim(fi,dset%zname,dset%z,zid)
     1671      IF (.NOT.ret) THEN ; iret = NF90_CLOSE(fi) ; RETURN ; ENDIF
     1672    ENDIF
     1673    IF (.NOT.htd) THEN
     1674      ret = nc_set_dim(fi,dset%tname,dset%t,tid)
     1675      IF (.NOT.ret) THEN ; iret = NF90_CLOSE(fi) ; RETURN ; ENDIF
     1676    ENDIF
     1677    IF (.NOT.hwd) THEN
     1678      ret = nc_set_dim(fi,dset%wname,dset%w,wid)
     1679      IF (.NOT.ret) THEN ; iret = NF90_CLOSE(fi) ; RETURN ; ENDIF
     1680    ENDIF
     1681    ret = .false.
     1682    iret = nf90_redef(fi)
     1683    iret = nf90_def_var(fi, TRIM(dset%dname), nf90_double,(/xid,yid,zid,tid,wid/),vid)
     1684    IF (iret /= 0) THEN ; iret = NF90_CLOSE(fi) ; RETURN ; ENDIF
     1685    iret = nf90_enddef(fi)
     1686    iret = nf90_put_var(fi,vid,dset%data)
     1687    ret = (iret == 0)
     1688    iret=NF90_CLOSE(fi)
     1689    ret = .true.
     1690    RETURN
     1691  END FUNCTION nc_wr_5d
     1692
     1693  FUNCTION nc_set_dim(fid,name,values,dimid) RESULT(ret)
     1694    !! Set a new dimension (and its associated values) in a NetCDF file.
     1695    INTEGER, INTENT(in)                    :: fid    !! Netcdf file id.
     1696    CHARACTER(len=*), INTENT(in)           :: name   !! Name of the dimension to set.
     1697    REAL(kind=8), DIMENSION(:), INTENT(in) :: values !! Associated values.
     1698    INTEGER, INTENT(out)                   :: dimid  !! Output dimension id.
     1699    LOGICAL                                :: ret    !! Return status
     1700    INTEGER :: iret,vid
     1701    ret = .false.
     1702    iret = nf90_redef(fid)
     1703    iret = nf90_def_dim(fid, TRIM(name), size(values), dimid)
     1704    WRITE(*,'(a)') "nc_set_dim: "//TRIM(name)//" --> "//TRIM(nf90_strerror(iret))
     1705    IF (iret /=0) RETURN
     1706    iret = nf90_def_var(fid, TRIM(name), nf90_double,(/dimid/),vid)
     1707    IF (iret /=0) RETURN
     1708    iret = nf90_enddef(fid)
     1709    iret = nf90_put_var(fid, vid,values)
     1710    ret = .true.
     1711  END FUNCTION nc_set_dim
     1712
     1713  FUNCTION compare(vec1,vec2,tol) RESULT(ret)
     1714    !! Compare two vector of double.
     1715    !!
     1716    !! The test is checked against the difference (element wise) of the two vector compared to
     1717    !! to a given tolerance.
     1718    REAL(kind=8), DIMENSION(:), INTENT(in) :: vec1 !! First vector to compare
     1719    REAL(kind=8), DIMENSION(:), INTENT(in) :: vec2 !! Second vector to compare
     1720    REAL(kind=8), INTENT(in), OPTIONAL     :: tol  !! Tolerance to apply for the comparison
     1721    LOGICAL :: ret                                 !! .true. if both vectors are equal, .false. otherwise.
     1722    REAL(kind=8) :: ztol
     1723    INTEGER      :: i
     1724    ztol = 1d-10 ; IF (PRESENT(tol)) ztol = abs(tol)
     1725    ret = .false.
     1726    IF (size(vec1) /= size(vec2)) RETURN
     1727
     1728    DO i=1,size(vec1) ; IF (abs(vec1(i)-vec2(i)) > ztol) RETURN ; ENDDO
     1729    ret = .true.
     1730  END FUNCTION compare
     1731
     1732
     1733
    12621734END MODULE DATASETS

  • trunk/LMDZ.TITAN/libf/muphytitan/defined.h

    r1793 r1897  
    1 /* Copyright Jérémie Burgalat (2010-2015)
     1/* Copyright Jérémie Burgalat (2010-2015,2017)
    22 *
    3  * burgalat.jeremie@gmail.com
     3 * jeremie.burgalat@univ-reims.fr
    44 *
    55 * This software is a computer program whose purpose is to provide configuration
    … …  
    7676/* Defines SSLEN if needed */
    7777#ifndef SSLEN
    78 #define SSLEN 200
     78#define SSLEN 250
    7979#endif
    8080
    8181/* Defines SLLEN if needed */
    8282#ifndef SLLEN
    83 #define SLLEN 2000
     83#define SLLEN 2500
    8484#endif

  • trunk/LMDZ.TITAN/libf/muphytitan/errors.F90

    r1814 r1897  
    1 ! Copyright Jérémie Burgalat (2010-2015)
    2 !
    3 ! burgalat.jeremie@gmail.com
     1! Copyright Jérémie Burgalat (2010-2015,2017)
     2!
     3! jeremie.burgalat@univ-reims.fr
    44!
    55! This software is a computer program whose purpose is to provide configuration
    … …  
    3333
    3434!! file: errors.F90
    35 !! summary: Errors handling source file
    36 !! author: Burgalat
    37 !! date: 2013-2015
     35!! summary: Errors handling source file.
     36!! author: J. Burgalat
     37!! date: 2013-2015,2017
    3838
    3939#include "defined.h"
    … …  
    8484    CONTAINS
    8585      PROCEDURE, PUBLIC :: to_string => error_to_string
     86        !! Get a string representation of the error
    8687#endif
    8788  END TYPE error
    … …  
    201202    IF (err /= 0) THEN
    202203      WRITE(*,'(a)') error_to_string(err)
    203       CALL EXIT(abs(err%id))
     204      CALL EXIT(err%id)
    204205    ENDIF
    205206  END SUBROUTINE aborting
    … …  
    229230    !! The method raises an assertion and stops the execution if __test__ is .false.
    230231    !!
    231     !! See [[errors(module):assert_r(subroutine)] remark.
     232    !! See [[errors(module):assert_r(subroutine)]] remark.
    232233    LOGICAL, INTENT(in)         :: test
    233234     !! Expression to test.
    … …  
    242243  END SUBROUTINE assert_w
    243244
     245  FUNCTION free_lun() RESULT(lu)
     246    !> Get the first free logical unit
     247    !!
     248    !! The function loops from 7 to 9999 and returns the first free logical unit.
     249    !! @note
     250    !! According to Fortran standard, the maximum value for a lun is processor
     251    !! dependent. I just assume that [7,9999] is a valid range and I believe that
     252    !! 9992 files to be opened is far enough for any program !
     253    !! @note
     254    !! If you intend to use loggers object from this library, you should keep in
     255    !! mind that loggers open files with the first free logical unit. Consequently
     256    !! if you need to perform I/O operations you should use this function to get a
     257    !! free lun instead of just randomly set a lun !
     258    INTEGER :: lu
     259      !! First free logical unit in the range [7,9999]  or -1 if no lun is available
     260    INTEGER, PARAMETER :: mxlu = 9999
     261    LOGICAL :: notfree
     262    lu = 6 ; notfree = .true.
     263    DO WHILE(notfree.AND.lu<=mxlu)
     264      lu=lu+1 ; INQUIRE(unit=lu,OPENED=notfree)
     265    ENDDO
     266    IF (lu >= mxlu) lu = -1
     267  END FUNCTION free_lun
     268
     269
    244270
    245271END MODULE ERRORS

  • trunk/LMDZ.TITAN/libf/muphytitan/fsystem.F90

    r1793 r1897  
    1 ! Copyright Jérémie Burgalat (2010-2015)
     1! Copyright Jérémie Burgalat (2010-2015,2017)
    22!
    3 ! burgalat.jeremie@gmail.com
     3! jeremie.burgalat@univ-reims.fr
    44!
    55! This software is a computer program whose purpose is to provide configuration
    … …  
    3333
    3434!! file: fsystem.F90
    35 !! summary: File system methods source file
    36 !! date: 2013-2015
    37 !! author: Burgalat
     35!! summary: File system methods source file.
     36!! author: J. Burgalat
     37!! date: 2013-2015,2017
     38
    3839
    3940#include "defined.h"
    … …  
    4849
    4950  PRIVATE :: get_umask
     51  PRIVATE :: c2t
    5052
    5153  INTEGER, PARAMETER :: MAX_PATH = 512 !! Maximum length of a path
    5254
    53 
     55  TYPE, PUBLIC :: chrono
     56    !! Define a simple chronometer
     57    !!
     58    !! This object can be used to get an approximation of the execution of some piece of code.
     59    REAL(kind=8), PRIVATE    :: cpu_start = 0d0   
     60      !! Starting CPU time
     61    INTEGER(kind=8), PRIVATE :: clock_start = 0d0
     62      !! Starting clock time
     63    LOGICAL, PRIVATE         :: on_run = .false.
     64      !! Chrono running state.
     65#if HAVE_FTNPROC
     66    CONTAINS
     67      PROCEDURE :: is_running => chrono_is_running
     68      PROCEDURE :: start      => chrono_start
     69      PROCEDURE :: stop       => chrono_stop
     70      PROCEDURE :: reset      => chrono_reset
     71      PROCEDURE :: get        => chrono_get
     72#endif
     73  END TYPE chrono
     74
     75#ifndef FORD_DOC
     76  ! C interfaces
    5477  INTERFACE
    55 
    5678    FUNCTION strlen_c(s) RESULT(length) bind(C,name="strlen")
    5779      !! Get length of C-string up to (but not including) the terminator
    … …  
    6890
    6991    FUNCTION errno_c() BIND(C,name="c_get_errno")
    70       !! Get last error numbero
     92      !! Get last error numero
    7193      IMPORT C_INT
    7294      INTEGER(kind=C_INT) :: errno_c !! Last errno
    … …  
    209231      INTEGER(kind=C_INT)                    :: mkdirp_c   !! 0 on success, last errno on failure
    210232    END FUNCTION mkdirp_c
     233
     234    FUNCTION copy_c(to,from) BIND(C,name="c_copy")
     235      !! Copy a file.
     236      IMPORT c_char, C_INT
     237      CHARACTER(kind=c_char), INTENT(in)  :: to(*)    !! Destination path.
     238      CHARACTER(kind=c_char), INTENT(in)  :: from(*)  !! Input file path to copy.
     239      INTEGER(kind=C_INT)                 :: copy_c !! 0 on success, 1 on failure.
     240    END FUNCTION copy_c
    211241
    212242    FUNCTION remove_c(path) BIND(C,name="c_remove")
    … …  
    255285    END FUNCTION termsize_c
    256286
     287    FUNCTION getCurrentRSS_c() BIND(C, name="c_getCurrentRSS")
     288      !! Get the current resident set size memory in bytes.
     289      IMPORT  C_SIZE_T
     290      INTEGER(kind=C_SIZE_T) :: getCurrentRSS_c !! Current resident set size in bytes (0 if not available).
     291    END FUNCTION getCurrentRSS_c
     292
     293    FUNCTION getPeakRSS_c() BIND(C, name="c_getPeakRSS")
     294      !! Get the peak resident set size memory in bytes.
     295      IMPORT  C_SIZE_T
     296      INTEGER(kind=C_SIZE_T) :: getPeakRSS_c !! Peak resident set size in bytes (0 if not available).
     297    END FUNCTION getPeakRSS_c
     298
     299    FUNCTION getSystemMemory_c(total,avail,free) BIND(C, name='c_getSystemMemory')
     300      !! Get global memory informations.
     301      IMPORT C_LONG_LONG,C_INT
     302      INTEGER(kind=C_LONG_LONG), INTENT(out) :: total             !! Total available memory.
     303      INTEGER(kind=C_LONG_LONG), INTENT(out) :: avail             !! Current available memory.
     304      INTEGER(kind=C_LONG_LONG), INTENT(out) :: free              !! Current free memory.
     305      INTEGER(kind=C_INT)                    :: getSystemMemory_c !! status, 0 on success, 1 otherwise.
     306    END FUNCTION getSystemMemory_c
    257307  END INTERFACE
    258 
     308#endif
    259309
    260310  CONTAINS
    … …  
    291341    !! @attention
    292342    !! The method does not free the underlying C string and it should be free using
    293     !! [[fsystem(module):free_c(interface)]] method.
     343    !! the subroutine free_c(_cstr_).
    294344    TYPE(C_PTR), INTENT(in) :: cstr
    295345      !! A TYPE(C_PTR) that represent the pointer to the C char array.
    … …  
    476526    RETURN
    477527  END FUNCTION fs_getcwd
     528
     529  FUNCTION fs_copy(input,output) RESULT(ret)
     530    !! Copy input file into output file.
     531    CHARACTER(len=*), INTENT(in)  :: input  !! Input file path to copy.
     532    CHARACTER(len=*), INTENT(in)  :: output !! Output file path destination.
     533    LOGICAL :: ret                          !! True on success, false otherwise.
     534    IF (LEN_TRIM(input) == 0 .OR. LEN_TRIM(output) == 0 .OR. input == output) THEN
     535      ret = .false.
     536    ELSE
     537      ret = INT(copy_c(cstring(ADJUSTL(output)),cstring(ADJUSTL(input)))) == 0
     538    ENDIF
     539    RETURN
     540  END FUNCTION fs_copy
    478541
    479542  FUNCTION fs_remove(path) RESULT(ret)
    … …  
    880943  END SUBROUTINE fs_msleep
    881944
     945  FUNCTION fs_get_memory(peak,units) RESULT(mem)
     946    !! Get the memory usage of the current process.
     947    LOGICAL, INTENT(in), OPTIONAL          :: peak  !! True to retrieve the peak RSS memory, otherwise retrieve the current RSS memory. Default to False.
     948    CHARACTER(len=*), INTENT(in), OPTIONAL :: units !! Output units: either 'B' (Bytes),'KB' (Kilo-),'MB' (Mega-),'GB' (Giga-). Default to 'B'.
     949    REAL(kind=8)                           :: mem   !! Memory usage.
     950    LOGICAL          :: zpeak
     951    CHARACTER(len=2) :: zunits
     952    zpeak = .false. ; IF (PRESENT(peak)) zpeak = peak
     953    zunits = 'B '   ; IF (PRESENT(units)) zunits = units
     954    IF (zunits /= 'B' .AND. zunits /= 'KB' .AND. zunits /= 'MB' .AND. zunits /= 'GB') zunits = 'B '
     955    IF (zpeak) THEN
     956      mem = REAL(getPeakRSS_c(),kind=8)
     957    ELSE
     958      mem = REAL(getCurrentRSS_c(),kind=8)
     959    ENDIF
     960    IF (zunits == 'KB') THEN
     961      mem = mem / 1024d0
     962    ELSE IF (zunits == 'MB') THEN
     963      mem = mem / 1048576d0
     964    ELSE IF (zunits == 'GB') THEN
     965      mem = mem / 1073741824d0
     966    ENDIF
     967    RETURN
     968  END FUNCTION fs_get_memory
     969
     970  FUNCTION fs_get_system_memory(total,available,free,units) RESULT(ret)
     971    !! Get informations about system memory.
     972    !!
     973    !! If no informations is available, output arguments are set to 0 and the method returns false.
     974    REAL(kind=8), INTENT(out), OPTIONAL    :: total      !! Total available memory.
     975    REAL(kind=8), INTENT(out), OPTIONAL    :: available  !! Current available memory.
     976    REAL(kind=8), INTENT(out), OPTIONAL    :: free       !! Current free memory.
     977    CHARACTER(len=*), INTENT(in), OPTIONAL :: units      !! Output units: either 'B' (Bytes),'KB' (Kilo-),'MB' (Mega-),'GB' (Giga-). Default to 'B'.
     978    LOGICAL                                :: ret        !! True on success, false otherwise.
     979    LOGICAL          :: zpeak
     980    CHARACTER(len=2) :: zunits
     981    INTEGER(kind=8)  :: ztot,zava,zfre   
     982
     983    zunits = 'B '   ; IF (PRESENT(units)) zunits = units
     984    IF (zunits /= 'B' .AND. zunits /= 'KB' .AND. zunits /= 'MB' .AND. zunits /= 'GB') zunits = 'B '
     985    ret = INT(getSystemMemory_c(ztot,zava,zfre),kind=4) == 0
     986    ztot = ztot * 1024 ; zava = zava * 1024 ; zfre = zfre * 1024
     987
     988    IF (PRESENT(total))     total     = ztot
     989    IF (PRESENT(available)) available = zava
     990    IF (PRESENT(free))      free      = zfre
     991    IF (.NOT.ret) RETURN
     992
     993    IF (zunits == 'KB') THEN
     994      IF (PRESENT(total))     total     = ztot / 1024d0
     995      IF (PRESENT(available)) available = zava / 1024d0
     996      IF (PRESENT(free))      free      = zfre / 1024d0
     997    ELSE IF (zunits == 'MB') THEN
     998      IF (PRESENT(total))     total     = ztot / 1048576d0
     999      IF (PRESENT(available)) available = zava / 1048576d0
     1000      IF (PRESENT(free))      free      = zfre / 1048576d0
     1001    ELSE IF (zunits == 'GB') THEN
     1002      IF (PRESENT(total))     total     = ztot / 1073741824d0
     1003      IF (PRESENT(available)) available = zava / 1073741824d0
     1004      IF (PRESENT(free))      free      = zfre / 1073741824d0
     1005    ENDIF
     1006    RETURN
     1007  END FUNCTION fs_get_system_memory
     1008
     1009
    8821010!===============================================================================
    8831011! MODULE MISCELLANEOUS METHODS
    … …  
    10321160  END FUNCTION sz2str
    10331161
     1162  FUNCTION chrono_is_running(this) RESULT (ret)
     1163    !! Get chrono's state.
     1164    OBJECT(chrono), INTENT(in) :: this !! Chrono object reference.
     1165    LOGICAL :: ret                    !! Running state.
     1166    ret = this%on_run
     1167    RETURN
     1168  END FUNCTION chrono_is_running
     1169
     1170  SUBROUTINE chrono_start(this)
     1171    !! Start the chrono.
     1172    !!
     1173    !! @note
     1174    !! Calling the method multiple times without explicitly stopping the chrono
     1175    !! [[chrono(type):stop(bound)]] does nothing (except for the first called).
     1176    OBJECT(chrono), INTENT(inout) :: this  !! Chrono object reference.
     1177    IF (.NOT.this%on_run) THEN
     1178      CALL CPU_TIME(this%cpu_start)
     1179      CALL SYSTEM_CLOCK(this%clock_start)
     1180    ENDIF
     1181    this%on_run = .true.
     1182  END SUBROUTINE chrono_start
     1183
     1184  SUBROUTINE chrono_stop(this)
     1185    !! Stop the chrono.
     1186    OBJECT(chrono), INTENT(inout) :: this !! Chrono object reference.
     1187    REAL(kind=8)    :: ecpu
     1188    INTEGER(kind=8) :: eclk,nbm,nbr
     1189    this%on_run = .false.
     1190  END SUBROUTINE chrono_stop
     1191
     1192  SUBROUTINE chrono_reset(this)
     1193    !! Reset the chrono's internal elapsed times.
     1194    OBJECT(chrono), INTENT(inout) :: this !! Chrono object reference.
     1195    CALL CPU_TIME(this%cpu_start)
     1196    CALL SYSTEM_CLOCK(this%clock_start)
     1197  END SUBROUTINE chrono_reset
     1198
     1199  SUBROUTINE chrono_get(this,cpu,clock,units)
     1200    !! Get elapsed time since last call of start or reset methods.
     1201    !!
     1202    !! The method computes the time elapsed in two ways :
     1203    !!
     1204    !! - If the [[fsystem(module):chrono(type)]] is not running, the method retruns 0.
     1205    !! - Otherwise, elapsed time since the last call of
     1206    !!   [[chrono(type):start(bound)]] (or [[chrono(type):reset(bound)]]).
     1207    OBJECT(chrono), INTENT(in)             :: this
     1208      !! Chrono object reference.
     1209    REAL(kind=8), INTENT(out), OPTIONAL    :: cpu
     1210      !! Elapsed cpu time in seconds by default (see units argument).
     1211    REAL(kind=8), INTENT(out), OPTIONAL    :: clock
     1212      !! Elapsed system clock time in seconds by default (see units argument).
     1213    CHARACTER(len=2), INTENT(in), OPTIONAL :: units
     1214      !! A two characters wide string with the units to convert in. Units should
     1215      !! be one of the following : 'ms', 's' (default), 'm', 'h' or 'd'.
     1216    CHARACTER(len=2) :: zu
     1217    REAL(kind=8)     :: cu, fact
     1218    INTEGER(kind=8)  :: ck, r, m
     1219    IF (this%on_run) THEN
     1220      IF (PRESENT(cpu)) THEN
     1221        CALL CPU_TIME(cu)
     1222        cpu = (cu - this%cpu_start)
     1223      ENDIF
     1224      IF (PRESENT(clock)) THEN
     1225        CALL SYSTEM_CLOCK(ck,r,m)
     1226        clock = c2t(ck,this%clock_start,r,m)
     1227      ENDIF
     1228    ELSE
     1229      IF (PRESENT(cpu))   cpu = 0d0
     1230      IF (PRESENT(clock)) clock = 0d0
     1231    ENDIF
     1232    fact = 1d0
     1233    zu = 's'
     1234    IF (PRESENT(units))  THEN
     1235      zu = units
     1236      SELECT CASE(zu)
     1237        CASE ('d') ; fact = 3600d0*24.
     1238        CASE ('h') ; fact = 3600d0
     1239        CASE ('m') ; fact = 60d0
     1240        CASE ('ms') ; fact = 1d-3
     1241        CASE DEFAULT ; fact = 1d0
     1242      END SELECT
     1243    ENDIF
     1244    IF (PRESENT(cpu)) cpu = cpu / fact
     1245    IF (PRESENT(clock)) clock = clock / fact
     1246  END SUBROUTINE chrono_get
     1247
     1248  FUNCTION c2t(e,i,r,m) RESULT(time)
     1249    !! Get the real-time between two clock counts from system_clock.
     1250    INTEGER(kind=8), INTENT(in) :: e !! Final clock count
     1251    INTEGER(kind=8), INTENT(in) :: i !! Initial clock count
     1252    INTEGER(kind=8), INTENT(in) :: r !! Clock count rate
     1253    INTEGER(kind=8), INTENT(in) :: m !! Maximum Clock count value
     1254    REAL(kind=8)    :: time          !! Time in seconds
     1255    INTEGER(kind=8) :: nc
     1256    nc = e-i ; IF (e < i) nc = nc+m
     1257    time = REAL(nc,kind=8)/r
     1258    RETURN
     1259  END FUNCTION c2t
    10341260END MODULE FSYSTEM
     1261

  • trunk/LMDZ.TITAN/libf/muphytitan/mm_clouds.f90

    r1793 r1897  
    1 ! Copyright 2013-2015 Université de Reims Champagne-Ardenne
     1! Copyright 2013-2015,2017 Université de Reims Champagne-Ardenne
    22! Contributor: J. Burgalat (GSMA, URCA)
    33! email of the author : jeremie.burgalat@univ-reims.fr
    … …  
    3535!! summary: Clouds microphysics module
    3636!! author: J. Burgalat
    37 !! date: 2013-2015
     37!! date: 2013-2015,2017
    3838
    3939MODULE MM_CLOUDS

  • trunk/LMDZ.TITAN/libf/muphytitan/mm_globals.f90

    r1814 r1897  
    1 ! Copyright 2013-2015 Université de Reims Champagne-Ardenne
     1! Copyright 2013-2015,2017 Université de Reims Champagne-Ardenne
    22! Contributor: J. Burgalat (GSMA, URCA)
    33! email of the author : jeremie.burgalat@univ-reims.fr
    … …  
    3535!! summary: Parameters and global variables module.
    3636!! author: J. Burgalat
    37 !! date: 2013-2015
     37!! date: 2013-2015,2017
    3838
    3939MODULE MM_GLOBALS
    … …  
    141141  ! from swift
    142142  USE CFGPARSE
    143   USE STRINGS
     143  USE STRING_OP
    144144  USE ERRORS
    145145  IMPLICIT NONE
    … …  
    166166  PROTECTED :: mm_rcs, mm_rcf, mm_drad, mm_drho
    167167
    168   LOGICAL, SAVE :: mm_debug = .true.  !! Enable QnD debug mode.
    169   LOGICAL, SAVE :: mm_log = .false.   !! Enable log mode.
     168  LOGICAL, SAVE :: mm_debug = .true.  !! Enable QnD debug mode (can be used for devel).
     169  LOGICAL, SAVE :: mm_log = .false.   !! Enable log mode (for configuration only).
    170170
    171171  LOGICAL, SAVE :: mm_w_haze_prod = .true. !! Enable/Disable haze production.
    … …  
    177177
    178178  LOGICAL, SAVE :: mm_var_prod = .false. !! Time variation of production rate control flag.
     179
     180  LOGICAL, SAVE :: mm_use_effg = .true. !! Enable/Disable effective G for computations.
    179181
    180182  !> Enable/Disable __Fiadero__'s correction.
    … …  
    689691      ALLOCATE(mm_spcname(mm_nesp),mm_xESPS(mm_nesp))
    690692      DO i=1,mm_nesp
    691         mm_spcname(i) = str_to_lower(species(i))
     693        mm_spcname(i) = to_lower(species(i))
    692694        IF(.NOT.cfg_has_section(cp,TRIM(mm_spcname(i)))) THEN
    693695          err = error("mm_global_init: Cannot find "//TRIM(mm_spcname(i))//" properties",-1)
    … …  
    866868      !mm_spcname(1:mm_nesp) = species(:)
    867869      DO i=1,mm_nesp
    868         mm_spcname(i) = str_to_lower(species(i))
     870        mm_spcname(i) = to_lower(species(i))
    869871        IF (.NOT.cfg_has_section(spccfg,TRIM(mm_spcname(i)))) THEN
    870872          err = error("mm_global_init: Cannot find "//TRIM(mm_spcname(i))//" properties",-1)
    … …  
    12141216    REAL(kind=mm_wp), INTENT(in) :: z !! Altitude in meters
    12151217    REAL(kind=mm_wp) :: effg          !! Effective gravitational acceleration in \(m.s^{-2}\)
    1216     effg = mm_g0 * (mm_rpla/(mm_rpla+z))**2
     1218    effg = mm_g0
     1219    IF (mm_use_effg) effg = effg * (mm_rpla/(mm_rpla+z))**2
    12171220    RETURN
    12181221  END FUNCTION mm_effg

  • trunk/LMDZ.TITAN/libf/muphytitan/mm_haze.f90

    r1819 r1897  
    1 ! Copyright 2013-2015 Université de Reims Champagne-Ardenne
     1! Copyright 2013-2015,2017 Université de Reims Champagne-Ardenne
    22! Contributor: J. Burgalat (GSMA, URCA)
    33! email of the author : jeremie.burgalat@univ-reims.fr
    … …  
    3535!! summary: Haze microphysics module.
    3636!! author: J. Burgalat
    37 !! date: 2013-2015
    38 
     37!! date: 2013-2015,2017
    3938MODULE MM_HAZE
    4039  !! Haze microphysics module.

  • trunk/LMDZ.TITAN/libf/muphytitan/mm_interfaces.f90

    r1793 r1897  
    1 ! Copyright 2013-2015 Université de Reims Champagne-Ardenne
     1! Copyright 2013-2015,2017 Université de Reims Champagne-Ardenne
    22! Contributor: J. Burgalat (GSMA, URCA)
    33! email of the author : jeremie.burgalat@univ-reims.fr
    … …  
    3535!! summary: Interfaces module for external functions
    3636!! author: J. Burgalat
    37 !! date: 2013-2015
     37!! date: 2013-2015,2017
    3838
    3939MODULE MM_INTERFACES

  • trunk/LMDZ.TITAN/libf/muphytitan/mm_lib.f90

    r1793 r1897  
    1 ! Copyright 2013-2015 Université de Reims Champagne-Ardenne
     1! Copyright 2013-2015,2017 Université de Reims Champagne-Ardenne
    22! Contributor: J. Burgalat (GSMA, URCA)
    33! email of the author : jeremie.burgalat@univ-reims.fr
    … …  
    3535!! summary: MP2M library interface module.
    3636!! author: J. Burgalat
    37 !! date: 2013-2015
     37!! date: 2013-2015,2017
    3838
    3939MODULE MM_LIB

  • trunk/LMDZ.TITAN/libf/muphytitan/mm_methods.f90

    r1793 r1897  
    1 ! Copyright 2013-2015 Université de Reims Champagne-Ardenne
     1! Copyright 2013-2015,2017 Université de Reims Champagne-Ardenne
    22! Contributor: J. Burgalat (GSMA, URCA)
    33! email of the author : jeremie.burgalat@univ-reims.fr
    … …  
    3535!! summary: Model miscellaneous methods module.
    3636!! author: J. Burgalat
    37 !! date: 2013-2015
     37!! date: 2013-2015,2017
    3838
    3939MODULE MM_METHODS

  • trunk/LMDZ.TITAN/libf/muphytitan/mm_microphysic.f90

    r1819 r1897  
    1 ! Copyright 2013-2015 Université de Reims Champagne-Ardenne
     1! Copyright 2013-2015,2017 Université de Reims Champagne-Ardenne
    22! Contributor: J. Burgalat (GSMA, URCA)
    33! email of the author : jeremie.burgalat@univ-reims.fr
    … …  
    3535!! brief: Microphysic processes interface module.
    3636!! author: J. Burgalat
    37 !! date: 2013-2015
     37!! date: 2013-2015,2017
    3838
    3939MODULE MM_MICROPHYSIC
    … …  
    111111      ! add temporary aerosols tendencies (-> m-3)
    112112      dm0a_f = dm0a_f + zdm0a_f  ; dm3a_f = dm3a_f + zdm3a_f
    113       ! sanity check for clouds tendencies
    114       WHERE (mm_m0ccn+dm0n*mm_dzlev < 0) ; dm0n = -mm_m0ccn/mm_dzlev ; END WHERE
    115       WHERE (mm_m3ccn+dm3n*mm_dzlev < 0) ; dm3n = -mm_m3ccn/mm_dzlev ; END WHERE
    116 
    117113      ! reverse directly clouds tendencies (-> m-2)
    118114      dm0n   = dm0n(mm_nla:1:-1) * mm_dzlev(mm_nla:1:-1)
    119115      dm3n   = dm3n(mm_nla:1:-1) * mm_dzlev(mm_nla:1:-1)
     116      ! sanity check for clouds tendencies
     117      WHERE (mm_m0ccn+dm0n < 0) ; dm0n = -mm_m0ccn ; END WHERE
     118      WHERE (mm_m3ccn+dm3n < 0) ; dm3n = -mm_m3ccn ; END WHERE
    120119      DO i=1,mm_nesp
    121120        dm3i(:,i)  = dm3i(mm_nla:1:-1,i)  * mm_dzlev(mm_nla:1:-1)
    122         WHERE (mm_m3ccn+dm3n*mm_dzlev < 0) ; dm3n = -mm_m3ccn/mm_dzlev ; END WHERE
     121        WHERE (mm_m3ice+dm3i < 0) ; dm3i = -mm_m3ice ; END WHERE
    123122        dgazs(:,i) = dgazs(mm_nla:1:-1,i)
    124123        ! no sanity check for gazs, let's prey.
    … …  
    127126      dm0n = 0._mm_wp ; dm3n = 0._mm_wp ; dm3i = 0._mm_wp ; dgazs = 0._mm_wp
    128127    ENDIF
    129     ! sanity check
    130     WHERE (mm_m0aer_s+dm0a_s*mm_dzlev < 0) ; dm0a_s = -mm_m0aer_s/mm_dzlev ; END WHERE
    131     WHERE (mm_m3aer_s+dm3a_f*mm_dzlev < 0) ; dm3a_s = -mm_m3aer_s/mm_dzlev ; END WHERE
    132     WHERE (mm_m0aer_f+dm0a_f*mm_dzlev < 0) ; dm0a_f = -mm_m0aer_f/mm_dzlev ; END WHERE
    133     WHERE (mm_m3aer_f+dm3a_f*mm_dzlev < 0) ; dm3a_f = -mm_m3aer_f/mm_dzlev ; END WHERE
    134 
    135128    ! multiply by altitude thickness and reverse vectors so they go from ground to top :)
    136129    dm0a_s = dm0a_s(mm_nla:1:-1) * mm_dzlev(mm_nla:1:-1)
    … …  
    138131    dm0a_f = dm0a_f(mm_nla:1:-1) * mm_dzlev(mm_nla:1:-1)
    139132    dm3a_f = dm3a_f(mm_nla:1:-1) * mm_dzlev(mm_nla:1:-1)
     133    ! sanity check
     134    WHERE (mm_m0aer_s+dm0a_s < 0) ; dm0a_s = -mm_m0aer_s ; END WHERE
     135    WHERE (mm_m3aer_s+dm3a_f < 0) ; dm3a_s = -mm_m3aer_s ; END WHERE
     136    WHERE (mm_m0aer_f+dm0a_f < 0) ; dm0a_f = -mm_m0aer_f ; END WHERE
     137    WHERE (mm_m3aer_f+dm3a_f < 0) ; dm3a_f = -mm_m3aer_f ; END WHERE
    140138   
    141139    RETURN
    … …  
    167165    ! Calls haze microphysics
    168166    call mm_haze_microphysics(dm0a_s,dm3a_s,dm0a_f,dm3a_f)
    169     ! sanity check
    170     WHERE (mm_m0aer_s+dm0a_s*mm_dzlev < 0) ; dm0a_s = -mm_m0aer_s/mm_dzlev ; END WHERE
    171     WHERE (mm_m3aer_s+dm3a_f*mm_dzlev < 0) ; dm3a_s = -mm_m3aer_s/mm_dzlev ; END WHERE
    172     WHERE (mm_m0aer_f+dm0a_f*mm_dzlev < 0) ; dm0a_f = -mm_m0aer_f/mm_dzlev ; END WHERE
    173     WHERE (mm_m3aer_f+dm3a_f*mm_dzlev < 0) ; dm3a_f = -mm_m3aer_f/mm_dzlev ; END WHERE
    174167    ! reverse vectors so they go from ground to top :)
    175168    dm0a_s = dm0a_s(mm_nla:1:-1) * mm_dzlev(mm_nla:1:-1)
    … …  
    177170    dm0a_f = dm0a_f(mm_nla:1:-1) * mm_dzlev(mm_nla:1:-1)
    178171    dm3a_f = dm3a_f(mm_nla:1:-1) * mm_dzlev(mm_nla:1:-1)
     172    ! sanity check
     173    WHERE (mm_m0aer_s+dm0a_s < 0) ; dm0a_s = -mm_m0aer_s ; END WHERE
     174    WHERE (mm_m3aer_s+dm3a_f < 0) ; dm3a_s = -mm_m3aer_s ; END WHERE
     175    WHERE (mm_m0aer_f+dm0a_f < 0) ; dm0a_f = -mm_m0aer_f ; END WHERE
     176    WHERE (mm_m3aer_f+dm3a_f < 0) ; dm3a_f = -mm_m3aer_f ; END WHERE
    179177    RETURN
    180178  END FUNCTION muphys_nocld

  • trunk/LMDZ.TITAN/libf/muphytitan/mm_mprec.F90

    r1793 r1897  
    1 ! Copyright 2013-2015 Université de Reims Champagne-Ardenne
     1! Copyright 2013-2015,2017 Université de Reims Champagne-Ardenne
    22! Contributor: J. Burgalat (GSMA, URCA)
    33! email of the author : jeremie.burgalat@univ-reims.fr
    … …  
    3535!! summary: Library floating point precision module.
    3636!! author: J. Burgalat
    37 !! date: 2013-2015
     37!! date: 2013-2015,2017
    3838
    3939#ifdef HAVE_CONFIG_H

  • trunk/LMDZ.TITAN/libf/muphytitan/mmp_gcm.f90

    r1819 r1897  
     1! Copyright 2017 Université de Reims Champagne-Ardenne
     2! Contributor: J. Burgalat (GSMA, URCA)
     3! email of the author : jeremie.burgalat@univ-reims.fr
     4!
     5! This software is a computer program whose purpose is to compute
     6! microphysics processes using a two-moments scheme.
     7!
     8! This library is governed by the CeCILL license under French law and
     9! abiding by the rules of distribution of free software.  You can  use,
     10! modify and/ or redistribute the software under the terms of the CeCILL
     11! license as circulated by CEA, CNRS and INRIA at the following URL
     12! "http://www.cecill.info".
     13!
     14! As a counterpart to the access to the source code and  rights to copy,
     15! modify and redistribute granted by the license, users are provided only
     16! with a limited warranty  and the software's author,  the holder of the
     17! economic rights,  and the successive licensors  have only  limited
     18! liability.
     19!
     20! In this respect, the user's attention is drawn to the risks associated
     21! with loading,  using,  modifying and/or developing or reproducing the
     22! software by the user in light of its specific status of free software,
     23! that may mean  that it is complicated to manipulate,  and  that  also
     24! therefore means  that it is reserved for developers  and  experienced
     25! professionals having in-depth computer knowledge. Users are therefore
     26! encouraged to load and test the software's suitability as regards their
     27! requirements in conditions enabling the security of their systems and/or
     28! data to be ensured and,  more generally, to use and operate it in the
     29! same conditions as regards security.
     30!
     31! The fact that you are presently reading this means that you have had
     32! knowledge of the CeCILL license and that you accept its terms.
     33
     34!! file: mmp_gcm.f90
     35!! summary: YAMMS interfaces for the LMDZ GCM.
     36!! author: J. Burgalat
     37!! date: 2017
    138MODULE MMP_GCM
    239  !! Interface to YAMMS for the LMDZ GCM.
     40  USE MMP_GLOBALS
    341  USE MM_LIB
    442  USE CFGPARSE
    … …  
    644  IMPLICIT NONE
    745
    8   PUBLIC
    9 
    10   !> Alpha function parameters.
    11   !!
    12   !! It stores the parameters of the inter-moments relation functions.
    13   !!
    14   !! The inter-moments relation function is represented by the sum of exponential
    15   !! quadratic expressions:
    16   !!
    17   !! $$
    18   !! \displaystyle \alpha(k) = \sum_{i=1}^{n} \exp\left( a_{i}\times k^{2} +
    19   !! b_{i}\times k^{2} +c_{i}\right)
    20   !! $$
    21   TYPE, PUBLIC :: aprm
    22     !> Quadratic coefficients of the quadratic expressions.
    23     REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE :: a
    24     !> Linear coefficients of the quadratic expressions.
    25     REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE :: b
    26     !> Free term of the quadratic expressions.
    27     REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE :: c
    28   END TYPE
    29 
    30   !> Size distribution parameters derived type.
    31   !!
    32   !! It stores the parameters of the size distribution law for Titan.
    33   !!
    34   !! The size distribution law is represented by the minimization of a sum of
    35   !! power law functions:
    36   !!
    37   !! $$
    38   !! \displaystyle n\left(r\right) = \frac{A_{0}}{C+\sum_{i=1}^{n} A_{i}\times
    39   !!                                    \left(\frac{r}{r_{c}}\right)^{-b_{i}}}
    40   !! $$
    41   TYPE, PUBLIC :: nprm
    42     !> Scaling factor.
    43     REAL(kind=mm_wp)                            :: a0
    44     !> Characterisitic radius.
    45     REAL(kind=mm_wp)                            :: rc
    46     !> Additional constant to the sum of power law.
    47     REAL(kind=mm_wp)                            :: c
    48     !> Scaling factor of each power law.
    49     REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE :: a
    50     !> Power of each power law.
    51     REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE :: b
    52   END TYPE
    53 
    54   !> Inter-moment relation set of parameters for the spherical mode.
    55   TYPE(aprm), PUBLIC, SAVE :: mmp_asp
    56   !> Inter-moment relation set of parameters for the fractal mode.
    57   TYPE(aprm), PUBLIC, SAVE :: mmp_afp
    58 
    59   !> Size-distribution law parameters of the spherical mode.
    60   TYPE(nprm), PUBLIC, SAVE :: mmp_pns
    61   !> Size-distribution law parameters of the fractal mode.
    62   TYPE(nprm), PUBLIC, SAVE :: mmp_pnf
    63 
    64   !> Data set for @f$<Q>_{SF}^{M0}@f$.
    65   TYPE(dset2d), PUBLIC, SAVE, TARGET             :: mmp_qbsf0
    66   !> Extended values of [[mmp_gcm(module):mmp_qbsf0(variable)]] dataset.
    67   REAL(kind=mm_wp), PUBLIC, SAVE, DIMENSION(2,2) :: mmp_qbsf0_e
    68   !> Data set for @f$<Q>_{SF}^{M3}@f$.
    69   TYPE(dset2d), PUBLIC, SAVE, TARGET             :: mmp_qbsf3
    70   !> Extended values of [[mmp_gcm(module):mmp_qbsf3(variable)]] dataset.
    71   REAL(kind=mm_wp), PUBLIC, SAVE, DIMENSION(2,2) :: mmp_qbsf3_e
    72   !> Data set for @f$<Q>_{FF}^{M0}@f$.
    73   TYPE(dset2d), PUBLIC, SAVE, TARGET             :: mmp_qbff0
    74   !> Extended values of [[mmp_gcm(module):mmp_qbff0(variable)]] dataset.
    75   REAL(kind=mm_wp), PUBLIC, SAVE, DIMENSION(2,2) :: mmp_qbff0_e
    76  
    77   !> Data set for linear interpolation of transfert probability (M0/CO).
    78   TYPE(dset1d), PUBLIC, SAVE, TARGET :: mmp_pco0p
    79   !> Data set for linear interpolation of transfert probability (M3/CO).
    80   TYPE(dset1d), PUBLIC, SAVE, TARGET :: mmp_pco3p
    81   !> Data set for linear interpolation of transfert probability (M0/FM).
    82   TYPE(dset1d), PUBLIC, SAVE, TARGET :: mmp_pfm0p
    83   !> Data set for linear interpolation of transfert probability (M3/FM).
    84   TYPE(dset1d), PUBLIC, SAVE, TARGET :: mmp_pfm3p
    85 
    86   !> \(b_{0}^{t}\) coefficients for Free-molecular regime kernel approximation.
    87   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/)
    88   !> \(b_{3}^{t}\) coefficients for Free-molecular regime kernel approximation.
    89   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/)
    90 
    91   !> Spherical probability transfert control flag.
    92   LOGICAL, SAVE :: mmp_w_ps2s = .true.
    93   !> Aerosol electric charge correction control flag.
    94   LOGICAL, SAVE :: mmp_w_qe   = .true.
    95 
    96 
    9746  CONTAINS
    9847   
    99   SUBROUTINE abort_program(err)
    100     !! Dump error message and abort the program.
    101     TYPE(error), INTENT(in) :: err !! Error object.
    102     WRITE(stderr,'(a)') "ERROR: "//TRIM(err%msg)
    103     CALL EXIT(err%id)
    104   END SUBROUTINE abort_program
    105 
    106 
    107   SUBROUTINE mmp_initialize(dt,df,rm,rho_aer,p_prod,tx_prod,rc_prod,rplanet,g0, air_rad,air_mmol,clouds,cfgpath)
     48  SUBROUTINE mmp_initialize(dt,p_prod,tx_prod,rc_prod,rplanet,g0, air_rad,air_mmol,clouds,cfgpath)
    10849    !! Initialize global parameters of the model.
    10950    !!
    … …  
    11253    !! default values are suitable for production runs. 
    11354    !! @note
    114     !! If the method fails to initialize parameters (i.e. returned error is not 0). Then the model
    115     !! should probably be aborted as the global variables of the model will not be correctly setup.
     55    !! If the subroutine fails to initialize parameters, the run is aborted.
    11656    !!
    11757    !! @warning
    … …  
    11959    !! initializes global variable that are not thread private.
    12060    !!
    121     !! '''
     61    !! ```
    12262    !! !$OMP SINGLE
    12363    !! call mmp_initialize(...)
    12464    !! !$OMP END SINGLE
     65    !! ```
    12566    !!
    12667    REAL(kind=mm_wp), INTENT(in)           :: dt
    12768      !! Microphysics timestep in seconds.
    128     REAL(kind=mm_wp), INTENT(in)           :: df
    129       !! Fractal dimension of fractal aerosol.
    130     REAL(kind=mm_wp), INTENT(in)           :: rm
    131       !! Monomer radius in meter.
    132     REAL(kind=mm_wp), INTENT(in)           :: rho_aer
    133       !! Aerosol density in \(kg.m^{-3}\).
    13469    REAL(kind=mm_wp), INTENT(in)           :: p_prod
    13570      !!  Aerosol production pressure level in Pa.
    … …  
    15186      !! Internal microphysic configuration file.
    15287
    153     INTEGER          :: coag_choice
    154     REAL(kind=mm_wp) :: fiad_max, fiad_min
    155     LOGICAL          :: w_h_prod, w_h_sed, w_h_coag, w_c_sed, w_c_nucond, &
    156                         no_fiadero, fwsed_m0, fwsed_m3
    157     TYPE(error)      :: err
     88    INTEGER                                           :: coag_choice
     89    REAL(kind=mm_wp)                                  :: fiad_max, fiad_min,df,rm,rho_aer
     90    LOGICAL                                           :: w_h_prod, w_h_sed, w_h_coag, w_c_sed, w_c_nucond, &
     91                                                         no_fiadero, fwsed_m0, fwsed_m3
     92    TYPE(error)                                       :: err
    15893    INTEGER                                           :: i
    15994    TYPE(cfgparser)                                   :: cparser
    … …  
    186121   
    187122    ! YAMMS internal parameters:
     123    err = mm_check_opt(cfg_get_value(cparser,"rm",rm),rm,50e-9_mm_wp,mm_log)
     124    err = mm_check_opt(cfg_get_value(cparser,"df",df),df,2._mm_wp,mm_log)
     125    err = mm_check_opt(cfg_get_value(cparser,"rho_aer",rho_aer),rho_aer,1000._mm_wp,mm_log)
    188126    ! the following parameters are primarily used to test and debug YAMMS.
    189127    ! They are set in an optional configuration file and default to suitable values for production runs.

  • trunk/LMDZ.TITAN/libf/phytitan/callcorrk.F90

    r1822 r1897  
    4545      INTEGER,INTENT(IN) :: ngrid                  ! Number of atmospheric columns.
    4646      INTEGER,INTENT(IN) :: nlayer                 ! Number of atmospheric layers.
    47       REAL,INTENT(IN) :: pq(ngrid,nlayer,nq)       ! Tracers (kg/kg_of_air).
     47      REAL,INTENT(IN) :: pq(ngrid,nlayer,nq)       ! Tracers (X/m2).
    4848      INTEGER,INTENT(IN) :: nq                     ! Number of tracers.
    4949      REAL,INTENT(IN) :: qsurf(ngrid,nq)           ! Tracers on surface (kg.m-2).
    … …  
    298298            endif
    299299           
    300             call optcv(pq,plevrad,tmid,pmid,                       &
     300            call optcv(pq(ig,:,1:nmicro),nlayer,plevrad,tmid,pmid,        &
    301301                 dtauv,tauv,taucumv,wbarv,cosbv,tauray,taugsurf)
    302302
    … …  
    340340!-----------------------------------------------------------------------
    341341
    342          call optci(pq,plevrad,tlevrad,tmid,pmid,                   &
     342         call optci(pq(ig,:,1:nmicro),nlayer,plevrad,tlevrad,tmid,pmid,    &
    343343              dtaui,taucumi,cosbi,wbari,taugsurfi)
    344344

  • trunk/LMDZ.TITAN/libf/phytitan/callkeys_mod.F90

    r1822 r1897  
    1212      logical,save :: callgasvis,continuum,graybody
    1313!$OMP THREADPRIVATE(callgasvis,continuum,graybody)
    14       logical,save :: strictboundcorrk                                     
     14      logical,save :: strictboundcorrk
    1515!$OMP THREADPRIVATE(strictboundcorrk)
     16      logical,save :: uncoupl_optic_haze
     17!$OMP THREADPRIVATE(uncoupl_optic_haze)
     18
    1619      logical,save :: callchim, callmufi, callclouds
    1720!$OMP THREADPRIVATE(callchim,callmufi,callclouds)
    … …  
    4548!$OMP THREADPRIVATE(iddist,iradia,startype)
    4649     
    47       real,save :: df_mufi, rm_mufi, rho_aer_mufi
    4850      real,save :: p_prod, tx_prod, rc_prod
    4951      real,save :: air_rad
    50 !$OMP THREADPRIVATE(df_mufi, rm_mufi, rho_aer_mufi,p_prod,tx_prod,rc_prod,air_rad)
    51 
     52!$OMP THREADPRIVATE(p_prod,tx_prod,rc_prod,air_rad)
     53     
    5254      real,save :: szangle
    5355!$OMP THREADPRIVATE(szangle)

  • trunk/LMDZ.TITAN/libf/phytitan/calmufi.F90

    r1819 r1897  
     1
     2
    13SUBROUTINE calmufi(plev, zlev, play, zlay, temp, pq, zdq)
    24  !! Interface subroutine to YAMMS model for Titan LMDZ GCM.
    35  !!
    4   !! The subroutine computes the microphysics processes for a single vertical column.
     6  !! The subroutine computes the microphysics processes for a si:le vertical column.
    57  !!
    68  !! - All input vectors are assumed to be defined from GROUND to TOP of the atmosphere.
    … …  
    5254
    5355  INTEGER :: ilon, i,nices
    54 
    5556  INTEGER :: nlon,nlay
    5657
    … …  
    8990    ! Convert tracers to extensive ( except for gazs where we work with molar mass ratio )
    9091    ! We suppose a given order of tracers !
    91     int2ext(:) = ( plev(ilon,1:nlay) - plev(ilon,2:nlay+1) ) / g
    92 
     92    int2ext(:) = ( plev(ilon,1:nlay)-plev(ilon,2:nlay+1) ) / g
    9393    m0as(:) = pq(ilon,:,1) * int2ext(:)
    9494    m3as(:) = pq(ilon,:,2) * int2ext(:)
    … …  
    9797   
    9898    if (callclouds) then ! if call clouds
    99       dm0n(:) = pq(ilon,:,5) * int2ext(:)
    100       dm3n(:) = pq(ilon,:,6) * int2ext(:)
     99      m0n(:) = pq(ilon,:,5) * int2ext(:)
     100      m3n(:) = pq(ilon,:,6) * int2ext(:)
    101101      do i=1,nices
    102         dm3i(:,nices) = pq(ilon,:,6+i) * int2ext(:)
    103         dgazs(:,i)    = pq(ilon,:,ices_indx(i)) * rat_mmol(ices_indx(i)) ! For gazs we work on the full tracer array !!
     102        m3i(:,nices) = pq(ilon,:,6+i) * int2ext(:)
     103        gazs(:,i)    = pq(ilon,:,ices_indx(i)) * rat_mmol(ices_indx(i)) ! For gazs we work on the full tracer array !!
    104104        ! We use the molar mass ratio from GCM in case there is discrepancy with the mm one
    105105      enddo
    106106    endif
    107 
    108107
    109108    ! Initialize YAMMS atmospheric column
    … …  
    135134    ! Convert tracers back to intensives ( except for gazs where we work with molar mass ratio )
    136135    ! We suppose a given order of tracers !
    137 
     136 
    138137    zdq(ilon,:,1) = dm0as(:) / int2ext(:)
    139138    zdq(ilon,:,2) = dm3as(:) / int2ext(:)
    … …  
    150149      enddo
    151150    endif
    152 
    153151  END DO ! loop on ilon
    154152

  • trunk/LMDZ.TITAN/libf/phytitan/inifis_mod.F90

    r1896 r1897  
    377377     endif
    378378
    379      write(*,*) "Fractal dimension ?"
    380      df_mufi=2.0 ! default value
    381      call getin_p("df_mufi",df_mufi)
    382      write(*,*)" df_mufi = ",df_mufi
    383 
    384      write(*,*) "Monomer radius (m) ?"
    385      rm_mufi=6.66e-08 ! default value
    386      call getin_p("rm_mufi",rm_mufi)
    387      write(*,*)" rm_mufi = ",rm_mufi
    388 
    389      write(*,*) "Aerosol density (kg.m-3)?"
    390      rho_aer_mufi=1.e3 ! default value
    391      call getin_p("rho_aer_mufi",rho_aer_mufi)
    392      write(*,*)" rho_aer_mufi = ",rho_aer_mufi
     379     write(*,*) "Disable the coupling of microphysics within rad. transf. ?"
     380     write(*,*) "If disabled we will assume a planetwide vert. profile of extinction ..."
     381     uncoupl_optic_haze=.true. ! default value - true as long as the microphysics is bugged
     382     call getin_p("uncoupl_optic_haze",uncoupl_optic_haze)
     383     write(*,*)" uncoupl_optic_haze = ",uncoupl_optic_haze
    393384
    394385     write(*,*) "Pressure level of aer. production (Pa) ?"

  • trunk/LMDZ.TITAN/libf/phytitan/inimufi.F90

    r1795 r1897  
    22
    33  use mmp_gcm
    4   use callkeys_mod, only : callclouds, df_mufi, &
    5         rm_mufi, rho_aer_mufi, p_prod, tx_prod, rc_prod, air_rad
     4  use callkeys_mod, only : callclouds, p_prod, tx_prod, rc_prod, air_rad
    65  use tracer_h
    76  use comcstfi_mod, only : g, rad, mugaz
    … …  
    4241  logical :: err
    4342
     43  ! PATCH : YAMMS now allows to enable/disable effective g computations:
     44  !  In the library it defaults to .true., in the GCM we do not want it !
     45  mm_use_effg = .false.
    4446
    4547  !----------------------------------------------------
    … …  
    4749  ! ---------------------------------------------------
    4850
    49    call mmp_initialize(ptimestep,df_mufi,rm_mufi,rho_aer_mufi,p_prod,tx_prod,rc_prod, &
     51   call mmp_initialize(ptimestep,p_prod,tx_prod,rc_prod, &
    5052        rad,g,air_rad,mugaz,callclouds,config_mufi)
    5153

  • trunk/LMDZ.TITAN/libf/phytitan/optci.F90

    r1822 r1897  
    1 subroutine optci(PQ,PLEV,TLEV,TMID,PMID,      &
     1subroutine optci(PQO,NLAY,PLEV,TLEV,TMID,PMID,      &
    22     DTAUI,TAUCUMI,COSBI,WBARI,TAUGSURF)
    33
    … …  
    66  use gases_h
    77  use comcstfi_mod, only: g, r
    8   use callkeys_mod, only: continuum,graybody
     8  use callkeys_mod, only: continuum,graybody,callclouds,callmufi, uncoupl_optic_haze
     9  use tracer_h, only : nmicro,nice
     10  use MMP_OPTICS
     11
    912  implicit none
    1013
    … …  
    3437  ! Input/Output
    3538  !==========================================================
    36   REAL*8, INTENT(IN)  :: PQ ! Tracers (kg/kg_of_air).
     39  REAL*8, INTENT(IN)  :: PQO(nlay,nmicro) ! Tracers (X/m2).
     40  INTEGER, INTENT(IN) :: NLAY             ! Number of pressure layers (for pqo)
    3741  REAL*8, INTENT(IN)  :: PLEV(L_LEVELS), TLEV(L_LEVELS)
    3842  REAL*8, INTENT(IN)  :: TMID(L_LEVELS), PMID(L_LEVELS)
    … …  
    8690  integer interm
    8791
     92  real*8 m0as,m3as,m0af,m3af
     93  real*8 ext_s,sca_s,ssa_s,asf_s
     94  real*8 ext_f,sca_f,ssa_f,asf_f
     95  logical,save :: firstcall=.true.
     96  !$OMP THREADPRIVATE(firstcall)
     97
    8898  !! AS: to save time in computing continuum (see bilinearbig)
    8999  IF (.not.ALLOCATED(indi)) THEN
    … …  
    127137        ilay = k / 2 ! int. arithmetic => gives the gcm layer index
    128138       
    129         !================= Titan customisation ========================================
    130         call disr_haze(dz(k),plev(k),wnoi(nw),dhaze_T(k,nw),SSA_T(k,nw),ASF_T(k,nw))
    131         ! =============================================================================
     139        ! Optical coupling of YAMMS is plugged but inactivated for now
     140        ! as long as the microphysics only isn't fully debugged -- JVO 01/18
     141        IF (callmufi .AND. (.NOT. uncoupl_optic_haze)) THEN
     142          m0as = pqo(ilay,1)
     143          m3as = pqo(ilay,2)
     144          m0af = pqo(ilay,3)
     145          m3af = pqo(ilay,4)
     146
     147          IF (.NOT.mmp_sph_optics_ir(m0as,m3as,nw,ext_s,sca_s,ssa_s,asf_s)) &
     148          CALL abort_gcm("optcv", "Fatal error in mmp_sph_optics_ir", 12)
     149          IF (.NOT.mmp_fra_optics_ir(m0af,m3af,nw,ext_f,sca_f,ssa_f,asf_f)) &
     150          CALL abort_gcm("optcv", "Fatal error in mmp_fra_optics_ir", 12)
     151          dhaze_T(k,nw) = ext_s+ext_f
     152          SSA_T(k,nw)   = (sca_s+sca_f)/dhaze_T(k,nw)
     153          ASF_T(k,nw)   = (asf_s*sca_s + asf_f*sca_f) /(sca_s+sca_f)
     154          IF (callclouds.and.firstcall) &
     155            WRITE(*,*) 'WARNING: In optci, optical properties &
     156                       &calculations are not implemented yet'
     157        ELSE
     158          ! Call fixed vertical haze profile of extinction - same for all columns
     159          call disr_haze(dz(k),plev(k),wnoi(nw),dhaze_T(k,nw),SSA_T(k,nw),ASF_T(k,nw))
     160        ENDIF
    132161
    133162        DCONT = 0.0d0 ! continuum absorption
    … …  
    401430! ============================================================================== 
    402431
     432  if(firstcall) firstcall = .false.
     433
    403434  return
    404435

  • trunk/LMDZ.TITAN/libf/phytitan/optcv.F90

    r1826 r1897  
    1 SUBROUTINE OPTCV(PQ,PLEV,TMID,PMID,  &
     1SUBROUTINE OPTCV(PQO,NLAY,PLEV,TMID,PMID,  &
    22     DTAUV,TAUV,TAUCUMV,WBARV,COSBV,TAURAY,TAUGSURF)
    33
    … …  
    66  use gases_h
    77  use comcstfi_mod, only: g, r
    8   use callkeys_mod, only: continuum,graybody,callgasvis
     8  use callkeys_mod, only: continuum,graybody,callgasvis,callclouds,callmufi,uncoupl_optic_haze
     9  use tracer_h, only: nmicro,nice
     10  use MMP_OPTICS
    911
    1012  implicit none
    … …  
    4143  ! Input/Output
    4244  !==========================================================
    43   REAL*8, INTENT(IN)  :: PQ ! Tracers (kg/kg_of_air).
     45  REAL*8, INTENT(IN)  :: PQO(nlay,nmicro) ! Tracers (X/m2).
     46  INTEGER, INTENT(IN) :: NLAY             ! Number of pressure layers (for pqo)
    4447  REAL*8, INTENT(IN)  :: PLEV(L_LEVELS)
    4548  REAL*8, INTENT(IN)  :: TMID(L_LEVELS), PMID(L_LEVELS)
    … …  
    97100  integer interm
    98101
     102  real*8 m0as,m3as,m0af,m3af
     103  real*8 ext_s,sca_s,ssa_s,asf_s
     104  real*8 ext_f,sca_f,ssa_f,asf_f
     105  logical,save :: firstcall=.true.
     106  !$OMP THREADPRIVATE(firstcall)
     107
     108
    99109  !! AS: to save time in computing continuum (see bilinearbig)
    100110  IF (.not.ALLOCATED(indv)) THEN
    … …  
    149159
    150160     do NW=1,L_NSPECTV
    151 
    152         !================= Titan customisation ========================================
    153         call disr_haze(dz(k),plev(k),wnov(nw),dhaze_T(k,nw),SSA_T(k,nw),ASF_T(k,nw))
    154         ! =============================================================================
     161     
     162        ! Optical coupling of YAMMS is plugged but inactivated (if false) for now
     163        ! as long as the microphysics only isn't fully debugged -- JVO 01/18
     164        IF (callmufi .AND. (.NOT. uncoupl_optic_haze)) THEN
     165          m0as = pqo(ilay,1)
     166          m3as = pqo(ilay,2)
     167          m0af = pqo(ilay,3)
     168          m3af = pqo(ilay,4)
     169
     170          IF (.NOT.mmp_sph_optics_vis(m0as,m3as,nw,ext_s,sca_s,ssa_s,asf_s)) &
     171          CALL abort_gcm("optcv", "Fatal error in mmp_sph_optics_vis", 12)
     172          IF (.NOT.mmp_fra_optics_vis(m0af,m3af,nw,ext_f,sca_f,ssa_f,asf_f)) &
     173          CALL abort_gcm("optcv", "Fatal error in mmp_fra_optics_vis", 12)
     174          dhaze_T(k,nw) = ext_s+ext_f
     175          SSA_T(k,nw)   = (sca_s+sca_f)/dhaze_T(k,nw)
     176          ASF_T(k,nw)   = (asf_s*sca_s + asf_f*sca_f) /(sca_s+sca_f)
     177          IF (callclouds.and.firstcall) &
     178            WRITE(*,*) 'WARNING: In optcv, optical properties &
     179                       &calculations are not implemented yet'
     180        ELSE
     181          ! Call fixed vertical haze profile of extinction - same for all columns
     182          call disr_haze(dz(k),plev(k),wnov(nw),dhaze_T(k,nw),SSA_T(k,nw),ASF_T(k,nw))
     183        ENDIF
    155184         
    156185        DRAYAER = TRAY(K,NW)
    … …  
    355384! ============================================================================== 
    356385
     386  if(firstcall) firstcall = .false.
    357387
    358388  return

  • trunk/LMDZ.TITAN/libf/phytitan/physiq_mod.F90

    r1896 r1897  
     1#define USE_QTEST
     2
    13      module physiq_mod
    24     
    … …  
    4648      use wxios, only: wxios_context_init, xios_context_finalize
    4749#endif
     50      use MMP_OPTICS
    4851      implicit none
    4952
    … …  
    150153!                + clean of all too-generic (ocean, water, co2 ...) routines
    151154!                + Titan's chemistry
     155!           Microphysical moment model - J.Burgalat / J.Vatant d'Ollone (2017-2018)
    152156!============================================================================================
    153157
    … …  
    383387!$OMP THREADPRIVATE(tankCH4)
    384388
     389      ! -----******----- FOR MUPHYS OPTICS -----******-----
     390      integer :: i,j
     391      real :: pqo(ngrid,nlayer,nq)   ! Tracers for the optics (X/m2).
     392      real :: i2e(nlayer)            ! int 2 ext factor
     393      ! -----******----- END FOR MUPHYS OPTICS -----******-----
     394
     395      real,save,dimension(:,:,:), allocatable :: tpq ! Tracers for decoupled microphysical tests ( temporary in 01/18 )
     396!$OMP THREADPRIVATE(tpq)
     397
     398
    385399!-----------------------------------------------------------------------------
    386400    ! Interface to calmufi
    387401    !   --> needed in order to pass assumed-shape arrays. Otherwise we must put calmufi in a module
    388     !       (to have an explicit generated by the compiler).
     402    !       (to have an explicit interface generated by the compiler).
    389403    !   Or one can put calmufi in MMP_GCM module (in muphytitan).
    390404    INTERFACE
    … …  
    410424! --------------------------------
    411425      if (firstcall) then
     426        allocate(tpq(ngrid,nlayer,nq))
     427        tpq(:,:,:) = pq(:,:,:)
    412428
    413429        ! Initialisation of nmicro as well as tracers names, indexes ...
    … …  
    518534
    519535           call inimufi(nq,ptimestep)
     536           
     537           ! Optical coupling of YAMMS is plugged but inactivated for now
     538           ! as long as the microphysics only isn't fully debugged -- JVO 01/18
     539           IF (.NOT.uncoupl_optic_haze) call mmp_initialize_optics("/path/to/mmp_optic_table.nc")
    520540
    521541         ENDIF
    … …  
    820840               call call_profilgases(nlayer)
    821841
     842               ! Convert (microphysical) tracers for optics: X.kg-1 --> X.m-2_
     843               ! NOTE: it should be moved somewhere else: calmufi performs the same kind of
     844               ! computations... waste of time...
     845               DO i = 1, ngrid
     846                 i2e(:) = ( pplev(i,1:nlayer)-pplev(i,2:nlayer+1) ) / g
     847                 pqo(i,:,:) = 0.0
     848                 DO j=1,nmicro-nice
     849                   pqo(i,:,j) = pq(i,:,j)*i2e(:)
     850                 ENDDO
     851               ENDDO
     852
     853
    822854               ! standard callcorrk
    823                call callcorrk(ngrid,nlayer,pq,nq,qsurf,                           &
     855               call callcorrk(ngrid,nlayer,pqo,nq,qsurf,                          &
    824856                              albedo,albedo_equivalent,emis,mu0,pplev,pplay,pt,   &
    825857                              tsurf,fract,dist_star,                              &
    … …  
    11081140 
    11091141         if (callmufi) then
    1110 
     1142#ifdef USE_QTEST
     1143               if (ngrid.eq.1) then ! We obviously don't have access to (and don't need) zonal means in 1D
     1144                  call calmufi(pplev,zzlev,pplay,zzlay,pt,tpq,zdqmufi)
     1145               else
     1146                  call calmufi(zplevbar,zzlevbar,zplaybar,zzlaybar,ztfibar,tpq,zdqmufi)
     1147               endif
     1148               tpq(:,:,:) = tpq(:,:,:) + zdqmufi(1:ngrid,1:nlayer,1:nq)*ptimestep
     1149#else
    11111150            ! Inside this routine we will split 2D->1D, intensive->extensive and separate different types of tracers
    11121151            ! Should be put in phytrac
    … …  
    11191158
    11201159            pdq(1:ngrid,1:nlayer,1:nq) = pdq(1:ngrid,1:nlayer,1:nq) + zdqmufi(1:ngrid,1:nlayer,1:nq)   
    1121 
     1160#endif
    11221161         endif ! end of 'callmufi'
    11231162     
    … …  
    13401379
    13411380
    1342 !-----------------------------------
    1343 !        Saving statistics :
    1344 !-----------------------------------
    1345 
    1346 !    Note :("stats" stores and accumulates 8 key variables in file "stats.nc"
    1347 !           which can later be used to make the statistic files of the run:
    1348 !           "stats")          only possible in 3D runs !!!
    1349 
    1350          
    1351       if (callstats) then
    1352 
    1353          call wstats(ngrid,"ps","Surface pressure","Pa",2,ps)
    1354          call wstats(ngrid,"tsurf","Surface temperature","K",2,tsurf)
    1355          call wstats(ngrid,"fluxsurf_lw",                               &
    1356                      "Thermal IR radiative flux to surface","W.m-2",2,  &
    1357                      fluxsurf_lw)
    1358          call wstats(ngrid,"fluxtop_lw",                                &
    1359                      "Thermal IR radiative flux to space","W.m-2",2,    &
    1360                      fluxtop_lw)
    1361                      
    1362 !            call wstats(ngrid,"fluxsurf_sw",                               &
    1363 !                        "Solar radiative flux to surface","W.m-2",2,       &
    1364 !                         fluxsurf_sw_tot)                     
    1365 !            call wstats(ngrid,"fluxtop_sw",                                &
    1366 !                        "Solar radiative flux to space","W.m-2",2,         &
    1367 !                        fluxtop_sw_tot)
    1368 
    1369 
    1370          call wstats(ngrid,"ISR","incoming stellar rad.","W m-2",2,fluxtop_dn)
    1371          call wstats(ngrid,"ASR","absorbed stellar rad.","W m-2",2,fluxabs_sw)
    1372          call wstats(ngrid,"OLR","outgoing longwave rad.","W m-2",2,fluxtop_lw)
    1373          !call wstats(ngrid,"ALB","Surface albedo"," ",2,albedo_equivalent)
    1374          !call wstats(ngrid,"ALB_1st","First Band Surface albedo"," ",2,albedo(:,1))
    1375          call wstats(ngrid,"p","Pressure","Pa",3,pplay)
    1376          call wstats(ngrid,"temp","Atmospheric temperature","K",3,zt)
    1377          call wstats(ngrid,"u","Zonal (East-West) wind","m.s-1",3,zu)
    1378          call wstats(ngrid,"v","Meridional (North-South) wind","m.s-1",3,zv)
    1379          call wstats(ngrid,"w","Vertical (down-up) wind","m.s-1",3,pw)
    1380          call wstats(ngrid,"q2","Boundary layer eddy kinetic energy","m2.s-2",3,q2)
    1381 
    1382          if (tracer) then
    1383             do iq=1,nq
    1384                call wstats(ngrid,noms(iq),noms(iq),'kg/kg',3,zq(1,1,iq))
    1385                call wstats(ngrid,trim(noms(iq))//'_surf',trim(noms(iq))//'_surf',  &
    1386                            'kg m^-2',2,qsurf(1,iq) )
    1387                          
    1388 !              call wstats(ngrid,trim(noms(iq))//'_reff',                          &
    1389 !                          trim(noms(iq))//'_reff',                                   &
    1390 !                          'm',3,reffrad(1,1,iq))
    1391 
    1392             end do
    1393 
    1394          endif ! end of 'tracer'
    1395 
    1396          if(lastcall) then
    1397             write (*,*) "Writing stats..."
    1398             call mkstats(ierr)
    1399          endif
    1400          
    1401       endif ! end of 'callstats'
    1402 
    1403 
    14041381!-----------------------------------------------------------------------------------------------------
    14051382!           OUTPUT in netcdf file "DIAGFI.NC", containing any variable for diagnostic
    … …  
    14751452        ! Temporary inclusions for winds diagnostics.
    14761453        call writediagfi(ngrid,"zdudif","Turbdiff tend. zon. wind","m s-2",3,zdudif)
    1477         call writediagfi(ngrid,"zdudyn","Dyn. tend. zon. wind","m s-2",3,zdudyn)
     1454        call writediagfi(ngrid,"zdudyn","Dyn. tend. zon. wind","m s-2",3,zdudyn)
    14781455
    14791456        ! Temporary inclusions for heating diagnostics.
    … …  
    14911468
    14921469         if (callmufi) then ! For now we assume an given order for tracers !
     1470#ifdef USE_QTEST
     1471            ! Microphysical tracers passed through dyn+phys(except mufi)
     1472            call writediagfi(ngrid,"mu_m0as_dp","Dynphys only spherical mode 0th order moment",'kg/kg',3,zq(:,:,1))
     1473            call writediagfi(ngrid,"mu_m3as_dp","Dynphys only spherical mode 3rd order moment",'kg/kg',3,zq(:,:,2))
     1474            call writediagfi(ngrid,"mu_m0af_dp","Dynphys only fractal mode 0th order moment",'kg/kg',3,zq(:,:,3))
     1475            call writediagfi(ngrid,"mu_m3af_dp","Dynphys only fractal mode 3rd order moment",'kg/kg',3,zq(:,:,4))
     1476            ! Microphysical tracers passed through mufi only
     1477            call writediagfi(ngrid,"mu_m0as_mo","Mufi only spherical mode 0th order moment",'kg/kg',3,tpq(:,:,1))
     1478            call writediagfi(ngrid,"mu_m3as_mo","Mufi only spherical mode 3rd order moment",'kg/kg',3,tpq(:,:,2))
     1479            call writediagfi(ngrid,"mu_m0af_mo","Mufi only fractal mode 0th order moment",'kg/kg',3,tpq(:,:,3))
     1480            call writediagfi(ngrid,"mu_m3af_mo","Mufi only fractal mode 3rd order moment",'kg/kg',3,tpq(:,:,4))
     1481#else
    14931482            call writediagfi(ngrid,"mu_m0as","Spherical mode 0th order moment",'kg/kg',3,zq(:,:,1))
    14941483            call writediagfi(ngrid,"mu_m3as","Spherical mode 3rd order moment",'kg/kg',3,zq(:,:,2))
    14951484            call writediagfi(ngrid,"mu_m0af","Fractal mode 0th order moment",'kg/kg',3,zq(:,:,3))
    14961485            call writediagfi(ngrid,"mu_m3af","Fractal mode 3rd order moment",'kg/kg',3,zq(:,:,4))
     1486#endif
    14971487         endif ! end of 'callmufi'
    14981488

  • trunk/LMDZ.TITAN/libf/phytitan/setspi.F90

    r1822 r1897  
    138138      end do
    139139!     note M=L_NSPECTI+1 after loop due to Fortran bizarreness
     140!        --> No fortran bizarreness here... incrementation is performed at the end of the loop...
     141!        --> then when M reached L_NSPECTI, we initialiaze the last element of each array and
     142!            ... increment one last time M... tadaaaa, mystery solved !
     143!            The same logic is applied on for loop in C !
    140144
    141145!=======================================================================
Note: See TracChangeset for help on using the changeset viewer.