Changeset 5751


Ignore:
Timestamp:
Jul 2, 2025, 3:30:23 PM (16 hours ago)
Author:
dcugnet
Message:
  • forgot to include horzcat_l??, horzcat_d21 and horzcat_?22 in the generic "cat" function
  • improve "dispTable", split in several routines (one each main stage), with some new possibilities:
    • conversion into a string array ("convertTable")
    • horizontal stacking of narrow tables ('gatherTable") If the total width is greater than "nColMax", table is split into several sub-tables. Each subtable includes the first "nHead" columns (names, indices...)
    • titles can be displayed on a single line or several lines (depending on the rank of argument "titles": 1 or 2)
File:
1 edited

Legend:

Unmodified
Added
Removed

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

    r5750 r5751  
    66
    77  PRIVATE
    8   PUBLIC :: maxlen, init_printout, msg, get_in, lunout, prt_level
     8  PUBLIC :: maxlen, init_printout, msg, get_in, lunout, prt_level, maxTableWidth
    99  PUBLIC :: strLower, strHead, strStack,  strCount, strReduce,  strClean, strIdx
    1010  PUBLIC :: strUpper, strTail, strStackm, strParse, strReplace, strFind, find, duplicate, cat
    … …  
    2323  INTERFACE strCount;   MODULE PROCEDURE  strCount_m1, strCount_11, strCount_1m; END INTERFACE strCount
    2424  INTERFACE strReplace; MODULE PROCEDURE strReplace_1,             strReplace_m; END INTERFACE strReplace
    25   INTERFACE cat; MODULE PROCEDURE  horzcat_s00, horzcat_i00, horzcat_r00, horzcat_d00, &
    26                                    horzcat_s10, horzcat_i10, horzcat_r10, horzcat_d10, &
    27                                    horzcat_s11, horzcat_i11, horzcat_r11, horzcat_d11, &
    28                                    horzcat_s21, horzcat_i21, horzcat_r21;  END INTERFACE cat !horzcat_d21
     25  INTERFACE cat; MODULE PROCEDURE  horzcat_s00, horzcat_i00, horzcat_r00, horzcat_d00, horzcat_l00, &
     26                                   horzcat_s10, horzcat_i10, horzcat_r10, horzcat_d10, horzcat_l10, &
     27                                   horzcat_s11, horzcat_i11, horzcat_r11, horzcat_d11, horzcat_l11, &
     28                                   horzcat_s21, horzcat_i21, horzcat_r21, horzcat_d21, horzcat_l21, &
     29                                   horzcat_s22, horzcat_i22, horzcat_r22, horzcat_d22, horzcat_l22; END INTERFACE cat
    2930  INTERFACE strFind;      MODULE PROCEDURE strFind_1, strFind_m;           END INTERFACE strFind
    30   INTERFACE find;         MODULE PROCEDURE strFind_1, strFind_m, intFind_1, intFind_m, booFind; END INTERFACE find
     31  INTERFACE find;         MODULE PROCEDURE strFind_1, strFind_m, intFind_1, intFind_m, booFind;     END INTERFACE find
    3132  INTERFACE duplicate;    MODULE PROCEDURE dupl_s, dupl_i, dupl_r, dupl_l; END INTERFACE duplicate
     33  INTERFACE dispTable;    MODULE PROCEDURE    dispTable_1,    dispTable_2; END INTERFACE dispTable
    3234  INTERFACE dispOutliers; MODULE PROCEDURE dispOutliers_1, dispOutliers_2; END INTERFACE dispOutliers
    3335  INTERFACE reduceExpr;   MODULE PROCEDURE   reduceExpr_1,   reduceExpr_m; END INTERFACE reduceExpr
    … …  
    3739  INTEGER,      SAVE :: lunout    = 6                      !--- Printing unit  (default: 6, ie. on screen)
    3840  INTEGER,      SAVE :: prt_level = 1                      !--- Printing level (default: 1, ie. print all)
     41  INTEGER,      SAVE :: maxTableWidth = 192                !--- Default max. number of characters per lines in dispTable
    3942
    4043CONTAINS
    … …  
    12161219
    12171220!==============================================================================================================================
    1218 !--- Display a clean table composed of successive vectors of same length.
     1221!=== DISPLAY A TABLE COMPOSED OF HORIZONTALLY CONCATENATED COLUMN VECTORS =====================================================
     1222!==============================================================================================================================
    12191223!=== The profile "p" describe in which order to pick up the columns from "s", "i" and "r" for display.
    12201224!===  * nRowMax lines are displayed (default: all lines)
    1221 !===  * nColMax characters (default: as long as needed) are displayed at most on a line. If the effective total length is
    1222 !===    higher, several partial tables are displayed ; the nHead (default: 1) first columns are included in each sub-table.
    1223 !==============================================================================================================================
    1224  FUNCTION dispTable(p, titles, s, i, r, rFmt, nRowMax, nColMax, nHead, unit, sub) RESULT(lerr)
    1225   IMPLICIT NONE
    1226   CHARACTER(LEN=*),           INTENT(IN)  :: p             !--- DISPLAY MAP: s/i/r
    1227   CHARACTER(LEN=*),           INTENT(IN)  :: titles(:)     !--- TITLES (ONE EACH COLUMN)
    1228   CHARACTER(LEN=*), OPTIONAL, INTENT(IN)  :: s(:,:)        !--- STRINGS
    1229   INTEGER,          OPTIONAL, INTENT(IN)  :: i(:,:)        !--- INTEGERS
    1230   REAL,             OPTIONAL, INTENT(IN)  :: r(:,:)        !--- REALS
    1231   CHARACTER(LEN=*), OPTIONAL, INTENT(IN)  :: rFmt          !--- Format for reals
    1232   INTEGER,          OPTIONAL, INTENT(IN)  :: nRowMax       !--- Display at most "nRowMax" rows
    1233   INTEGER,          OPTIONAL, INTENT(IN)  :: nColMax       !--- Display at most "nColMax" characters each line
    1234   INTEGER,          OPTIONAL, INTENT(IN)  :: nHead         !--- Head columns repeated for multiple tables display
    1235   INTEGER,          OPTIONAL, INTENT(IN)  :: unit          !--- Output unit (default: screen)
    1236   CHARACTER(LEN=*), OPTIONAL, INTENT(IN)  :: sub           !--- Subroutine name
    1237   LOGICAL :: lerr
    1238 !------------------------------------------------------------------------------------------------------------------------------
    1239   CHARACTER(LEN=2048) :: row
    1240   CHARACTER(LEN=maxlen)  :: rFm, el, subn
     1225!===  * nColMax characters (default: as long as needed) are displayed at most on a line.
     1226!===     - narrow tables are stacked horizontally as much as possible (ie: total width must stay lower than nColMax) .
     1227!===     - wide tables are cut into several sub-tables of columns subsets, with the first nHead columns repeated.
     1228!===  * titles can be a vector (one element each column) or an array (dim 1: number of lines ; dim 2: number of columns)
     1229!==============================================================================================================================
     1230LOGICAL FUNCTION dispTable_1(p, titles, s, i, r, rFmt, nRowMax, nColMax, nHead, unit, sub) RESULT(lerr)
     1231  IMPLICIT NONE
     1232  CHARACTER(LEN=*),           INTENT(IN)  :: p                       !--- DISPLAY MAP: s/i/r
     1233  CHARACTER(LEN=*),           INTENT(IN)  :: titles(:)               !--- TITLES (one each column, single line)
     1234  CHARACTER(LEN=*), OPTIONAL, INTENT(IN)  :: s(:,:)                  !--- STRINGS
     1235  INTEGER,          OPTIONAL, INTENT(IN)  :: i(:,:)                  !--- INTEGERS
     1236  REAL,             OPTIONAL, INTENT(IN)  :: r(:,:)                  !--- REALS
     1237  CHARACTER(LEN=*), OPTIONAL, INTENT(IN)  :: rFmt                    !--- Format for reals
     1238  INTEGER,          OPTIONAL, INTENT(IN)  :: nRowMax                 !--- Display at most "nRowMax" rows
     1239  INTEGER,          OPTIONAL, INTENT(IN)  :: nColMax                 !--- Display at most "nColMax" characters each line
     1240  INTEGER,          OPTIONAL, INTENT(IN)  :: nHead                   !--- Head columns repeated for multiple tables display
     1241  INTEGER,          OPTIONAL, INTENT(IN)  :: unit                    !--- Output unit (default: screen)
     1242  CHARACTER(LEN=*), OPTIONAL, INTENT(IN)  :: sub                     !--- Subroutine name
     1243!------------------------------------------------------------------------------------------------------------------------------
     1244  lerr = dispTable_2(p, RESHAPE(titles, [1,SIZE(titles)]), s, i, r, rFmt, nRowMax, nColMax, nHead, unit, sub)
     1245END FUNCTION dispTable_1
     1246!==============================================================================================================================
     1247LOGICAL FUNCTION dispTable_2(p, titles, s, i, r, rFmt, nRowMax, nColMax, nHead, unit, sub) RESULT(lerr)
     1248  IMPLICIT NONE
     1249  CHARACTER(LEN=*),           INTENT(IN)  :: p                       !--- DISPLAY MAP: s/i/r
     1250  CHARACTER(LEN=*),           INTENT(IN)  :: titles(:,:)             !--- TITLES (one each column, possibly more than one line)
     1251  CHARACTER(LEN=*), OPTIONAL, INTENT(IN)  :: s(:,:)                  !--- STRINGS
     1252  INTEGER,          OPTIONAL, INTENT(IN)  :: i(:,:)                  !--- INTEGERS
     1253  REAL,             OPTIONAL, INTENT(IN)  :: r(:,:)                  !--- REALS
     1254  CHARACTER(LEN=*), OPTIONAL, INTENT(IN)  :: rFmt                    !--- Format for reals
     1255  INTEGER,          OPTIONAL, INTENT(IN)  :: nRowMax                 !--- Display at most "nRowMax" rows
     1256  INTEGER,          OPTIONAL, INTENT(IN)  :: nColMax                 !--- Display at most "nColMax" characters each line
     1257  INTEGER,          OPTIONAL, INTENT(IN)  :: nHead                   !--- Head columns repeated for multiple tables display
     1258  INTEGER,          OPTIONAL, INTENT(IN)  :: unit                    !--- Output unit (default: screen)
     1259  CHARACTER(LEN=*), OPTIONAL, INTENT(IN)  :: sub                     !--- Subroutine name
     1260!------------------------------------------------------------------------------------------------------------------------------
     1261  INTEGER, PARAMETER :: nm = 1
     1262  INTEGER, ALLOCATABLE :: n(:), nmx(:)
     1263  INTEGER :: nRmx, nCmx, nHd, unt, ib, ic, ie, it, nt, ncol, k, l, l0
     1264  CHARACTER(LEN=maxlen), ALLOCATABLE :: c(:,:), c1(:,:), m(:)
     1265  CHARACTER(LEN=maxlen) :: subn
     1266
     1267  !=== CONVERT THE ELEMENTS INTO A STRINGS ARRAY
     1268  lerr = convertTable(p, titles, c, s, i, r, rFmt, sub); IF(lerr) RETURN
     1269
     1270  !=== GET VALUES FOR REMAINING OPTIONAL ARGUMENTS
     1271  nRmx= SIZE(c, 1);    IF(PRESENT(nRowMax)) nRmx=MIN(nRmx,nRowMax)   !--- Maximum number of lines to print
     1272  nCmx= maxTableWidth; IF(PRESENT(nColMax)) nCmx=MIN(nCmx,nColMax)   !--- Maximum number of characters each line
     1273  nHd = 0;             IF(PRESENT(nHead))   nHd = nHead              !--- Number of front columns to duplicate
     1274  unt = lunout;        IF(PRESENT(unit))    unt = unit               !--- Unit to print messages
     1275  subn= 'dispTable';   IF(PRESENT(sub))     subn= sub                !--- Calling subroutine name
     1276
     1277  !=== SMALL WIDTH TABLE: STACK AS MUCH VERTICAL SECTIONS HORIZONTALLY AS POSSIBLE CONSIDERING nColMax. UNTOUCHED OTHERWISE.
     1278  n  = tableCellsWidth(c)+2*nm
     1279  c1 = gatherTable(c, n, SIZE(titles, 1), nRmx, nCmx, subn)
     1280  ncol = SIZE(c1, DIM=2)
     1281  IF(ncol /= SIZE(c,2)) n = tableCellsWidth(c1)+2*nm                 !--- UPDATE "n(:)" IF "c" HAS BEEN STACKED
     1282
     1283  nCmx = 48
     1284
     1285  !=== HIGH WIDTH TABLE: CUT IT INTO SUB-TABLES, WITH THE FIRST "nHead" COLUMNS REPEATED IN EACH OF THEM
     1286  !--- Build the vector of max column index in case the rows are too long (table must be displayed in multiple parts)
     1287  IF(SUM(n+1)-1 > nCmx .AND. ncol > 1) THEN
     1288     l0 = 1 + LEN_TRIM(subn) + SUM(n(1:nHd)+1)
     1289
     1290     !=== DETERMINE THE NUMBER "nt" OF SUB-TABLES
     1291     nt=1; l=l0; DO ic = nHd+1, ncol; IF(l+n(ic)+1 >= nCmx) THEN; l=l0; nt=nt+1;               END IF; l = l+n(ic)+1; END DO
     1292
     1293     !=== GET THE INDEX OF THE LAST COLUMN FOR EACH SUB-TABLE
     1294     ALLOCATE(nmx(nt))
     1295     it=0; l=l0; DO ic = nHd+1, ncol; IF(l+n(ic)+1 >= nCmx) THEN; l=l0; it=it+1; nmx(it)=ic-1; END IF; l = l+n(ic)+1; END DO
     1296     nmx(nt) = ncol
     1297
     1298     !=== DISPLAY THE SUB-TABLES
     1299     DO it = 1, nt
     1300        ie = nmx(it); ib = nHd+1; IF(it > 1) ib = nmx(it-1)+1
     1301        m = buildTable(cat(c1(:,1:nHd),c1(:,ib:ie)), nm, SIZE(titles, 1))
     1302        DO k = 1, SIZE(m); CALL msg(TRIM(m(k)), subn, unit=unt); END DO; CALL msg('', subn, unit=unt)
     1303     END DO
     1304  ELSE
     1305     !=== DISPLAY THE SINGLE TABLE
     1306     m  = buildTable(c1, nm, SIZE(titles,1))
     1307     DO k = 1, SIZE(m); CALL msg(TRIM(m(k)), subn, unit=unt); END DO
     1308  END IF
     1309
     1310CONTAINS
     1311
     1312FUNCTION tableCellsWidth(t) RESULT(n)  !=== COMPUTE FOR EACH COLUMN THE MIMIMUM WIDTH TO DISPLAY ELEMENTS WITHOUT TRUNCATION
     1313  CHARACTER(LEN=*), INTENT(IN) :: t(:,:)
     1314  INTEGER, ALLOCATABLE :: n(:)
     1315  INTEGER :: i, j
     1316  n = [(MAXVAL([(LEN_TRIM(t(i,j)), i=1, SIZE(t,1))], DIM=1), j=1, SIZE(t,2))]
     1317END FUNCTION tableCellsWidth
     1318
     1319END FUNCTION dispTable_2
     1320!==============================================================================================================================
     1321
     1322
     1323!==============================================================================================================================
     1324!--- Concatenate horizontally the table d0(:,:) so that:
     1325!===  * total width (number of characters per line) remains lower than nColMax (default: 256 characters)
     1326!===  * total number of lines remains lower than nRowMax                       (default: all lines are kept)
     1327!=== If the table d0 starts with nTitle /= 0 lines for titles, they are duplicated at each section top.
     1328!==============================================================================================================================
     1329FUNCTION gatherTable(d0, n, nTitle, nRowMax, nColMax, sub) RESULT(d1)
     1330  IMPLICIT NONE
     1331  CHARACTER(LEN=*),           INTENT(IN) :: d0(:,:)        !--- Input strings array
     1332  INTEGER,                    INTENT(IN) :: n(:)           !--- Maximum width of elements in each column (excluding separator)
     1333  INTEGER,          OPTIONAL, INTENT(IN) :: nTitle         !--- Number of rows for titles
     1334  INTEGER,          OPTIONAL, INTENT(IN) :: nRowMax        !--- Maximum number of rows
     1335  INTEGER,          OPTIONAL, INTENT(IN) :: nColMax        !--- Maximum number of characters each line
     1336  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sub            !--- Subroutine name
     1337  CHARACTER(LEN=maxlen),     ALLOCATABLE :: d1(:,:)        !--- Array of horizontally gathered sections
     1338  INTEGER :: nr0, nc0, nr1, nc1                            !--- Row and columns numbers for original and gathered array
     1339  INTEGER :: ih, nh, nv                                    !--- Index and number of stacked sections
     1340  INTEGER :: nttl, nrMx, ncMx                              !--- Titles number and effective max. row and columns numbers
     1341  INTEGER :: nrem, nr, ir0, icb, ice
     1342  nr0 = SIZE(d0, DIM=1)
     1343  nc0 = SIZE(d0, DIM=2)
     1344  nttl = 0;   IF(PRESENT(nTitle))  nttl = nTitle
     1345  ncMx = 256; IF(PRESENT(nColMax)) ncMx = MIN(nCmx, nColMax)
     1346  nrMx = nr0; IF(PRESENT(nRowMax)) nrMx = MIN(nrMx, nRowMax)
     1347  nh = MAX(1, ncMx/SUM(n+1))                               !--- Max. horiz. stackabled sections for ncMx (+1: last separator)
     1348  nv = 1+(nr0-nttl-1)/nh                                   !--- Corresponding number ofvertical elements per section
     1349  nh = 1+(nr0-nttl-1)/nv                                   !--- Effective number of sections
     1350  nr1 = MIN(nrMx,1+ nttl+(nr0-nttl-1)/nh); nc1 = nc0*nh    !--- Shape of the stacked array
     1351  ALLOCATE(d1(nr1,nc1))
     1352  nrem = nr0                                               !--- Remaining values to fill in
     1353  DO ih = 1, nh
     1354     nr = MAX(0,MIN(nr1,nrem)-nttl); nrem=nrem-nr          !--- Number of copied rows in ith section (excluding titles)
     1355     ir0 = nttl+(ih-1)*(nr1-nttl)                          !--- Row start index in d1
     1356     ice = ih*nc0; icb = ice-nc0+1                         !--- Column end and start indices in d1
     1357     d1(1:nttl,        icb:ice) = d0(1:nttl,      :)       !--- Copy titles line(s)
     1358     d1(1+nttl:nr+nttl,icb:ice) = d0(1+ir0:nr+ir0,:)       !--- Copy ith section
     1359     IF(nr1 == nr + nttl) CYCLE
     1360     d1(1+nr+nttl:nr1, icb:ice) =' '                       !--- Fill missing cells with a space
     1361  END DO
     1362END FUNCTION gatherTable
     1363!==============================================================================================================================
     1364
     1365
     1366!==============================================================================================================================
     1367!--- Convert a set of columns of different natures ("s"trings, "i"ntegers, "r"eals) into a strings table.   Default value
     1368!===  * p:    profile giving the order to pick up columns from "s", "i" and "r" to construct "c(:,:)".        mandatory
     1369!===  * t:    titles, one per variable (2nd index), possibly on several lines (1st index).                    mandatory
     1370!===  * c:    assembled array                                                                                 mandatory
     1371!===  * s:    horizontally stacked string  column vectors of values                                           /
     1372!===  * i:    horizontally stacked integer column vectors of values                                           /
     1373!===  * r:    horizontally stacked real    column vectors of values                                           /
     1374!===  * rFmt: format for real conversion                                                                      *
     1375!===  * sub:  calling subroutine name (for error messages)                                                    /
     1376!=== NOTE: The vectors s, i and r do not have necessarly the same length. Empty elements are filled at the end.
     1377!==============================================================================================================================
     1378LOGICAL FUNCTION convertTable(p, t, c, s, i, r, rFmt, sub) RESULT(lerr)
     1379  IMPLICIT NONE
     1380  CHARACTER(LEN=*),                   INTENT(IN)  :: p          !--- DISPLAY MAP: s/i/r
     1381  CHARACTER(LEN=*),                   INTENT(IN)  :: t(:,:)     !--- TITLES (ONE EACH COLUMN)
     1382  CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: c(:,:)     !--- CONVERTED STRINGS TABLE
     1383  CHARACTER(LEN=*),         OPTIONAL, INTENT(IN)  :: s(:,:)     !--- STRINGS
     1384  INTEGER,                  OPTIONAL, INTENT(IN)  :: i(:,:)     !--- INTEGERS
     1385  REAL,                     OPTIONAL, INTENT(IN)  :: r(:,:)     !--- REALS
     1386  CHARACTER(LEN=*),         OPTIONAL, INTENT(IN)  :: rFmt       !--- Format for reals
     1387  CHARACTER(LEN=*),         OPTIONAL, INTENT(IN)  :: sub        !--- Subroutine name
     1388!------------------------------------------------------------------------------------------------------------------------------
    12411389  CHARACTER(LEN=maxlen), ALLOCATABLE :: d(:,:)
    1242   CHARACTER(LEN=1) :: s1, sp
    1243   INTEGER :: is, ii, ir, it, k, nmx,  unt, ic, np
    1244   INTEGER :: ns, ni, nr, nt, l, ncol, nHd, ib, l0
    1245   INTEGER, ALLOCATABLE :: n(:), ncmx(:)
    1246   INTEGER, PARAMETER   :: nm=1                             !--- Space between values & columns
    1247   LOGICAL :: ls, li, lr
     1390  CHARACTER(LEN=maxlen)  :: rFm, subn
     1391  CHARACTER(LEN=1) :: sp = '|'                             !--- Table cells separator
     1392  INTEGER :: it, is, ii, ir, ic, nmx
     1393  INTEGER :: nt, ns, ni, nr, ncol
     1394  LOGICAL :: ls, li, lr, ll
     1395  rFm = '*';    IF(PRESENT(rFmt)) rFm = rFmt               !--- Specified format for reals
    12481396  subn = '';    IF(PRESENT(sub)) subn = sub
    1249   rFm = '*';    IF(PRESENT(rFmt)) rFm = rFmt               !--- Specified format for reals
    1250   unt = lunout; IF(PRESENT(unit)) unt = unit               !--- Specified output unit
    1251   np = LEN_TRIM(p); ns = 0; ni = 0; nr = 0; ncol = 0
    12521397  ls = PRESENT(s); li = PRESENT(i); lr = PRESENT(r)
    1253   lerr = .FALSE.; IF(.NOT.ANY([ls,li,lr])) RETURN          !--- Nothing to do
    1254   sp = '|'                                                 !--- Separator
     1398  ns = 0; ni = 0; nr = 0; ncol = 0
     1399  ncol = LEN_TRIM(p)                                       !--- Number of columns of the table
     1400  nt   = SIZE(t,1)
    12551401
    12561402  !--- CHECK ARGUMENTS COHERENCE
    1257   lerr = np /= SIZE(titles); CALL msg('display map "p" length and titles list mismatch', subn, lerr); IF(lerr) RETURN
    1258   IF(ls) THEN
    1259     ns = SIZE(s, 1); ncol = ncol + SIZE(s, 2); lerr = COUNT([(p(ic:ic)=='s', ic=1, np)]) /= SIZE(s, 2)
     1403  lerr = .NOT.ANY([ls,li,lr])
     1404  CALL msg('missing argument(s) "s", "i" and/or "r"', subn, lerr)
     1405  IF(lerr) RETURN
     1406  lerr = ncol /= SIZE(t,2)
     1407  CALL msg('display map "p" length and titles number mismatch', subn, lerr)
     1408  IF(lerr) RETURN
     1409  IF(ls) THEN; ns = SIZE(s,1)
     1410     lerr = COUNT([(p(ic:ic)=='s', ic=1, ncol)]) /= SIZE(s,2)
     1411     CALL msg('display map "p" and string arguments mismatch: nb(p=="s")/=SIZE(s,2)', subn, lerr)
     1412     IF(lerr) RETURN
    12601413  END IF
    1261   IF(li) THEN
    1262     ni = SIZE(i, 1); ncol = ncol + SIZE(i, 2); lerr = COUNT([(p(ic:ic)=='i', ic=1, np)]) /= SIZE(i, 2)
     1414  IF(li) THEN; ni = SIZE(i,1)
     1415     lerr = COUNT([(p(ic:ic)=='i', ic=1, ncol)]) /= SIZE(i,2)
     1416     CALL msg('display map "p" and integer arguments mismatch: nb(p=="i")/=SIZE(i,2)', subn, lerr)
     1417     IF(lerr) RETURN
    12631418  END IF
    1264   IF(lr) THEN
    1265     nr = SIZE(r, 1); ncol = ncol + SIZE(r, 2); lerr = COUNT([(p(ic:ic)=='r', ic=1, np)]) /= SIZE(r, 2)
     1419  IF(lr) THEN; nr = SIZE(r,1)
     1420     lerr = COUNT([(p(ic:ic)=='r', ic=1, ncol)]) /= SIZE(r,2)
     1421     CALL msg('display map "p" and real arguments mismatch: nb(p=="r")/=SIZE(r,2)', subn, lerr)
     1422     IF(lerr) RETURN
    12661423  END IF
    1267   CALL msg('display map "p" length and arguments number mismatch', subn, lerr); IF(lerr) RETURN
    1268   lerr = ncol /= SIZE(titles); CALL msg('"titles" length and arguments number mismatch', subn, lerr); IF(lerr) RETURN
    1269   lerr = ls.AND.li.AND.ns/=ni; CALL msg('string and integer arguments lengths mismatch', subn, lerr); IF(lerr) RETURN
    1270   lerr = ls.AND.lr.AND.ns/=nr; CALL msg(   'string and real arguments lengths mismatch', subn, lerr); IF(lerr) RETURN
    1271   lerr = li.AND.lr.AND.ni/=nr; CALL msg(  'integer and real arguments lengths mismatch', subn, lerr); IF(lerr) RETURN
    1272   nmx = MAX(ns,ni,nr)+1; IF(PRESENT(nRowMax)) nmx = MIN(nmx,nRowMax+1)
    1273 
    1274   !--- Allocate the assembled quantities array
    1275   ALLOCATE(d(nmx,ncol), n(ncol))
     1424!  lerr = (ls.AND.li .AND. ns /= ni) .OR. (li.AND.lr .AND. ni /= nr) .OR. (lr.AND.ls .AND. nr /= ns)
     1425!  CALL msg('mismatching rows numbers for at least "s", "i" or "r"', subn, lerr)
     1426!  IF(lerr) RETURN
     1427  nmx = MAX(ns, ni, nr) + nt
    12761428
    12771429  !--- Assemble the vectors into a strings array in the order indicated by "pattern"
     1430  ALLOCATE(c(nmx,ncol))
    12781431  is =  1; ii = 1; ir = 1
    12791432  DO ic = 1, ncol
    1280     d(1,ic) = TRIM(titles(ic))
     1433    c(1:nt,ic) = t(1:nt,ic)                                          !--- Add titles line(s)
    12811434    SELECT CASE(p(ic:ic))
    1282       CASE('s'); d(2:nmx,ic) =         s(:,is)     ; is = is + 1
    1283       CASE('i'); d(2:nmx,ic) = num2str(i(:,ii)    ); ii = ii + 1
    1284       CASE('r'); d(2:nmx,ic) = num2str(r(:,ir),rFm); ir = ir + 1
     1435      CASE('s'); c(1+nt:nmx,ic) =         s(:,is)     ; is = is + 1  !--- Add string  elements
     1436      CASE('i'); c(1+nt:nmx,ic) = num2str(i(:,ii)    ); ii = ii + 1  !--- Add integer elements
     1437      CASE('r'); c(1+nt:nmx,ic) = num2str(r(:,ir),rFm); ir = ir + 1  !--- Add real    elements
    12851438    END SELECT
    12861439  END DO
    1287   CALL cleanZeros(d)
    1288   DO ic = 1, ncol
    1289     n(ic)=0; DO ir=1, nmx; n(ic)=MAX(n(ic), LEN_TRIM(d(ir,ic))); END DO
    1290   END DO
    1291   n(:) = n(:) + 2*nm
    1292 
    1293   !--- Build the vector of max column index in case the rows are too long (table must be displayed in multiple parts)
    1294   nHd = 1; IF(PRESENT(nHead)) nHd = nHead
    1295   IF(.NOT.PRESENT(nColMax)) THEN
    1296     nt = 1; ncmx = [ncol]
    1297   ELSE
    1298     nt = 1; l0 = SUM(n(1:nHd)+1)+1
    1299     IF(PRESENT(sub)) l0=l0+LEN_TRIM(subn)+1
    1300     !--- Count the number of table parts
    1301     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
    1302     !--- Get the index of the last column for each table part
    1303     ALLOCATE(ncmx(nt)); k = 1
    1304     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
    1305     ncmx(nt) = ncol
    1306   END IF
    1307      
    1308   !--- Display the strings array as a table
    1309   DO it = 1, nt
    1310     DO ir = 1, nmx; row = ''
    1311       DO ic = 1, nHd; el = d(ir,ic)
    1312         s1 = sp
    1313         row = TRIM(row)//REPEAT(' ',nm)//TRIM(el)//REPEAT(' ',n(ic)-LEN_TRIM(el)-nm)//s1
    1314       END DO
    1315       ib = nHd+1; IF(it>1) ib = ncmx(it-1)+1
    1316       DO ic = ib, ncmx(it); el = d(ir,ic)
    1317         s1 = sp
    1318         row = TRIM(row)//REPEAT(' ',nm)//TRIM(el)//REPEAT(' ',n(ic)-LEN_TRIM(el)-nm)//s1
    1319       END DO
    1320       nr = LEN_TRIM(row)-1                                           !--- Final separator removed
    1321       CALL msg(row(1:nr), subn, unit=unt)
    1322       IF(ir /= 1) CYCLE                                              !--- Titles only are underlined
    1323       row=''; DO ic=1,nHd; row=TRIM(row)//REPEAT('-',n(ic))//'+'; END DO
    1324       DO ic = ib,ncmx(it); row=TRIM(row)//REPEAT('-',n(ic))//'+'; END DO
    1325       CALL msg(row(1:LEN_TRIM(row)-1), subn, unit=unt)
    1326     END DO
    1327     CALL msg('', subn, unit=unt)
    1328   END DO
    1329 
    1330 END FUNCTION dispTable
    1331 !==============================================================================================================================
     1440  CALL cleanZeros(c)                                                 !--- Remove useless zeros in converted numbers
     1441
     1442END FUNCTION convertTable
     1443!==============================================================================================================================
     1444
     1445
     1446!==============================================================================================================================
     1447!--- Build a table from the string array "d(:,:)" as a vector of assembled lines (to be printed as messages).
     1448!===  * each column has the minimum width "n(j)" needed to display the elements "d(:,j)" with at least "nm" spaces each side.
     1449!===  * the structure of a cell is:  <n1 spaces><TRIM(d(i,j))><n2 spaces>| (pay attention to the end separator "|")
     1450!===  * n1 and n2 depend on the justification (three methods available) and give a total width of "n(j)", as expected.
     1451!===  * each cell ends with the separator "|", except the last one
     1452!===  * nTitle/=0 means that the first "nTitle" lines will be separated from the rest of the table with an underline.
     1453!==============================================================================================================================
     1454FUNCTION buildTable(d, nm, nTitle) RESULT(m)
     1455  IMPLICIT NONE
     1456  CHARACTER(LEN=*),  INTENT(IN) :: d(:,:)                  !--- Input array
     1457  INTEGER,           INTENT(IN) :: nm                      !--- Number of spaces before and after values
     1458  INTEGER, OPTIONAL, INTENT(IN) :: nTitle                  !--- Number of rows for titles
     1459  CHARACTER(LEN=10*maxlen), ALLOCATABLE :: m(:)            !--- Lines to issue as messages to display the table
     1460  CHARACTER(LEN=1) :: sp = '|'                             !--- Separator
     1461  INTEGER :: ir, ic, nr, nc, i, j, n(SIZE(d,2)), nttl, id, p
     1462  nr = SIZE(d, DIM=1); nc = SIZE(d, DIM=2)                 !--- Dimensions of the table
     1463  nttl = 0; IF(PRESENT(nTitle))  nttl = nTitle
     1464  n = [(MAXVAL([(LEN_TRIM(d(i,j)), i=1, nr)], DIM=1), j=1, nc)] + 2*nm
     1465  ALLOCATE(m(nr+1))                                        !--- Allocate the vector (+1 for header line)
     1466  i = 1
     1467  DO ir = 1, nr
     1468     IF(ir <= nttl) CALL centerJustified(d(ir,:), n, i, m(i))
     1469     IF(ir == nttl) CALL      headerLine(         n, i, m(i))
     1470     IF(ir >  nttl) CALL   leftJustified(d(ir,:), n, i, m(i))
     1471  END DO
     1472
     1473CONTAINS
     1474
     1475SUBROUTINE leftJustified(d, n, i, r)
     1476  CHARACTER(LEN=*), INTENT(IN)    :: d(:)
     1477  INTEGER,          INTENT(IN)    :: n(:)
     1478  CHARACTER(LEN=*), INTENT(INOUT) :: r
     1479  INTEGER,          INTENT(INOUT) :: i
     1480  r = ''
     1481  DO id = 1, nc; r = TRIM(r)//REPEAT(' ',nm)//TRIM(d(id))//REPEAT(' ',n(id)-LEN_TRIM(d(id))-nm)//sp; END DO
     1482  r = r(1:LEN_TRIM(r)-1); i = i+1                          !--- Final separator removed
     1483END SUBROUTINE leftJustified
     1484
     1485SUBROUTINE centerJustified(d, n, i, r)
     1486  CHARACTER(LEN=*), INTENT(IN)    :: d(:)
     1487  INTEGER,          INTENT(IN)    :: n(:)
     1488  INTEGER,          INTENT(INOUT) :: i
     1489  CHARACTER(LEN=*), INTENT(INOUT) :: r
     1490  INTEGER :: p
     1491  r = ''; DO id = 1, nc; p=n(id)-LEN_TRIM(d(id)); r = TRIM(r)//REPEAT(' ', p - p/2)//TRIM(d(id))//REPEAT(' ', p/2)//sp; END DO
     1492  r = r(1:LEN_TRIM(r)-1); i = i+1                          !--- Final separator removed
     1493END SUBROUTINE centerJustified
     1494
     1495SUBROUTINE rightJustified(d, n, i, r)
     1496  CHARACTER(LEN=*), INTENT(IN)    :: d(:)
     1497  INTEGER,          INTENT(IN)    :: n(:)
     1498  INTEGER,          INTENT(INOUT) :: i
     1499  CHARACTER(LEN=*), INTENT(INOUT) :: r
     1500  r = ''; DO id = 1, nc; r = TRIM(r)//REPEAT(' ',n(id)-LEN_TRIM(d(id))-nm)//TRIM(d(id))//REPEAT(' ',nm)//sp; END DO
     1501  r = r(1:LEN_TRIM(r)-1); i = i+1                          !--- Final separator removed
     1502END SUBROUTINE rightJustified
     1503
     1504SUBROUTINE headerLine(n, i, r)
     1505  INTEGER,          INTENT(IN)    :: n(:)
     1506  INTEGER,          INTENT(INOUT) :: i
     1507  CHARACTER(LEN=*), INTENT(INOUT) :: r
     1508  r = ''; DO id= 1 , nc; r = TRIM(r)//REPEAT('-',n(id))//'+'; END DO
     1509  r = r(1:LEN_TRIM(r)-1); i = i+1                          !--- Final '+' removed
     1510END SUBROUTINE headerLine
     1511
     1512END FUNCTION buildTable
     1513!==============================================================================================================================
     1514
    13321515
    13331516!==============================================================================================================================
Note: See TracChangeset for help on using the changeset viewer.