Changeset 5753 for LMDZ6/trunk/libf/misc/strings_mod.f90

Timestamp:

Jul 2, 2025, 3:51:41 PM (8 days ago)

Author:

dcugnet

Message:

Much improved outlayers displaying routine: display compact and readable tables of outlayers.
This version is intended to be used by the isotopes checking routines.

File:

• LMDZ6/trunk/libf/misc/strings_mod.f90 (modified) (1 diff)

LMDZ6/trunk/libf/misc/strings_mod.f90

@@ -1598 +1598 @@
 
 !==============================================================================================================================
+!=== DISPLAY OUTLIERS IN TABLES ===============================================================================================
+!==============================================================================================================================
+!=== lerr = dispOutliers_1(ll(:), a(:[:]), n(:), err_msg, nam(:), sub, nRowmax, nColMax, unit)
+!===  * ll    linearized mask of outliers
+!===  * a     linearized fields:
+!===    a(:)  all the fields are linearized (all contane
+!=== Behaviour depends on ll(:), n(:) and nam(:). We note hereafter nv = SIZE(nam).
+!===
+!=== 1) if SIZE(ll) == PRODUCT(n) and nv==1 or "nam" is unspecified:           outliers of a single variable are displayed
+!===     i[,j[,k]] |       nam       |
+!===     ----------+-----------------+
+!===     *[,*[,*]] | val(i[,j[,k]])  |
+!===        ...    |      ...        |
+!===
+!===
+!=== 2) if SIZE(ll) == PRODUCT(n) and nv>1:                "nv" tables of outliers are displayed, each having its own mask
+!===     i[,j] |    var(1)
+!===     ------+--------------
+!===     *[,*] | val(i[,j],1)
+!===      ...  |     ...
+!===
+!===          ...
+!===
+!===     i[,j] |    var(nv)
+!===     ------+---------------
+!===     *[,*] | val(i[,j],nv)
+!===      ...  |     ...
+!===
+!===
+!=== 3) if SIZE(ll) = PRODUCT(n(1:SIZE(n)-1):              outliers of "nv" variables are displayed, all with mask "ll(:)"
+!===     i[,j] |    var(1)    |    var(2)     |   ...   |    var(nv)       
+!===     ------+--------------+---------------+-- ... --+---------------
+!===     *[,*] | val(i[,j],1) | val(i[,j],2)  |   ...   | val(i[,j],nv)
+!===      ...  |     ...      |     ...       |   ...   |     ...
+!===
+!===  NOTES:
+!===  * in cases 2 and 3, SIZE(nam) MUST be equal to n(SIZE(n)).
+!===  * for the sake of readability, narrow tables (compared to the max. width "nColMax") are horizontally stacked.
+!===  Here is the result in the case 1:
+!===    i[,j[,k]] |       nam       | i[,j[,k]] |       nam       |   ...   | i[,j[,k]] |       nam       
+!===    ----------+-----------------+-----------+-----------------+-- ... --+-----------+-----------------
+!===    *[,*[,*]] | val(i[,j[,k]])  | *[,*[,*]] | val(i[,j[,k]])  |   ...   | *[,*[,*]] | val(i[,j[,k]])
+!===       ...    |      ...        |    ...    |      ...        |   ...   |    ...    |      ...
+!===  * conversly, in case 3, too wide tables are displayed as several sub-tables.
+!===  * too long tables are truncated to nRowMax lines (excluding titles lines).
+!==============================================================================================================================
+LOGICAL FUNCTION dispOutliers_1(ll, a, n, err_msg, nam, sub, nRowmax, nColMax, unit) RESULT(lerr)
+  IMPLICIT NONE
+! Display outliers list in tables
+! If "nam" is supplied, it means the last index is for tracers => one table each tracer for rank > 2.
+  LOGICAL,                    INTENT(IN)  :: ll(:)                   !--- Linearized mask of outliers
+  REAL,                       INTENT(IN)  ::  a(:)                   !--- Linearized array of values
+  INTEGER,                    INTENT(IN)  ::  n(:)                   !--- Profile before linearization
+  CHARACTER(LEN=*), OPTIONAL, INTENT(IN)  :: err_msg, nam(:), sub    !--- Error message, variables and calling subroutine names
+  INTEGER,          OPTIONAL, INTENT(IN)  :: nRowMax                 !--- Maximum number of lines to display    (default: all)
+  INTEGER,          OPTIONAL, INTENT(IN)  :: nColMax                 !--- Maximum number of characters per line (default: 2048)
+  INTEGER,          OPTIONAL, INTENT(IN)  :: unit                    !--- Output unit                           (def: lunout)
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen),      ALLOCATABLE :: t(:), vnm(:), c(:,:)
+  LOGICAL,                    ALLOCATABLE :: m(:), ld(:)
+  INTEGER,                    ALLOCATABLE :: ki(:), kj(:)
+  INTEGER                                 :: rk, ib, ie, itr, nm, unt, nRmx, nCmx, iv, nv, np
+  CHARACTER(LEN=maxlen)                   :: mes, subn, fm='(f12.9)', p
+  lerr = .FALSE.
+
+  IF(.NOT.ANY(ll)) RETURN                                            !--- No outliers -> finished
+
+  mes = 'outliers found'; IF(PRESENT(err_msg)) mes = err_msg         !--- Error message
+  vnm = ['a'];            IF(PRESENT(nam))     vnm = nam             !--- Variables names
+  subn= 'dispOutliers';   IF(PRESENT(sub))     subn= sub             !--- Calling subroutine name
+  nRmx= SIZE(a);          IF(PRESENT(nRowMax)) nRmx=MIN(nRmx,nRowMax)!--- Maximum number of lines to print
+  nCmx= 2048;             IF(PRESENT(nColMax)) nCmx=MIN(nCmx,nColMax)!--- Maximum number of characters each line
+  unt = lunout;           IF(PRESENT(unit))    unt = unit            !--- Unit to print messages
+
+  rk = SIZE(n)                                                       !--- Rank of "a" before linearization
+  nv = SIZE(vnm)                                                     !--- Number of variables
+  np = PRODUCT(n(1:rk-1))                                            !--- Number of points per var (in the multiple vars case)
+  lerr = rk>3;                  CALL msg('can display field with rank <=3 only !', subn, lerr, unt); IF(lerr) RETURN
+  lerr = n(rk) == 1;            CALL msg('degenerated last dim: n(SIZE(n)) = 1 !', subn, lerr, unt); IF(lerr) RETURN
+  lerr = nv/=1 .AND. nv/=n(rk); CALL msg('SIZE(nam) /= 1 and /= last "n" element', subn, lerr, unt); IF(lerr) RETURN
+  lerr = SIZE(a) /= PRODUCT(n); CALL msg('profile "n" does not match "a" and "ll', subn, lerr, unt); IF(lerr) RETURN
+  lerr = ALL([PRODUCT(n),np] /= SIZE(ll))
+  CALL msg('ll" length must be either PROD(n) or PROD(n(1:rk-1))', subn, lerr, unt); IF(lerr) RETURN
+
+  !============================================================================================================================
+  IF(SIZE(ll) == PRODUCT(n)) THEN                                    !=== ll(:) IS A MASK FOR THE WHOLE a(:) VECTOR ===========
+  !============================================================================================================================
+     p = 's'//REPEAT('r',nv)                                         !--- Display map: one string, "nv" reals
+     IF(nv == 1) THEN                                                !=== SINGLE VARIABLE
+        CALL buildTitle(n, vnm, t)                                   !--- Build titles list "t" for a single variable
+        CALL buildCoord(n, ll, c)                                    !--- Masked ("ll") coordinates vector "c"
+        lerr = dispTable(p, t, s=c, r=cat(PACK(a,ll)), rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=1, unit=unt, sub=subn)
+     ELSE                                                            !=== MULTIPLE VARIABLES
+        DO iv = 1, nv
+           CALL buildTitle(n, vnm(iv:iv), t)                         !--- Titles list "t" for the "iv"th variables
+           CALL buildCoord(n(1:rk-1), ll, c)                         !--- Masked ("ll") coordinates vector "c"
+           ib = 1+(iv-1)*np; ie = ib+np
+           lerr = dispTable(p, t, s=c, r=cat(PACK(a(ib:ie),ll(ib:ie))), rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=1, &
+                                                                                                    unit=unt, sub=subn)
+           CALL msg("can't display outliers table", subn, lerr, unt); IF(lerr) RETURN
+        END DO
+     END IF
+  !============================================================================================================================
+  ELSE                                                              !=== ll(:) IS A MASK FOR EACH TRACER STACKED IN a(:) VECTOR
+  !============================================================================================================================
+     CALL buildTitle(n, vnm, t)                                     !--- Build titles list "t" for all the variable
+     CALL duplicate(ll, nv, ld)                                     !--- "ll" concatenated "nv" times
+     CALL buildCoord(n(1:rk-1), ll, c)                              !--- Masked ("ll") coordinates vector "c"
+     lerr = dispTable(p, t, s=c, r=RESHAPE(PACK(a,ld),[np,nv]), rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=1,unit=unt,sub=subn)
+  !============================================================================================================================
+  END IF
+  !============================================================================================================================
+  CALL msg("can't display outliers table", subn, lerr, unt)
+
+CONTAINS
+
+SUBROUTINE buildTitle(n, vname, title)                               !=== BUILD TITLES: [COORD. NAME, THE VARIABLE(S) NAME(S)]
+  INTEGER,                            INTENT(IN)  ::     n(:)
+  CHARACTER(LEN=maxlen),              INTENT(IN)  :: vname(:)
+  CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: title(:)
+  INTEGER :: rk
+  rk = SIZE(n)
+  ALLOCATE(title(1+SIZE(vname)))
+  title(2:SIZE(vname)+1) = vname
+  title(1) = 'i'
+  IF(rk >= 2) title(1) = TRIM(title(1))//', j'
+  IF(rk >= 3) title(1) = TRIM(title(1))//', k'
+END SUBROUTINE buildTitle
+
+SUBROUTINE buildCoord(n, mask, coord)                                !=== BUILD MASKED COORDINATES OK FOR "s" ARG OF dispTable
+  INTEGER,                            INTENT(IN)  ::     n(:)
+  LOGICAL,                            INTENT(IN)  ::  mask(:)
+  CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: coord(:,:)
+  CHARACTER(LEN=maxlen) :: sj, sk
+  INTEGER :: i, j, k, m(3), rk, ic
+  rk = SIZE(n)
+  m(:) = 1;  m(1:rk) = n(:)
+  ALLOCATE(coord(1,COUNT(mask)))
+  ic = 0
+  DO k = 1, m(3); sk = ', '//num2str(k)
+     DO j = 1, m(2); sj = ', '//num2str(j)
+        DO i = 1, m(1)
+           IF(.NOT.mask(i+m(1)*(j+m(2)*k))) CYCLE
+           ic = ic+1
+           coord(ic,1) = num2str(i)
+           IF(rk >= 2) coord(ic,1) = TRIM(coord(ic,1))//TRIM(sj)
+           IF(rk >= 3) coord(ic,1) = TRIM(coord(ic,1))//TRIM(sk)
+        END DO
+     END DO
+  END DO
+END SUBROUTINE buildCoord
+
+END FUNCTION dispOutliers_1
+!==============================================================================================================================
+LOGICAL FUNCTION dispOutliers_2(ll, a, n, err_msg, nam, sub, nRowmax, nColMax, unit) RESULT(lerr)
+  IMPLICIT NONE
+! Display outliers list in tables
+! If "nam" is supplied, it means the last index is for tracers => one table each tracer for rank > 2.
+  LOGICAL,                    INTENT(IN)  :: ll(:)                   !--- Linearized mask of outliers
+  REAL,                       INTENT(IN)  ::  a(:,:)                 !--- Linearized array of values
+  INTEGER,                    INTENT(IN)  ::  n(:)                   !--- Profile before linearization
+  CHARACTER(LEN=*), OPTIONAL, INTENT(IN)  :: err_msg, nam(:), sub    !--- Error message, variables and calling subroutine names
+  INTEGER,          OPTIONAL, INTENT(IN)  :: nRowMax                 !--- Maximum number of lines to display    (default: all)
+  INTEGER,          OPTIONAL, INTENT(IN)  :: nColMax                 !--- Maximum number of characters per line (default: 2048)
+  INTEGER,          OPTIONAL, INTENT(IN)  :: unit                    !--- Output unit                           (def: lunout)
+!------------------------------------------------------------------------------------------------------------------------------
+  lerr = dispOutliers_1(ll, PACK(a, MASK=.TRUE.), n, err_msg, nam, sub, nRowmax, nColMax, unit)
+END FUNCTION dispOutliers_2
+!==============================================================================================================================
+
+
+!==============================================================================================================================
 !=== Reduce an algebrical expression (basic operations and parenthesis) to a single number (string format) ====================
 !==============================================================================================================================