Changeset 4193 for LMDZ6/trunk/libf/misc


Ignore:
Timestamp:
Jul 4, 2022, 11:45:46 PM (2 years ago)
Author:
dcugnet
Message:
  • Modifications in readSections to allow a continuation line character "\": in both "tracer.def" and "isotopes_params.def", information for a single tracer or isotope can now be stored on several lines.
  • Modifications in "dispTable" and associated routines to allow too wide tables to be displayed as several shorter sub-tables: each sub-table is at most "nMaxCol" characters wide (typically: number of characters displayable in a tandard screen window) and the first "nHead" columns (typically: name, index, etc.) are duplicated in each sub-table. A default value for nMaxCol, called maxTableWidth (currently = 192) is available in readTracFiles_mod.
  • Subroutine "readIsotopesFile" becomes a function with a boolean returned error value "lerr" used to trigger an external aborting function (no STOP).
Location:
LMDZ6/trunk/libf/misc
Files:
2 edited

Legend:

Unmodified
Added
Removed

  • LMDZ6/trunk/libf/misc/readTracFiles_mod.f90

    r4191 r4193  
    2121
    2222  PUBLIC :: tran0, idxAncestor, ancestor                             !--- GENERATION 0 TRACER + TOOLS FOR GENERATIONS
     23  PUBLIC :: maxTableWidth
    2324!------------------------------------------------------------------------------------------------------------------------------
    2425  TYPE :: dataBase_type                                              !=== TYPE FOR TRACERS SECTION
    … …  
    5960  CHARACTER(LEN=maxlen), SAVE :: newH2OIso(5) = ['H2[16]O', 'H[2]HO ', 'H2[18]O', 'H2[17]O', 'H[3]HO ']
    6061
    61 
    6262  !=== LOCAL COPIES OF THE TRACERS AND ISOTOPES DESCRIPTORS, USED BY getKey (INITIALIZED IN getKey_init)
    6363  TYPE(trac_type), ALLOCATABLE, TARGET, SAVE ::  tracers(:)
    6464  TYPE(isot_type), ALLOCATABLE, TARGET, SAVE :: isotopes(:)
    6565
     66  INTEGER,    PARAMETER :: maxTableWidth = 192                       !--- Maximum width of a table displayed with "dispTable"
    6667  CHARACTER(LEN=maxlen) :: modname
    6768
    … …  
    267268  TYPE(trac_type),       ALLOCATABLE :: tt(:)
    268269  TYPE(trac_type)       :: tmp
    269   CHARACTER(LEN=1024)   :: str
     270  CHARACTER(LEN=1024)   :: str, str2
    270271  CHARACTER(LEN=maxlen) :: secn
    271272  INTEGER               :: ierr, n
    … …  
    273274  IF(.NOT.ALLOCATED(dBase)) ALLOCATE(dBase(0))
    274275  OPEN(90, FILE=fnam, FORM='formatted', STATUS='old')
    275   DO; READ(90,'(a)', IOSTAT=ierr)str
     276  DO; str=''
     277    DO
     278      READ(90,'(a)', IOSTAT=ierr)str2                                !--- Read a full line
     279      str=TRIM(str)//' '//TRIM(str2)                                 !--- Append "str" with the current line
     280      n=LEN_TRIM(str); IF(n == 0) EXIT                               !--- Empty line (probably end of file)
     281      IF(IACHAR(str(n:n))  /= 92) EXIT                               !--- No "\" continuing line symbol found => end of line
     282      str = str(1:n-1)                                               !--- Remove the "\" continuing line symbol
     283    END DO
     284    str = ADJUSTL(str)                                               !--- Remove the front space
    276285    IF(ierr    /= 0 ) EXIT                                           !--- Finished: error or end of file
    277286    IF(str(1:1)=='#') CYCLE                                          !--- Skip comments lines
    … …  
    777786  phas =         [(fgetKey(iq, 'phases',tm(:)%keys, 'g' ), iq=1, nq)]
    778787  CALL msg(TRIM(message)//':', modname)
    779   IF(tm(1)%parent == '') THEN
    780     IF(test(dispTable('iiiss',   ['iq    ','hadv  ','vadv  ','name  ','phase '], cat(tm%name, phas), cat([(iq, iq=1, nq)], &
    781                                             hadv,    vadv),                sub=modname), lerr)) RETURN
     788  IF(ALL(tm(:)%parent == '')) THEN
     789    IF(test(dispTable('iiiss',   ['iq    ','hadv  ','vadv  ','name  ','phase '], cat(tm%name, phas), &
     790                 cat([(iq, iq=1, nq)], hadv, vadv),                 nColMax=maxTableWidth, nHead=2, sub=modname), lerr)) RETURN
    782791  ELSE
    783792    IF(test(dispTable('iiissis', ['iq    ','hadv  ','vadv  ','name  ','parent','igen  ','phase '], cat(tm%name, tm%parent, &
    784            tm%phase), cat([(iq, iq=1, nq)], hadv,    vadv, tm%iGeneration), sub=modname), lerr)) RETURN
     793      tm%phase), cat([(iq, iq=1, nq)], hadv, vadv, tm%iGeneration), nColMax=maxTableWidth, nHead=2, sub=modname), lerr)) RETURN
    785794  END IF
    786795END FUNCTION dispTraSection
    … …  
    933942  CALL get_in('ok_iso_verif', isot(strIdx(isot%parent, 'H2O'))%check, .FALSE.)
    934943
    935   lerr = dispIsotopes(isot, 'Isotopes parameters read from file', modname)
     944  lerr = dispIsotopes(isot, 'Isotopes parameters read from file "'//TRIM(fnam)//'"', modname)
    936945
    937946END FUNCTION readIsotopesFile
    … …  
    945954!===      NOTE: THIS IS DONE HERE (IN A ROUTINE CALLED BY THE DYNAMIC), BECAUSE THE DYNAMIC NEEDS FEW PHYSICAL PARAMETERS.  ===
    946955!==============================================================================================================================
    947 SUBROUTINE initIsotopes(trac, isot)
     956LOGICAL FUNCTION initIsotopes(trac, isot) RESULT(lerr)
    948957  TYPE(trac_type), ALLOCATABLE, TARGET, INTENT(INOUT) :: trac(:)
    949958  TYPE(isot_type), ALLOCATABLE, TARGET, INTENT(INOUT) :: isot(:)
    … …  
    955964  TYPE(trac_type), POINTER   ::  t(:), t1
    956965  TYPE(isot_type), POINTER   ::  i
     966  lerr = .FALSE.
    957967
    958968  t => trac
    … …  
    10191029  !=== READ PHYSICAL PARAMETERS FROM "isotopes_params.def" FILE
    10201030  !    DONE HERE, AND NOT ONLY IN "infotrac_phy", BECAUSE SOME PHYSICAL PARAMS ARE NEEDED FOR RESTARTS (tnat AND alpha_ideal)
    1021   IF(readIsotopesFile('isotopes_params.def',isot)) THEN
    1022      STOP 'Problem when reading isotopes parameters in initIsotopes'
    1023   ENDIF
    1024 
    1025 END SUBROUTINE initIsotopes
     1031  lerr = readIsotopesFile('isotopes_params.def',isot)
     1032
     1033END FUNCTION initIsotopes
    10261034!==============================================================================================================================
    10271035
    … …  
    10481056      END DO
    10491057    END DO
    1050     IF(test(fmsg('Problem with the table content', modname, dispTable(prf, ttl, val, cat([(it,it=1,nt)]), rFmt='(EN8.4)',     &
    1051        sub=modname)), lerr)) RETURN
     1058    IF(test(fmsg('Problem with the table content', modname, dispTable(prf, ttl, val, &
     1059            cat([(it,it=1,nt)]), rFmt='(EN8.4)', nColMax=maxTableWidth, nHead=2, sub=modname)), lerr)) RETURN
    10521060    DEALLOCATE(ttl, val)
    10531061  END DO       

  • LMDZ6/trunk/libf/misc/strings_mod.F90

    r4120 r4193  
    853853!--- Display a clean table composed of successive vectors of same length.
    854854!=== The profile "p" describe in which order to pick up the columns from "s", "i" and "r" for display.
    855 !==============================================================================================================================
    856 LOGICAL FUNCTION dispTable(p, titles, s, i, r, rFmt, nmax, unit, sub) RESULT(lerr)
     855!===  * nRowMax lines are displayed (default: all lines)
     856!===  * nColMax characters (default: as long as needed) are displayed at most on a line. If the effective total length is
     857!===    higher, several partial tables are displayed ; the nHead (default: 1) first columns are included in each sub-table.
     858!==============================================================================================================================
     859LOGICAL FUNCTION dispTable(p, titles, s, i, r, rFmt, nRowMax, nColMax, nHead, unit, sub) RESULT(lerr)
    857860  CHARACTER(LEN=*),           INTENT(IN)  :: p             !--- DISPLAY MAP: s/i/r
    858861  CHARACTER(LEN=*),           INTENT(IN)  :: titles(:)     !--- TITLES (ONE EACH COLUMN)
    … …  
    861864  REAL,             OPTIONAL, INTENT(IN)  :: r(:,:)        !--- REALS
    862865  CHARACTER(LEN=*), OPTIONAL, INTENT(IN)  :: rFmt          !--- Format for reals
    863   INTEGER,          OPTIONAL, INTENT(IN)  :: nmax          !--- Display less than "nrow" rows
     866  INTEGER,          OPTIONAL, INTENT(IN)  :: nRowMax       !--- Display at most "nRowMax" rows
     867  INTEGER,          OPTIONAL, INTENT(IN)  :: nColMax       !--- Display at most "nColMax" characters each line
     868  INTEGER,          OPTIONAL, INTENT(IN)  :: nHead         !--- Head columns repeated for multiple tables display
    864869  INTEGER,          OPTIONAL, INTENT(IN)  :: unit          !--- Output unit (default: screen)
    865870  CHARACTER(LEN=*), OPTIONAL, INTENT(IN)  :: sub           !--- Subroutine name
    … …  
    869874  CHARACTER(LEN=maxlen), ALLOCATABLE :: d(:,:)
    870875  CHARACTER(LEN=1) :: s1, sp
    871   INTEGER :: is, ii, ir, np, nrow, unt, ic
    872   INTEGER :: ns, ni, nr, ncol, nmx
    873   INTEGER, ALLOCATABLE :: n(:)
    874   INTEGER, PARAMETER   :: nm=2                             !--- Space between values & columns
     876  INTEGER :: is, ii, ir, it, k, nmx,  unt, ic, np
     877  INTEGER :: ns, ni, nr, nt, l, ncol, nHd, ib, l0
     878  INTEGER, ALLOCATABLE :: n(:), ncmx(:)
     879  INTEGER, PARAMETER   :: nm=1                             !--- Space between values & columns
    875880  LOGICAL :: ls, li, lr
    876881
    … …  
    884889
    885890  !--- CHECK ARGUMENTS COHERENCE
    886   lerr = np /= SIZE(titles); IF(fmsg('string "pattern" length and titles list mismatch', subn, lerr)) RETURN
     891  lerr = np /= SIZE(titles); IF(fmsg('display map "p" length and titles list mismatch', subn, lerr)) RETURN
    887892  IF(ls) THEN
    888893    ns = SIZE(s, 1); ncol = ncol + SIZE(s, 2); lerr = COUNT([(p(ic:ic)=='s', ic=1, np)]) /= SIZE(s, 2)
    … …  
    894899    nr = SIZE(r, 1); ncol = ncol + SIZE(r, 2); lerr = COUNT([(p(ic:ic)=='r', ic=1, np)]) /= SIZE(r, 2)
    895900  END IF
    896   IF(fmsg('string "pattern" length and arguments number mismatch', subn, lerr)) RETURN
     901  IF(fmsg('display map "p" length and arguments number mismatch', subn, lerr)) RETURN
    897902  lerr = ncol /= SIZE(titles); IF(fmsg('"titles" length and arguments number mismatch', subn, lerr)) RETURN
    898903  lerr = ls.AND.li.AND.ns/=ni; IF(fmsg('string and integer arguments lengths mismatch', subn, lerr)) RETURN
    899904  lerr = ls.AND.lr.AND.ns/=nr; IF(fmsg(   'string and real arguments lengths mismatch', subn, lerr)) RETURN
    900905  lerr = li.AND.lr.AND.ni/=nr; IF(fmsg(  'integer and real arguments lengths mismatch', subn, lerr)) RETURN
    901   nrow = MAX(ns,ni,nr)+1
    902   nmx = nrow; IF(PRESENT(nmax)) nmx = MIN(nmx,nmax+1)
     906  nmx = MAX(ns,ni,nr)+1; IF(PRESENT(nRowMax)) nmx = MIN(nmx,nRowMax+1)
    903907
    904908  !--- Allocate the assembled quantities array
    905   ALLOCATE(d(nrow,ncol), n(ncol))
     909  ALLOCATE(d(nmx,ncol), n(ncol))
    906910
    907911  !--- Assemble the vectors into a strings array in the order indicated by "pattern"
    … …  
    914918      CASE('r'); d(2:nmx,ic) = real2str(r(:,ir),rFm); ir = ir + 1
    915919    END SELECT
     920  END DO
     921  CALL cleanZeros(d)
     922  DO ic = 1, ncol
    916923    n(ic)=0; DO ir=1, nmx; n(ic)=MAX(n(ic), LEN_TRIM(d(ir,ic))); END DO
    917924  END DO
    918925  n(:) = n(:) + 2*nm
    919926
     927  !--- Build the vector of max column index in case the rows are too long (table must be displayed in multiple parts)
     928  nHd = 1; IF(PRESENT(nHead)) nHd = nHead
     929  IF(.NOT.PRESENT(nColMax)) THEN
     930    nt = 1; ncmx = [ncol]
     931  ELSE
     932    nt = 1; l0 = SUM(n(1:nHd)+1)+1
     933    IF(PRESENT(sub)) l0=l0+LEN_TRIM(subn)+1
     934    !--- Count the number of table parts
     935    l = l0; DO ic = nHd+1, ncol; l = l+n(ic)+1; IF(l>=nColMax) THEN; nt = nt+1; l = l0+n(ic)+1; END IF; END DO
     936    !--- Get the index of the last column for each table part
     937    ALLOCATE(ncmx(nt)); k = 1
     938    l = l0; DO ic = nHd+1, ncol; l = l+n(ic)+1; IF(l>=nColMax) THEN; ncmx(k) = ic-1; l = l0+n(ic)+1; k = k+1; END IF; END DO
     939    ncmx(nt) = ncol
     940  END IF
     941     
    920942  !--- Display the strings array as a table
    921   DO ir = 1, nmx; row = ''
    922     DO ic = 1, ncol; el = d(ir,ic)
    923       s1 = sp
    924       row = TRIM(row)//REPEAT(' ',nm)//TRIM(el)//REPEAT(' ',n(ic)-LEN_TRIM(el)-nm)//s1
     943  DO it = 1, nt
     944    DO ir = 1, nmx; row = ''
     945      DO ic = 1, nHd; el = d(ir,ic)
     946        s1 = sp
     947        row = TRIM(row)//REPEAT(' ',nm)//TRIM(el)//REPEAT(' ',n(ic)-LEN_TRIM(el)-nm)//s1
     948      END DO
     949      ib = nHd+1; IF(it>1) ib = ncmx(it-1)+1
     950      DO ic = ib, ncmx(it); el = d(ir,ic)
     951        s1 = sp
     952        row = TRIM(row)//REPEAT(' ',nm)//TRIM(el)//REPEAT(' ',n(ic)-LEN_TRIM(el)-nm)//s1
     953      END DO
     954      nr = LEN_TRIM(row)-1                                           !--- Final separator removed
     955      CALL msg(row(1:nr), subn, unit=unt)
     956      IF(ir /= 1) CYCLE                                              !--- Titles are underlined
     957      row=''; DO ic=1,nHd; row=TRIM(row)//REPEAT('-',n(ic))//'+'; END DO
     958      DO ic = ib,ncmx(it); row=TRIM(row)//REPEAT('-',n(ic))//'+'; END DO
     959      CALL msg(row(1:LEN_TRIM(row)-1), subn, unit=unt)
    925960    END DO
    926     nr = LEN_TRIM(row)-1                                             !--- Final separator removed
    927     CALL msg(row(1:nr), subn, unit=unt)
    928     IF(ir /= 1) CYCLE                                                !--- Titles are underlined
    929     row=''; DO ic=1,ncol; row=TRIM(row)//REPEAT('-',n(ic))//'+'; END DO
    930     CALL msg(row(1:LEN_TRIM(row)-1), subn, unit=unt)
     961    CALL msg('', subn, unit=unt)
    931962  END DO
    932963
    … …  
    9701001    lerr = COUNT([(p(ic:ic)=='r', ic=1, np)]) /= SIZE(r, DIM=2)
    9711002  END IF
    972   IF(fmsg('string "pattern" length and arguments number mismatch', ll=lerr)) RETURN
     1003  IF(fmsg('display map "p" length and arguments number mismatch', ll=lerr)) RETURN
    9731004  lerr = ncol /= SIZE(titles); IF(fmsg('"titles" length and arguments number mismatch', ll=lerr)) RETURN
    9741005  lerr = ls.AND.li.AND.ns/=ni; IF(fmsg('string and integer arguments lengths mismatch', ll=lerr)) RETURN
    … …  
    9891020      CASE('r'); d(2:nrow,ic) = real2str(r(:,ir),rFm); ir = ir + 1
    9901021    END SELECT
     1022  END DO
     1023  CALL cleanZeros(d)
     1024  DO ic = 1, ncol
    9911025    n(ic) = 0; DO ir=1, nrow; n(ic)=MAX(n(ic), LEN_TRIM(d(ir,ic))); END DO
    9921026    IF(needQuotes(d(2,ic)) .AND. ic/=1) n(ic) = n(ic) + 2 !--- For quotes, using second line only
    … …  
    10161050
    10171051!==============================================================================================================================
    1018 LOGICAL FUNCTION dispOutliers_1(ll, a, n, err_msg, nam, subn, nmax, unit) RESULT(lerr)
     1052LOGICAL FUNCTION dispOutliers_1(ll, a, n, err_msg, nam, subn, nRowmax, nColMax, nHead, unit) RESULT(lerr)
    10191053! Display outliers list in tables
    10201054! If "nam" is supplied, it means the last index is for tracers => one table each tracer for rank > 2.
    … …  
    10241058
    10251059  CHARACTER(LEN=*), OPTIONAL, INTENT(IN)  :: err_msg, nam(:), subn   !--- Error message, variables and calling subroutine names
    1026   INTEGER,          OPTIONAL, INTENT(IN)  :: nmax, unit              !--- Maximum number of lines to display (default: all)
     1060  INTEGER,          OPTIONAL, INTENT(IN)  :: nRowMax                 !--- Maximum number of lines to display    (default: all)
     1061  INTEGER,          OPTIONAL, INTENT(IN)  :: nColMax                 !--- Maximum number of characters per line (default: 2048)
     1062  INTEGER,          OPTIONAL, INTENT(IN)  :: nHead                   !--- Number of front columns to duplicate  (default: 1)
     1063  INTEGER,          OPTIONAL, INTENT(IN)  :: unit                    !--- Output unit                           (def: lunout)
    10271064  CHARACTER(LEN=maxlen),      ALLOCATABLE :: ttl(:)
    10281065  LOGICAL,                    ALLOCATABLE :: m(:)
    10291066  INTEGER,                    ALLOCATABLE :: ki(:), kj(:)
    1030   INTEGER                                 :: i, j, k, rk, rk1, ib, ie, itr, nm, unt, nmx, nv
     1067  INTEGER                                 :: i, j, k, rk, rk1, ib, ie, itr, nm, unt, nRmx, nCmx, nHd, nv
    10311068  CHARACTER(LEN=maxlen)                   :: mes, sub, fm='(f12.9)', v, s
    10321069  CHARACTER(LEN=maxlen),      ALLOCATABLE :: vnm(:)
    … …  
    10371074  vnm = ['a'];            IF(PRESENT(nam ))    vnm = nam             !--- Variables names
    10381075  sub = 'dispOutliers';   IF(PRESENT(subn))    sub = subn            !--- Calling subroutine name
    1039   nmx = SIZE(a);          IF(PRESENT(nmax))    nmx = MIN(nmx,nmax)   !--- Maximum number of lines to print
     1076  nRmx= SIZE(a);          IF(PRESENT(nRowMax)) nRmx=MIN(nRmx,nRowMax)!-- Maximum number of lines to print
     1077  nCmx= 2048;             IF(PRESENT(nColMax)) nCmx=MIN(nCmx,nColMax)!-- Maximum number of characters each line
     1078  nHd = 1;                IF(PRESENT(nHead))   nHd = nHead           !--- Number of front columns to duplicate
    10401079  unt = lunout;           IF(PRESENT(unit))    unt = unit            !--- Unit to print messages
    10411080
    … …  
    10611100  IF(rk==1) THEN
    10621101    ALLOCATE(ttl(2)); ttl(2) = TRIM(vnm(1))//'(i)'; ttl(1) = 'i'
    1063     IF(nv == 1) lerr = dispTable('sr', ttl,               s=cat(PACK(nam,ll)), r=cat(PACK(a,ll)), rFmt=fm, nmax=nmax)
    1064     IF(nv /= 1) lerr = dispTable('ir', ['name ','value'], i=cat(PACK(ki,m)),   r=cat(PACK(a,ll)), rFmt=fm, nmax=nmax)
     1102    IF(nv == 1) lerr = dispTable('sr', ttl,               s=cat(PACK(nam,ll)), r=cat(PACK(a,ll)), &
     1103                                 rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=nHd, unit=unt, sub=sub)
     1104    IF(nv /= 1) lerr = dispTable('ir', ['name ','value'], i=cat(PACK(ki,m)),   r=cat(PACK(a,ll)), &
     1105                                 rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=nHd, unit=unt, sub=sub)
    10651106    CALL msg("can't display outliers table", sub, lerr, unt)
    10661107    RETURN
    … …  
    10781119    IF(nv == 1) ttl(rk) = TRIM(v)//','//int2str(itr)//')'            !--- "<name>(i,j,itr)" (single name)
    10791120    IF(nv /= 1) ttl(rk) = TRIM(v)//')'                               !--- "<nam(itr)>(i,j)" (one name each table/itr index)
    1080     IF(rk==2) lerr = dispTable('ir',  ttl, i=cat(PACK(ki,m)),            r=cat(PACK(a(ib:ie),m)), rFmt=fm, nmax=nmax)
    1081     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)
     1121    IF(rk==2) lerr = dispTable('ir',  ttl, i=cat(PACK(ki,m)),            r=cat(PACK(a(ib:ie),m)), &
     1122                                 rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=nHd, unit=unt, sub=sub)
     1123    IF(rk==3) lerr = dispTable('iir', ttl, i=cat(PACK(ki,m),PACK(kj,m)), r=cat(PACK(a(ib:ie),m)), &
     1124                                 rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=nHd, unit=unt, sub=sub)
    10821125    CALL msg("can't display outliers table", sub, lerr, unt)
    10831126    IF(lerr) RETURN
    … …  
    10851128END FUNCTION dispOutliers_1
    10861129!==============================================================================================================================
    1087 LOGICAL FUNCTION dispOutliers_2(ll, a, n, err_msg, nam, subn, nmax, unit) RESULT(lerr)
     1130LOGICAL FUNCTION dispOutliers_2(ll, a, n, err_msg, nam, subn, nRowMax, nColMax, nHead, unit) RESULT(lerr)
    10881131! Display outliers list in tables
    10891132! If "nam" is supplied and, it means the last index is for tracers => one table each tracer for rank > 2.
    … …  
    10921135  INTEGER,                    INTENT(IN)  ::  n(:)                   !--- Profile before linearization
    10931136  CHARACTER(LEN=*), OPTIONAL, INTENT(IN)  :: err_msg, nam(:), subn   !--- Error message, variables and calling subroutine names
    1094   INTEGER,          OPTIONAL, INTENT(IN)  :: nmax, unit              !--- Maximum number of lines to display (default: all)
     1137  INTEGER,          OPTIONAL, INTENT(IN)  :: nRowMax                 !--- Maximum number of lines to display    (default: all)
     1138  INTEGER,          OPTIONAL, INTENT(IN)  :: nColMax                 !--- Maximum number of characters per line (default: 2048)
     1139  INTEGER,          OPTIONAL, INTENT(IN)  :: nHead                   !--- Number of front columns to duplicate  (default: 1)
     1140  INTEGER,          OPTIONAL, INTENT(IN)  :: unit                    !--- Output unit                           (def: lunout)
    10951141
    10961142  CHARACTER(LEN=maxlen)                   :: mes, sub, fm='(f12.9)', prf
    … …  
    10981144  LOGICAL,                    ALLOCATABLE :: m(:)
    10991145  INTEGER,                    ALLOCATABLE :: ki(:), kj(:), kl(:)
    1100   INTEGER                                 :: i, j, k, rk, ib, ie, itr, nm, nv, unt, nmx, rk1
     1146  INTEGER                                 :: i, j, k, rk, ib, ie, itr, nm, nv, unt, nRmx, nCmx, nHd, rk1
    11011147  REAL,                       ALLOCATABLE :: val(:,:)
    11021148
    1103   lerr = ANY(ll); IF(.NOT.lerr) RETURN                                    !--- No outliers -> finished
     1149  lerr = ANY(ll); IF(.NOT.lerr) RETURN                               !--- No outliers -> finished
    11041150  rk = SIZE(n); nv = SIZE(a,2)
    1105   mes = 'outliers found';         IF(PRESENT(err_msg)) mes = err_msg      !--- Error message
    1106   vnm = [(ACHAR(k+96),k=1,nv)];   IF(PRESENT(nam ))    vnm = nam          !--- Variables names
    1107   sub = 'dispOutliers';           IF(PRESENT(subn))    sub = subn         !--- Calling subroutine name
    1108   nmx = SIZE(a);                  IF(PRESENT(nmax))    nmx = MIN(nmx,nmax)!--- Maximum number of lines to print
    1109   unt = lunout;                   IF(PRESENT(unit))    unt = unit         !--- Unit to print messages
    1110   lerr = SIZE(vnm) /= nv;         IF(fmsg('SIZE(nam) /= SIZE(a,2)',                  sub, lerr, unt)) RETURN
    1111   lerr = SIZE(a,1) /= SIZE(ll);   IF(fmsg('"ll" and "a" sizes mismatch',             sub, lerr, unt)) RETURN
    1112   lerr = SIZE(a,1) /= PRODUCT(n); IF(fmsg('profile "n" does not match "a" and "ll"', sub, lerr, unt)) RETURN
     1151  mes = 'outliers found';        IF(PRESENT(err_msg)) mes = err_msg  !--- Error message
     1152  vnm = [(ACHAR(k+96),k=1,nv)];  IF(PRESENT(nam ))    vnm = nam      !--- Variables names
     1153  sub = 'dispOutliers';          IF(PRESENT(subn))    sub = subn     !--- Calling subroutine name
     1154  nRmx= SIZE(a);          IF(PRESENT(nRowMax)) nRmx=MIN(nRmx,nRowMax)!-- Maximum number of lines to print
     1155  nCmx= 2048;             IF(PRESENT(nColMax)) nCmx=MIN(nCmx,nColMax)!-- Maximum number of characters each line
     1156  nHd = 1;                IF(PRESENT(nHead))   nHd = nHead           !--- Number of front columns to duplicate
     1157  unt = lunout;                  IF(PRESENT(unit))    unt = unit     !--- Unit to print messages
     1158  lerr= SIZE(vnm) /= nv;         IF(fmsg('SIZE(nam) /= SIZE(a,2)',                  sub, lerr, unt)) RETURN
     1159  lerr= SIZE(a,1) /= SIZE(ll);   IF(fmsg('"ll" and "a" sizes mismatch',             sub, lerr, unt)) RETURN
     1160  lerr= SIZE(a,1) /= PRODUCT(n); IF(fmsg('profile "n" does not match "a" and "ll"', sub, lerr, unt)) RETURN
    11131161
    11141162  SELECT CASE(rk1)                                                   !--- Indices list
    … …  
    11241172  prf = REPEAT('i',rk)//REPEAT('r',nv)                               !--- Profile
    11251173  ALLOCATE(val(COUNT(ll),nv)); DO k=1, nv; val(:,k) = PACK(a(:,k),ll); END DO
    1126   IF(rk == 1) lerr = dispTable(prf, ttl, i = cat(PACK(ki,ll)),             r = val, rFmt=fm, nmax=nmax)
    1127   IF(rk == 2) lerr = dispTable(prf, ttl, i = cat(PACK(ki,ll),PACK(kj,ll)), r = val, rFmt=fm, nmax=nmax)
    1128   IF(rk == 3) lerr = dispTable(prf, ttl, i = cat(PACK(ki,ll),PACK(kj,ll),PACK(kl,ll)), &
    1129                      r = val, rFmt=fm, nmax=nmax)
     1174  IF(rk == 1) lerr = dispTable(prf, ttl, i = cat(PACK(ki,ll)),                         r = val, &
     1175                                 rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=nHd, unit=unt, sub=sub)
     1176  IF(rk == 2) lerr = dispTable(prf, ttl, i = cat(PACK(ki,ll),PACK(kj,ll)),             r = val, &
     1177                                 rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=nHd, unit=unt, sub=sub)
     1178  IF(rk == 3) lerr = dispTable(prf, ttl, i = cat(PACK(ki,ll),PACK(kj,ll),PACK(kl,ll)), r = val, &
     1179                                 rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=nHd, unit=unt, sub=sub)
    11301180  CALL msg("can't display outliers table", sub, lerr, unt)
    11311181END FUNCTION dispOutliers_2
    … …  
    13201370END FUNCTION dble2str
    13211371!==============================================================================================================================
    1322 
     1372ELEMENTAL SUBROUTINE cleanZeros(s)
     1373  CHARACTER(LEN=*), INTENT(INOUT) :: s
     1374  INTEGER :: ls, ix, i
     1375  IF(is_numeric(s)) THEN
     1376    ls = LEN_TRIM(s)
     1377    ix = MAX(INDEX(s,'E'),INDEX(s,'e'),INDEX(s,'D'),INDEX(s,'d'))
     1378    IF(ix == 0) THEN
     1379      DO ix = ls,1,-1; IF(s(ix:ix) /= '0') EXIT; END DO; s=s(1:ix+1)
     1380    ELSE IF(INDEX(s,'.')/=0) THEN
     1381      i = ix-1; DO WHILE(s(i:i) == '0'); i = i-1; END DO; s=s(1:i)//s(ix:ls)
     1382    END IF
     1383  END IF
     1384END SUBROUTINE cleanZeros
     1385!==============================================================================================================================
    13231386
    13241387!==============================================================================================================================
Note: See TracChangeset for help on using the changeset viewer.