Changeset 2 for strings_mod.F90


Ignore:
Timestamp:
Dec 8, 2021, 9:25:11 PM (3 years ago)
Author:
dcugnet
Message:
  • string_mod.F90:
    • Fix: use ioipsl_getincom (and the non-existing not ioipsl_getin_mod).
    • Nominal strings length is now a parameter (maxlen).
    • No global "modname" used -> modified "msg" routines with corresponding "modname" optional argument.
  • trac_types_mod.F90:
    • Longer and more explicit names for most of the entries.
    • itr component removed, but two new components (isAdvected and isH2Ofamily) help to keep iq=1,nqtot loops only and drop elements to be avoided in most physical routines just by using a conditional CYCLE.
  • readTracFiles_mod.F90:
    • Derived type 'dataBase_type' (formerly "db"), only used in this routine, is moved from "trac_types_mod" to here.
    • String length is now a parameter (maxlen), taken from "strings_mod.F90".
File:
1 edited

Legend:

Unmodified
Added
Removed

  • strings_mod.F90

    r1 r2  
    44
    55  PRIVATE
    6   PUBLIC :: modname, init_printout, msg, fmsg, get_in, lunout, prt_level
     6  PUBLIC :: maxlen, init_printout, msg, fmsg, get_in, lunout, prt_level
    77  PUBLIC :: strLower, strHead, strStack,  strClean,  strIdx,  strCount, strReplace
    88  PUBLIC :: strUpper, strTail, strStackm, strReduce, strFind, strParse, cat, find
    … …  
    1313
    1414  INTERFACE get_in;     MODULE PROCEDURE getin_s,  getin_i,  getin_r,  getin_l;  END INTERFACE get_in
    15   INTERFACE  msg;       MODULE PROCEDURE        msg_1,      msg_l1,       msg_m; END INTERFACE  msg
    16   INTERFACE fmsg;       MODULE PROCEDURE       fmsg_1,     fmsg_l1,      fmsg_m; END INTERFACE fmsg
     15  INTERFACE  msg;       MODULE PROCEDURE        msg_1,                    msg_m; END INTERFACE  msg
     16  INTERFACE fmsg;       MODULE PROCEDURE       fmsg_1,                   fmsg_m; END INTERFACE fmsg
    1717  INTERFACE strHead;    MODULE PROCEDURE    strHead_1,                strHead_m; END INTERFACE strHead
    1818  INTERFACE strTail;    MODULE PROCEDURE    strTail_1,                strTail_m; END INTERFACE strTail
    … …  
    3232  INTERFACE testFile;     MODULE PROCEDURE     testFile_1,     testFile_m; END INTERFACE testFile
    3333
    34   CHARACTER(LEN=256), SAVE :: modname = ''                 !--- Current subroutine name
    35   INTEGER,            SAVE :: lunout  = 6                  !--- Printing unit  (default: 6, ie. on screen)
    36   INTEGER,            SAVE :: prt_level = 1                !--- Printing level (default: 1, ie. print all)
    37 
     34  INTEGER, PARAMETER :: maxlen    = 256                    !--- Standard maximum length for strings
     35  INTEGER,      SAVE :: lunout    = 6                      !--- Printing unit  (default: 6, ie. on screen)
     36  INTEGER,      SAVE :: prt_level = 1                      !--- Printing level (default: 1, ie. print all)
    3837
    3938CONTAINS
    … …  
    5756!==============================================================================================================================
    5857SUBROUTINE getin_s(nam, val, def)
    59 USE ioipsl_getin_mod, ONLY: getin
     58USE ioipsl_getincom, ONLY: getin
    6059  CHARACTER(LEN=*), INTENT(IN)    :: nam
    6160  CHARACTER(LEN=*), INTENT(INOUT) :: val
    … …  
    6665!==============================================================================================================================
    6766SUBROUTINE getin_i(nam, val, def)
    68 USE ioipsl_getin_mod, ONLY: getin
     67USE ioipsl_getincom, ONLY: getin
    6968  CHARACTER(LEN=*), INTENT(IN)    :: nam
    7069  INTEGER,          INTENT(INOUT) :: val
    … …  
    7574!==============================================================================================================================
    7675SUBROUTINE getin_r(nam, val, def)
    77 USE ioipsl_getin_mod, ONLY: getin
     76USE ioipsl_getincom, ONLY: getin
    7877  CHARACTER(LEN=*), INTENT(IN)    :: nam
    7978  REAL,             INTENT(INOUT) :: val
    … …  
    8483!==============================================================================================================================
    8584SUBROUTINE getin_l(nam, val, def)
    86 USE ioipsl_getin_mod, ONLY: getin
     85USE ioipsl_getincom, ONLY: getin
    8786  CHARACTER(LEN=*), INTENT(IN)    :: nam
    8887  LOGICAL,          INTENT(INOUT) :: val
    … …  
    9796!=== Display one or several messages, one each line, starting with the current routine name "modname".
    9897!==============================================================================================================================
    99 SUBROUTINE msg_1(str, unit)
    100   CHARACTER(LEN=*),  INTENT(IN) :: str
    101   INTEGER, OPTIONAL, INTENT(IN) :: unit
     98SUBROUTINE msg_1(str, modname, ll, unit)
     99  !--- Display a simple message "str". Optional parameters:
     100  !    * "modname": module name, displayed in front of the message (with ": " separator) if present.
     101  !    * "ll":      message trigger ; message is displayed only if ll==.TRUE.
     102  !    * "unit":    write unit (by default: "lunout")
     103  CHARACTER(LEN=*),           INTENT(IN) :: str
     104  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: modname
     105  LOGICAL,          OPTIONAL, INTENT(IN) :: ll
     106  INTEGER,          OPTIONAL, INTENT(IN) :: unit
    102107  INTEGER :: unt
     108  IF(PRESENT(ll)) THEN; IF(ll) RETURN; END IF
    103109  unt = lunout; IF(PRESENT(unit)) unt = unit
    104   WRITE(unt,'(a)') TRIM(modname)//': '//str
     110  IF(PRESENT(modname)) THEN
     111    WRITE(unt,'(a)') TRIM(modname)//': '//str              !--- Routine name provided
     112  ELSE
     113    WRITE(unt,'(a)') str                                   !--- Simple message
     114  END IF
    105115END SUBROUTINE msg_1
    106116!==============================================================================================================================
    107 SUBROUTINE msg_l1(ll, str, unit)
    108   LOGICAL,           INTENT(IN) :: ll
    109   CHARACTER(LEN=*),  INTENT(IN) :: str
    110   INTEGER, OPTIONAL, INTENT(IN) :: unit
    111   INTEGER :: unt
    112   IF(.NOT.ll) RETURN
    113   unt = lunout; IF(PRESENT(unit)) unt = unit
    114   WRITE(unt,'(a)') TRIM(modname)//': '//str
    115 END SUBROUTINE msg_l1
    116 !==============================================================================================================================
    117 SUBROUTINE msg_m(str, unit, nmax)
    118   CHARACTER(LEN=*),  INTENT(IN) :: str(:)
    119   INTEGER, OPTIONAL, INTENT(IN) :: unit
    120   INTEGER, OPTIONAL, INTENT(IN) :: nmax
    121   CHARACTER(LEN=256), ALLOCATABLE :: s(:)
     117SUBROUTINE msg_m(str, modname, ll, unit, nmax)
     118  !--- Same as msg_1 with multiple strings that are stacked (separator: coma) on up to "nmax" full lines.
     119  CHARACTER(LEN=*),           INTENT(IN) :: str(:)
     120  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: modname
     121  LOGICAL,          OPTIONAL, INTENT(IN) :: ll
     122  INTEGER,          OPTIONAL, INTENT(IN) :: unit
     123  INTEGER,          OPTIONAL, INTENT(IN) :: nmax
     124  CHARACTER(LEN=maxlen), ALLOCATABLE :: s(:)
    122125  INTEGER :: unt, nmx, k
     126  LOGICAL :: lerr
     127  lerr = .TRUE.; IF(PRESENT(ll))  lerr = ll
    123128  unt = lunout ; IF(PRESENT(unit)) unt = unit
    124129  nmx = 128;     IF(PRESENT(nmax)) nmx = nmax
    125130  s = strStackm(str, ', ', nmx)
    126   DO k=1,SIZE(s); WRITE(unt,'(a)') TRIM(modname)//': '//TRIM(s(k)); END DO
     131  IF(PRESENT(modname)) THEN
     132    DO k=1,SIZE(s); CALL msg_1(s(k), modname, lerr, unt); END DO
     133  ELSE
     134    DO k=1,SIZE(s); CALL msg_1(s(k), ll=lerr, unit=unt);  END DO
     135  END IF
    127136END SUBROUTINE msg_m
    128137!==============================================================================================================================
    129 LOGICAL FUNCTION fmsg_1(str, unit) RESULT(lerr)
    130   CHARACTER(LEN=*),  INTENT(IN)  :: str
    131   INTEGER, OPTIONAL, INTENT(IN)  :: unit
     138LOGICAL FUNCTION fmsg_1(str, modname, ll, unit) RESULT(lerr)
     139  CHARACTER(LEN=*),           INTENT(IN) :: str
     140  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: modname
     141  LOGICAL,          OPTIONAL, INTENT(IN) :: ll
     142  INTEGER,          OPTIONAL, INTENT(IN) :: unit
    132143  INTEGER :: unt
    133   lerr = .TRUE.
     144  lerr = .TRUE.; IF(PRESENT(ll))  lerr = ll
    134145  unt = lunout ; IF(PRESENT(unit)) unt = unit
    135   CALL msg_1(str, unt)
     146  IF(PRESENT(modname)) THEN
     147    CALL msg_1(str, modname, lerr, unt)
     148  ELSE
     149    CALL msg_1(str, ll=lerr, unit=unt)
     150  END IF
    136151END FUNCTION fmsg_1
    137152!==============================================================================================================================
    138 LOGICAL FUNCTION fmsg_l1(li, str, unit) RESULT(lerr)
    139   LOGICAL,           INTENT(IN)  :: li
    140   CHARACTER(LEN=*),  INTENT(IN)  :: str
    141   INTEGER, OPTIONAL, INTENT(IN)  :: unit
    142   INTEGER :: unt
    143   lerr = li;     IF(.NOT.lerr) RETURN
    144   unt = lunout ; IF(PRESENT(unit)) unt = unit
    145   CALL msg_l1(lerr, str, unt)
    146 END FUNCTION fmsg_l1
    147 !==============================================================================================================================
    148 LOGICAL FUNCTION fmsg_m(str, unit, nmax) RESULT(lerr)
    149   CHARACTER(LEN=*),  INTENT(IN)  :: str(:)
    150   INTEGER, OPTIONAL, INTENT(IN)  :: unit
    151   INTEGER, OPTIONAL, INTENT(IN)  :: nmax
     153LOGICAL FUNCTION fmsg_m(str, modname, ll, unit, nmax) RESULT(lerr)
     154  CHARACTER(LEN=*),           INTENT(IN)  :: str(:)
     155  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: modname
     156  LOGICAL,          OPTIONAL, INTENT(IN) :: ll
     157  INTEGER,          OPTIONAL, INTENT(IN) :: unit
     158  INTEGER,          OPTIONAL, INTENT(IN)  :: nmax
    152159  INTEGER :: unt, nmx
    153   lerr = .TRUE.
     160  lerr = .TRUE.; IF(PRESENT(ll))  lerr = ll
    154161  unt = lunout ; IF(PRESENT(unit)) unt = unit
    155162  nmx = 128;     IF(PRESENT(nmax)) nmx = nmax
    156   CALL msg_m(str, unt, nmx)
     163  IF(PRESENT(modname)) THEN
     164    CALL msg_m(str, modname, lerr, unt, nmx)
     165  ELSE
     166    CALL msg_m(str, ll=lerr, unit=unt, nmax=nmx)
     167  END IF
    157168END FUNCTION fmsg_m
    158169!==============================================================================================================================
    … …  
    162173!=== Lower/upper case conversion function. ====================================================================================
    163174!==============================================================================================================================
    164 ELEMENTAL CHARACTER(LEN=256) FUNCTION strLower(str) RESULT(out)
     175ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION strLower(str) RESULT(out)
    165176  CHARACTER(LEN=*), INTENT(IN) :: str
    166177  INTEGER :: k
    … …  
    171182END FUNCTION strLower
    172183!==============================================================================================================================
    173 ELEMENTAL CHARACTER(LEN=256) FUNCTION strUpper(str) RESULT(out)
     184ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION strUpper(str) RESULT(out)
    174185  CHARACTER(LEN=*), INTENT(IN) :: str
    175186  INTEGER :: k
    … …  
    188199!===    * strHead(..,.TRUE.)  = 'a_b'         ${str%$sep*}                                                     ================
    189200!==============================================================================================================================
    190 CHARACTER(LEN=256) FUNCTION strHead_1(str,sep,lFirst) RESULT(out)
     201CHARACTER(LEN=maxlen) FUNCTION strHead_1(str,sep,lFirst) RESULT(out)
    191202  CHARACTER(LEN=*),           INTENT(IN) :: str
    192203  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sep
    … …  
    203214!==============================================================================================================================
    204215FUNCTION strHead_m(str,sep,lFirst) RESULT(out)
    205   CHARACTER(LEN=256),        ALLOCATABLE :: out(:)
     216  CHARACTER(LEN=maxlen),     ALLOCATABLE :: out(:)
    206217  CHARACTER(LEN=*),           INTENT(IN) :: str(:)
    207218  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sep
    … …  
    222233!===    * strHead(..,.TRUE.)  = 'c'           ${str##*$sep}                                                    ================
    223234!==============================================================================================================================
    224 CHARACTER(LEN=256) FUNCTION strTail_1(str,sep,lFirst) RESULT(out)
     235CHARACTER(LEN=maxlen) FUNCTION strTail_1(str,sep,lFirst) RESULT(out)
    225236  CHARACTER(LEN=*),           INTENT(IN) :: str
    226237  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sep
    … …  
    237248!==============================================================================================================================
    238249FUNCTION strTail_m(str,sep,lFirst) RESULT(out)
    239   CHARACTER(LEN=256),        ALLOCATABLE :: out(:)
     250  CHARACTER(LEN=maxlen),     ALLOCATABLE :: out(:)
    240251  CHARACTER(LEN=*),           INTENT(IN) :: str(:)
    241252  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sep
    … …  
    270281!==============================================================================================================================
    271282FUNCTION strStackm(str, sep, nmax) RESULT(out)
    272   CHARACTER(LEN=256),        ALLOCATABLE :: out(:)
     283  CHARACTER(LEN=maxlen),     ALLOCATABLE :: out(:)
    273284  CHARACTER(LEN=*),           INTENT(IN) :: str(:)
    274285  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sep
    275286  INTEGER,          OPTIONAL, INTENT(IN) :: nmax
    276   CHARACTER(LEN=256), ALLOCATABLE :: t(:)
    277   CHARACTER(LEN=256) :: sp
     287  CHARACTER(LEN=maxlen), ALLOCATABLE :: t(:)
     288  CHARACTER(LEN=maxlen) :: sp
    278289  INTEGER :: is, ns, no, mx, n
    279290  IF(SIZE(str) == 0) THEN; out = ['']; RETURN; END IF
    … …  
    328339  CHARACTER(LEN=*), ALLOCATABLE, INTENT(INOUT) :: str1(:)
    329340  INTEGER,          OPTIONAL,    INTENT(OUT)   :: nb
    330   CHARACTER(LEN=256), ALLOCATABLE :: s1(:)
     341  CHARACTER(LEN=maxlen), ALLOCATABLE :: s1(:)
    331342  INTEGER :: k, n, n1
    332343  IF(PRESENT(nb)) nb = 0
    … …  
    342353  CHARACTER(LEN=*),   ALLOCATABLE, INTENT(INOUT) :: str1(:)
    343354  CHARACTER(LEN=*),                INTENT(IN)    :: str2(:)
    344   CHARACTER(LEN=256), ALLOCATABLE :: s1(:), s2(:)
     355  CHARACTER(LEN=maxlen), ALLOCATABLE :: s1(:), s2(:)
    345356  INTEGER :: k
    346357  IF(SIZE(str2)==0) RETURN
    … …  
    432443  LOGICAL, OPTIONAL, INTENT(IN)  :: lSc                              !--- Care about nbs with front sign or in scient. notation
    433444
    434   INTEGER              :: idx0                                       !--- Used to display an identified non-numeric string
    435   INTEGER, ALLOCATABLE :: ii(:)
    436   LOGICAL              :: ll, ls
    437   CHARACTER(LEN=256)  :: d
     445  INTEGER               :: idx0                                      !--- Used to display an identified non-numeric string
     446  INTEGER, ALLOCATABLE  :: ii(:)
     447  LOGICAL               :: ll, ls
     448  CHARACTER(LEN=maxlen) :: d
    438449!  modname = 'strIdx'
    439450  lerr = .FALSE.
    … …  
    545556  DO
    546557    lerr = strIdx_prv(r, delimiter, ib, ie, jd, ll)
    547     IF(fmsg(lerr,'"'//TRIM(r(ib:ie-1))//'" is not numeric')) RETURN
     558    IF(fmsg('"'//TRIM(r(ib:ie-1))//'" is not numeric', ll=lerr)) RETURN
    548559    IF(jd == 0) EXIT
    549560    ib = ie + LEN(delimiter(jd))
    … …  
    560571!==============================================================================================================================
    561572LOGICAL FUNCTION strParse_1(rawList, delimiter, keys, lSc, vals, n) RESULT(lerr)
    562   CHARACTER(LEN=*),                          INTENT(IN)  :: rawList, delimiter
    563   CHARACTER(LEN=256), ALLOCATABLE,           INTENT(OUT) :: keys(:)
    564   LOGICAL,                         OPTIONAL, INTENT(IN)  :: lSc      !--- Take care about numbers in scientific notation
    565   CHARACTER(LEN=256), ALLOCATABLE, OPTIONAL, INTENT(OUT) :: vals(:)
    566   INTEGER,                         OPTIONAL, INTENT(OUT) :: n
     573  CHARACTER(LEN=*),                             INTENT(IN)  :: rawList, delimiter
     574  CHARACTER(LEN=maxlen), ALLOCATABLE,           INTENT(OUT) :: keys(:)
     575  LOGICAL,                            OPTIONAL, INTENT(IN)  :: lSc      !--- Take care about numbers in scientific notation
     576  CHARACTER(LEN=maxlen), ALLOCATABLE, OPTIONAL, INTENT(OUT) :: vals(:)
     577  INTEGER,                            OPTIONAL, INTENT(OUT) :: n
    567578  LOGICAL :: ll
    568579!  modname = 'strParse'
    … …  
    574585!==============================================================================================================================
    575586LOGICAL FUNCTION strParse_m(rawList, delimiter, keys, lSc, vals, n, id) RESULT(lerr)
    576   CHARACTER(LEN=*),                          INTENT(IN)  :: rawList, delimiter(:)
    577   CHARACTER(LEN=256),           ALLOCATABLE, INTENT(OUT) :: keys(:)  !--- Parsed keys vector
    578   LOGICAL,            OPTIONAL,              INTENT(IN)  :: lSc      !--- Take care about numbers in scientific notation
    579   CHARACTER(LEN=256), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: vals(:)  !--- Values for <name>=<value> keys
    580   INTEGER,            OPTIONAL,              INTENT(OUT) :: n        !--- Length of the parsed vector
    581   INTEGER,            OPTIONAL, ALLOCATABLE, INTENT(OUT) :: id(:)    !--- Indexes of the separators in "delimiter(:)" vector
     587  CHARACTER(LEN=*),                             INTENT(IN)  :: rawList, delimiter(:)
     588  CHARACTER(LEN=maxlen),           ALLOCATABLE, INTENT(OUT) :: keys(:)  !--- Parsed keys vector
     589  LOGICAL,               OPTIONAL,              INTENT(IN)  :: lSc      !--- Take care about numbers in scientific notation
     590  CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: vals(:)  !--- Values for <name>=<value> keys
     591  INTEGER,               OPTIONAL,              INTENT(OUT) :: n        !--- Length of the parsed vector
     592  INTEGER,               OPTIONAL, ALLOCATABLE, INTENT(OUT) :: id(:)    !--- Indexes of the separators in "delimiter(:)" vector
    582593
    583594  CHARACTER(LEN=1024) :: r
    … …  
    587598!  modname = 'strParse'
    588599  ll = .FALSE.; IF(PRESENT(lSc)) ll = lSc
    589   IF(test(fmsg(strCount_1m(rawList, delimiter, nk, ll), "Couldn't parse list: non-numerical strings were found"),lerr)) RETURN
     600  IF(test(fmsg("Couldn't parse list: non-numerical strings were found", ll=strCount_1m(rawList, delimiter, nk, ll)),lerr)) RETURN
    590601
    591602  !--- FEW ALLOCATIONS
    … …  
    600611  ib = 1
    601612  DO ik = 1, nk-1
    602     IF(test(fmsg(strIdx_prv(r, delimiter, ib, ie, jd, ll),'Non-numeric values found'),lerr)) RETURN
     613    IF(test(fmsg('Non-numeric values found', ll=strIdx_prv(r, delimiter, ib, ie, jd, ll)),lerr)) RETURN
    603614    keys(ik) = r(ib:ie-1)
    604615    IF(PRESENT(vals)) CALL parseKeys(keys(ik), vals(ik))             !--- Parse a <key>=<val> pair
    … …  
    674685  CHARACTER(LEN=*),           TARGET, INTENT(IN) :: s0
    675686  CHARACTER(LEN=*), OPTIONAL, TARGET, INTENT(IN) :: s1, s2, s3, s4, s5, s6, s7, s8, s9
    676   CHARACTER(LEN=256), ALLOCATABLE :: out(:)
    677   CHARACTER(LEN=256), POINTER     :: s
     687  CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:)
     688  CHARACTER(LEN=maxlen), POINTER     :: s
    678689  LOGICAL :: lv(10)
    679690  INTEGER :: iv
    … …  
    693704  CHARACTER(LEN=*),           TARGET, DIMENSION(:), INTENT(IN) :: s0
    694705  CHARACTER(LEN=*), OPTIONAL, TARGET, DIMENSION(:), INTENT(IN) :: s1, s2, s3, s4, s5, s6, s7, s8, s9
    695   CHARACTER(LEN=256), ALLOCATABLE :: out(:,:)
    696   CHARACTER(LEN=256), POINTER     :: s(:)
     706  CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:,:)
     707  CHARACTER(LEN=maxlen), POINTER     :: s(:)
    697708  LOGICAL :: lv(10)
    698709  INTEGER :: nrow, ncol, iv, n
    … …  
    707718    END SELECT
    708719    n = SIZE(s, DIM=1)
    709     IF(n/=nrow) THEN; CALL msg('Can''t concatenate vectors of differing lengths',1); STOP; END IF
     720    IF(n/=nrow) THEN; CALL msg("Can't concatenate vectors of differing lengths"); STOP; END IF
    710721    out(:,iv) = s(:)
    711722  END DO
    … …  
    748759    END SELECT
    749760    n = SIZE(i, DIM=1)
    750     IF(n/=nrow) THEN; CALL msg('Can''t concatenate vectors of differing lengths',1); STOP; END IF
     761    IF(n/=nrow) THEN; CALL msg("Can't concatenate vectors of differing lengths"); STOP; END IF
    751762    out(:,iv) = i(:)
    752763  END DO
    … …  
    789800    END SELECT
    790801    n = SIZE(r, DIM=1)
    791     IF(n/=nrow) THEN; CALL msg('Can''t concatenate vectors of differing lengths',1); STOP; END IF
     802    IF(n/=nrow) THEN; CALL msg("Can't concatenate vectors of differing lengths"); STOP; END IF
    792803    out(:,iv) = r(:)
    793804  END DO
    … …  
    830841    END SELECT
    831842    n = SIZE(d, DIM=1)
    832     IF(n/=nrow) THEN; CALL msg('Can''t concatenate vectors of differing lengths',1); STOP; END IF
     843    IF(n/=nrow) THEN; CALL msg("Can't concatenate vectors of differing lengths"); STOP; END IF
    833844    out(:,iv) = d(:)
    834845  END DO
    … …  
    852863
    853864  CHARACTER(LEN=2048) :: row
    854   CHARACTER(LEN=256)  :: rFm, el
    855   CHARACTER(LEN=256), ALLOCATABLE :: d(:,:)
     865  CHARACTER(LEN=maxlen)  :: rFm, el
     866  CHARACTER(LEN=maxlen), ALLOCATABLE :: d(:,:)
    856867  CHARACTER(LEN=1) :: s1, sp
    857868  INTEGER :: is, ii, ir, np, nrow, unt, ic
    … …  
    870881
    871882  !--- CHECK ARGUMENTS COHERENCE
    872   lerr = np /= SIZE(titles); IF(fmsg(lerr, 'string "pattern" length and titles list mismatch')) RETURN
     883  lerr = np /= SIZE(titles); IF(fmsg('string "pattern" length and titles list mismatch', ll=lerr)) RETURN
    873884  IF(ls) THEN; ns = SIZE(s, DIM=1); ncol = ncol + SIZE(s, DIM=2)
    874885    lerr = COUNT([(p(ic:ic)=='s', ic=1, np)]) /= SIZE(s, DIM=2)
    … …  
    880891    lerr = COUNT([(p(ic:ic)=='r', ic=1, np)]) /= SIZE(r, DIM=2)
    881892  END IF
    882 
    883   IF(fmsg(lerr, 'string "pattern" length and arguments number mismatch')) RETURN
    884   lerr = ncol /= SIZE(titles); IF(fmsg(lerr, '"titles" length and arguments number mismatch')) RETURN
    885   lerr = ls.AND.li.AND.ns/=ni; IF(fmsg(lerr, 'string and integer arguments lengths mismatch')) RETURN
    886   lerr = ls.AND.lr.AND.ns/=nr; IF(fmsg(lerr,    'string and real arguments lengths mismatch')) RETURN
    887   lerr = li.AND.lr.AND.ni/=nr; IF(fmsg(lerr,   'integer and real arguments lengths mismatch')) RETURN
     893  IF(fmsg('string "pattern" length and arguments number mismatch', ll=lerr)) RETURN
     894  lerr = ncol /= SIZE(titles); IF(fmsg('"titles" length and arguments number mismatch', ll=lerr)) RETURN
     895  lerr = ls.AND.li.AND.ns/=ni; IF(fmsg('string and integer arguments lengths mismatch', ll=lerr)) RETURN
     896  lerr = ls.AND.lr.AND.ns/=nr; IF(fmsg(   'string and real arguments lengths mismatch', ll=lerr)) RETURN
     897  lerr = li.AND.lr.AND.ni/=nr; IF(fmsg(  'integer and real arguments lengths mismatch', ll=lerr)) RETURN
    888898  nrow = MAX(ns,ni,nr)+1
    889899  nmx = nrow; IF(PRESENT(nmax)) nmx = MIN(nmx,nmax+1)
    … …  
    912922    END DO
    913923    nr = LEN_TRIM(row)-1                                             !--- Final separator removed
    914     CALL msg(row(1:nr), unt)
     924    CALL msg(row(1:nr), unit=unt)
    915925    IF(ir /= 1) CYCLE                                                !--- Titles are underlined
    916926    row=''; DO ic=1,ncol; row=TRIM(row)//REPEAT('-',n(ic))//'+'; END DO
    917     CALL msg(row(1:LEN_TRIM(row)-1), unt)
     927    CALL msg(row(1:LEN_TRIM(row)-1), unit=unt)
    918928  END DO
    919929
    … …  
    932942  LOGICAL,          OPTIONAL, INTENT(IN)  :: llast         !--- Last variable: no final ','
    933943
    934   CHARACTER(LEN=256)  :: rFm, el
    935   CHARACTER(LEN=256), ALLOCATABLE :: d(:,:)
    936   CHARACTER(LEN=:),   ALLOCATABLE :: sp, row
     944  CHARACTER(LEN=maxlen)  :: rFm, el
     945  CHARACTER(LEN=maxlen), ALLOCATABLE :: d(:,:)
     946  CHARACTER(LEN=:),      ALLOCATABLE :: sp, row
    937947  INTEGER :: is, ii, ir, nrow, ic
    938948  INTEGER :: ns, ni, nr, ncol, np
    … …  
    957967    lerr = COUNT([(p(ic:ic)=='r', ic=1, np)]) /= SIZE(r, DIM=2)
    958968  END IF
    959   IF(fmsg(lerr, 'string "pattern" length and arguments number mismatch')) RETURN
    960   lerr = ncol /= SIZE(titles); IF(fmsg(lerr, '"titles" length and arguments number mismatch')) RETURN
    961   lerr = ls.AND.li.AND.ns/=ni; IF(fmsg(lerr, 'string and integer arguments lengths mismatch')) RETURN
    962   lerr = ls.AND.lr.AND.ns/=nr; IF(fmsg(lerr,    'string and real arguments lengths mismatch')) RETURN
    963   lerr = li.AND.lr.AND.ni/=nr; IF(fmsg(lerr,   'integer and real arguments lengths mismatch')) RETURN
     969  IF(fmsg('string "pattern" length and arguments number mismatch', ll=lerr)) RETURN
     970  lerr = ncol /= SIZE(titles); IF(fmsg('"titles" length and arguments number mismatch', ll=lerr)) RETURN
     971  lerr = ls.AND.li.AND.ns/=ni; IF(fmsg('string and integer arguments lengths mismatch', ll=lerr)) RETURN
     972  lerr = ls.AND.lr.AND.ns/=nr; IF(fmsg(   'string and real arguments lengths mismatch', ll=lerr)) RETURN
     973  lerr = li.AND.lr.AND.ni/=nr; IF(fmsg(  'integer and real arguments lengths mismatch', ll=lerr)) RETURN
    964974
    965975  !--- Allocate the assembled quantities array
    … …  
    10121022  CHARACTER(LEN=*), OPTIONAL, INTENT(IN)  :: err_msg, nam(:), subn   !--- Error message, variables and calling subroutine names
    10131023  INTEGER,          OPTIONAL, INTENT(IN)  :: nmax, unit              !--- Maximum number of lines to display (default: all)
    1014   CHARACTER(LEN=256),         ALLOCATABLE :: ttl(:)
     1024  CHARACTER(LEN=maxlen),      ALLOCATABLE :: ttl(:)
    10151025  LOGICAL,                    ALLOCATABLE :: m(:)
    10161026  INTEGER,                    ALLOCATABLE :: ki(:), kj(:)
    10171027  INTEGER                                 :: i, j, k, rk, rk1, ib, ie, itr, nm, unt, nmx, nv
    1018   CHARACTER(LEN=256)                      :: mes, sub, fm='(f12.9)', v, s
    1019   CHARACTER(LEN=256),         ALLOCATABLE :: vnm(:)
     1028  CHARACTER(LEN=maxlen)                   :: mes, sub, fm='(f12.9)', v, s
     1029  CHARACTER(LEN=maxlen),      ALLOCATABLE :: vnm(:)
    10201030
    10211031  lerr = ANY(ll); IF(.NOT.lerr) RETURN                               !--- No outliers -> finished
    … …  
    10281038
    10291039  rk = SIZE(n); nv = SIZE(vnm)
    1030   IF(test(fmsg(nv /= 1 .AND. nv /= n(rk), 'In "'//TRIM(sub)//'": SIZE(nam) /= 1 or =last "n" element'    , unt),lerr)) RETURN
    1031   IF(test(fmsg(SIZE(a) /= SIZE(ll),       'In "'//TRIM(sub)//'": "ll" and "a" sizes mismatch'            , unt),lerr)) RETURN
    1032   IF(test(fmsg(SIZE(a) /= PRODUCT(n),     'In "'//TRIM(sub)//'": profile "n" does not match "a" and "ll"', unt),lerr)) RETURN
    1033 
    1034   WRITE(unt,*)'Outliers detected by '//TRIM(sub)//': '//TRIM(mes)
     1040  IF(test(fmsg('SIZE(nam) /= 1 and /= last "n" element', sub, nv /= 1 .AND. nv /= n(rk), unt),lerr)) RETURN
     1041  IF(test(fmsg('ll" and "a" sizes mismatch',             sub, SIZE(a) /= SIZE(ll),       unt),lerr)) RETURN
     1042  IF(test(fmsg('profile "n" does not match "a" and "ll', sub, SIZE(a) /= PRODUCT(n),     unt),lerr)) RETURN
     1043  CALL msg(mes, sub, unit=unt)
    10351044
    10361045  !--- SCALAR CASE: single value to display
    … …  
    10511060    IF(nv == 1) lerr = dispTable('sr', ttl,               s=cat(PACK(nam,ll)), r=cat(PACK(a,ll)), rFmt=fm, nmax=nmax)
    10521061    IF(nv /= 1) lerr = dispTable('ir', ['name ','value'], i=cat(PACK(ki,m)),   r=cat(PACK(a,ll)), rFmt=fm, nmax=nmax)
    1053     CALL msg(lerr,'In '//TRIM(sub)//": can't display outliers table", unt)
     1062    CALL msg("can't display outliers table", sub, lerr, unt)
    10541063    RETURN
    10551064  END IF
    … …  
    10681077    IF(rk==2) lerr = dispTable('ir',  ttl, i=cat(PACK(ki,m)),            r=cat(PACK(a(ib:ie),m)), rFmt=fm, nmax=nmax)
    10691078    IF(rk==3) lerr = dispTable('iir', ttl, i=cat(PACK(ki,m),PACK(kj,m)), r=cat(PACK(a(ib:ie),m)), rFmt=fm, nmax=nmax)
    1070     CALL msg(lerr,'In '//TRIM(sub)//": can't display outliers table", unt)
    1071     IF(lerr) THEN; CALL msg("Can't display outliers table"); RETURN; END IF
     1079    CALL msg("can't display outliers table", sub, lerr, unt)
     1080    IF(lerr) RETURN
    10721081  END DO
    10731082END FUNCTION dispOutliers_1
    … …  
    10821091  INTEGER,          OPTIONAL, INTENT(IN)  :: nmax, unit              !--- Maximum number of lines to display (default: all)
    10831092
    1084   CHARACTER(LEN=256)                      :: mes, sub, fm='(f12.9)', prf
    1085   CHARACTER(LEN=256),         ALLOCATABLE :: ttl(:), vnm(:)
     1093  CHARACTER(LEN=maxlen)                   :: mes, sub, fm='(f12.9)', prf
     1094  CHARACTER(LEN=maxlen),      ALLOCATABLE :: ttl(:), vnm(:)
    10861095  LOGICAL,                    ALLOCATABLE :: m(:)
    10871096  INTEGER,                    ALLOCATABLE :: ki(:), kj(:), kl(:)
    … …  
    10961105  nmx = SIZE(a);                  IF(PRESENT(nmax))    nmx = MIN(nmx,nmax)!--- Maximum number of lines to print
    10971106  unt = lunout;                   IF(PRESENT(unit))    unt = unit         !--- Unit to print messages
    1098   lerr = SIZE(vnm) /= nv;         IF(fmsg(lerr, 'In "dispOutlayers_2": SIZE(nam) /= SIZE(a,2)'  ,unt)) RETURN
    1099   lerr = SIZE(a,1) /= SIZE(ll);   IF(fmsg(lerr,'In '//TRIM(sub)//': "ll" and "a" sizes mismatch',unt)) RETURN
    1100   lerr = SIZE(a,1) /= PRODUCT(n); IF(fmsg(lerr,'In '//TRIM(sub)//': profile "n" does not match "a" and "ll"',unt)) RETURN
     1107  lerr = SIZE(vnm) /= nv;         IF(fmsg('SIZE(nam) /= SIZE(a,2)',                  sub, lerr, unt)) RETURN
     1108  lerr = SIZE(a,1) /= SIZE(ll);   IF(fmsg('"ll" and "a" sizes mismatch',             sub, lerr, unt)) RETURN
     1109  lerr = SIZE(a,1) /= PRODUCT(n); IF(fmsg('profile "n" does not match "a" and "ll"', sub, lerr, unt)) RETURN
    11011110
    11021111  SELECT CASE(rk1)                                                   !--- Indices list
    … …  
    11161125  IF(rk == 3) lerr = dispTable(prf, ttl, i = cat(PACK(ki,ll),PACK(kj,ll),PACK(kl,ll)), &
    11171126                     r = val, rFmt=fm, nmax=nmax)
    1118   CALL msg(lerr,'In '//TRIM(sub)//": can't display outliers table", unt)
     1127  CALL msg("can't display outliers table", sub, lerr, unt)
    11191128END FUNCTION dispOutliers_2
    11201129!==============================================================================================================================
    … …  
    11251134!==============================================================================================================================
    11261135LOGICAL FUNCTION reduceExpr_1(str, val) RESULT(lerr)
    1127   CHARACTER(LEN=*),    INTENT(IN)  :: str
    1128   CHARACTER(LEN=256), INTENT(OUT) :: val
    1129 
    1130   CHARACTER(LEN=256)               :: v
    1131   CHARACTER(LEN=1024)              :: s, vv
     1136  CHARACTER(LEN=*),      INTENT(IN)  :: str
     1137  CHARACTER(LEN=maxlen), INTENT(OUT) :: val
     1138
     1139  CHARACTER(LEN=maxlen)              :: v
     1140  CHARACTER(LEN=1024)                :: s, vv
    11321141  CHARACTER(LEN=1024), ALLOCATABLE :: vl(:)
    11331142  INTEGER,             ALLOCATABLE :: ip(:)
    … …  
    11411150  ll = strCount(s,')',nn)
    11421151  lerr = nl /= nn
    1143   IF(fmsg(lerr, 'Mismatching number of opening and closing parenthesis: '//TRIM(s))) RETURN
     1152  IF(fmsg('Mismatching number of opening and closing parenthesis: '//TRIM(s), ll=lerr)) RETURN
    11441153  nl = 2*nl-1
    11451154
    … …  
    11751184!==============================================================================================================================
    11761185LOGICAL FUNCTION reduceExpr_basic(str, val) RESULT(lerr)
    1177   CHARACTER(LEN=*),   INTENT(IN)  :: str
    1178   CHARACTER(LEN=*),   INTENT(OUT) :: val
    1179   DOUBLE PRECISION,   ALLOCATABLE :: vl(:)
    1180   INTEGER,            ALLOCATABLE :: id(:)
    1181   CHARACTER(LEN=256), ALLOCATABLE :: ky(:)
    1182   CHARACTER(LEN=1),   ALLOCATABLE :: op(:)
     1186  CHARACTER(LEN=*),      INTENT(IN)  :: str
     1187  CHARACTER(LEN=*),      INTENT(OUT) :: val
     1188  DOUBLE PRECISION,      ALLOCATABLE :: vl(:)
     1189  INTEGER,               ALLOCATABLE :: id(:)
     1190  CHARACTER(LEN=maxlen), ALLOCATABLE :: ky(:)
     1191  CHARACTER(LEN=1),      ALLOCATABLE :: op(:)
    11831192
    11841193  CHARACTER(LEN=1024) :: s
    … …  
    11941203  vl = str2dble(ky)                                                            !--- Conversion to doubles
    11951204  lerr = ANY(vl >= HUGE(1.d0))
    1196   IF(fmsg(lerr,'Some values are non-numeric in: '//TRIM(s))) RETURN            !--- Non-numerical values found
     1205  IF(fmsg('Some values are non-numeric in: '//TRIM(s), ll=lerr)) RETURN        !--- Non-numerical values found
    11971206  DO io = 1, SIZE(op)                                                          !--- Loop on known operators (order matters !)
    11981207    DO i = SIZE(id), 1, -1                                                     !--- Loop on found operators
    … …  
    12181227!==============================================================================================================================
    12191228FUNCTION reduceExpr_m(str, val) RESULT(lerr)
    1220   LOGICAL,            ALLOCATABLE              :: lerr(:)
    1221   CHARACTER(LEN=*),                INTENT(IN)  :: str(:)
    1222   CHARACTER(LEN=256), ALLOCATABLE, INTENT(OUT) :: val(:)
     1229  LOGICAL,               ALLOCATABLE              :: lerr(:)
     1230  CHARACTER(LEN=*),                   INTENT(IN)  :: str(:)
     1231  CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: val(:)
    12231232  INTEGER :: i
    12241233  ALLOCATE(lerr(SIZE(str)),val(SIZE(str)))
    … …  
    12771286END FUNCTION str2dble
    12781287!==============================================================================================================================
    1279 ELEMENTAL CHARACTER(LEN=256) FUNCTION bool2str(b) RESULT(out)
     1288ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION bool2str(b) RESULT(out)
    12801289  LOGICAL, INTENT(IN) :: b
    12811290  WRITE(out,*)b
    … …  
    12831292END FUNCTION bool2str
    12841293!==============================================================================================================================
    1285 ELEMENTAL CHARACTER(LEN=256) FUNCTION int2str(i, nDigits) RESULT(out)
     1294ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION int2str(i, nDigits) RESULT(out)
    12861295  INTEGER,           INTENT(IN) :: i
    12871296  INTEGER, OPTIONAL, INTENT(IN) :: nDigits
    … …  
    12921301END FUNCTION int2str
    12931302!==============================================================================================================================
    1294 ELEMENTAL CHARACTER(LEN=256) FUNCTION real2str(r,fmt) RESULT(out)
     1303ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION real2str(r,fmt) RESULT(out)
    12951304  REAL,                       INTENT(IN) :: r
    12961305  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: fmt
    … …  
    13001309END FUNCTION real2str
    13011310!==============================================================================================================================
    1302 ELEMENTAL CHARACTER(LEN=256) FUNCTION dble2str(d,fmt) RESULT(out)
     1311ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION dble2str(d,fmt) RESULT(out)
    13031312  DOUBLE PRECISION,           INTENT(IN) :: d
    13041313  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: fmt
    … …  
    13671376  CHARACTER(LEN=*),   INTENT(IN)  :: message, items, reason
    13681377  INTEGER,  OPTIONAL, INTENT(IN)  :: nmax
    1369   CHARACTER(LEN=256), ALLOCATABLE :: s(:)
     1378  CHARACTER(LEN=maxlen), ALLOCATABLE :: s(:)
    13701379  INTEGER :: i, nmx
    13711380  nmx = 256; IF(PRESENT(nmax)) nmx=nmax
Note: See TracChangeset for help on using the changeset viewer.