Index: LMDZ6/trunk/libf/misc/strings_mod.f90 =================================================================== --- LMDZ6/trunk/libf/misc/strings_mod.f90 (revision 5751) +++ LMDZ6/trunk/libf/misc/strings_mod.f90 (revision 5752) @@ -1598,139 +1598,4 @@ !============================================================================================================================== -LOGICAL FUNCTION dispOutliers_1(ll, a, n, err_msg, nam, subn, nRowmax, nColMax, nHead, 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(:), subn !--- 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) :: nHead !--- Number of front columns to duplicate (default: 1) - INTEGER, OPTIONAL, INTENT(IN) :: unit !--- Output unit (def: lunout) -!------------------------------------------------------------------------------------------------------------------------------ - CHARACTER(LEN=maxlen), ALLOCATABLE :: ttl(:) - LOGICAL, ALLOCATABLE :: m(:) - INTEGER, ALLOCATABLE :: ki(:), kj(:) - INTEGER :: i, j, k, rk, rk1, ib, ie, itr, nm, unt, nRmx, nCmx, nHd, nv - CHARACTER(LEN=maxlen) :: mes, sub, fm='(f12.9)', v, s - CHARACTER(LEN=maxlen), ALLOCATABLE :: vnm(:) - - lerr = ANY(ll); IF(.NOT.lerr) 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 - sub = 'dispOutliers'; IF(PRESENT(subn)) sub = subn !--- 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 - nHd = 1; IF(PRESENT(nHead)) nHd = nHead !--- Number of front columns to duplicate - unt = lunout; IF(PRESENT(unit)) unt = unit !--- Unit to print messages - - rk = SIZE(n); nv = SIZE(vnm) - lerr = nv/=1 .AND. nv/=n(rk); CALL msg('SIZE(nam) /= 1 and /= last "n" element', sub, lerr); IF(lerr) RETURN - lerr = SIZE(a) /= SIZE(ll); CALL msg('ll" and "a" sizes mismatch', sub, lerr); IF(lerr) RETURN - lerr = SIZE(a) /= PRODUCT(n); CALL msg('profile "n" does not match "a" and "ll', sub, lerr); IF(lerr) RETURN - CALL msg(mes, sub, unit=unt) - - !--- SCALAR CASE: single value to display - IF(rk==1.AND.n(1)==1) THEN - IF(ll(1)) WRITE(unt,'(a," = ",f12.9)')TRIM(nam(1)),a(1); RETURN - END IF - - rk1 = rk; IF(nv==1) rk1 = rk-1 !--- Rank of each displayed table - SELECT CASE(rk1) !--- Indices list - CASE(1,2); ki = [ (i,i=1,n(1)) ] - CASE(3); ki = [((i,i=1,n(1)),j=1,n(2))]; kj = [((j,i=1,n(1)),j=1,n(2))] - CASE DEFAULT; WRITE(unt,*)'Sorry: routine "dispOutliers" is limited to rank 3'; RETURN - END SELECT - - !--- VECTOR CASE: table " name | value " (known names) / ) / " i | a(i) " (unknown names) - IF(rk==1) THEN - ALLOCATE(ttl(2)); ttl(2) = TRIM(vnm(1))//'(i)'; ttl(1) = 'i' - IF(nv == 1) lerr = dispTable('sr', ttl, s=cat(PACK(nam,ll)), r=cat(PACK(a,ll)), & - rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=nHd, unit=unt, sub=sub) - IF(nv /= 1) lerr = dispTable('ir', ['name ','value'], i=cat(PACK(ki,m)), r=cat(PACK(a,ll)), & - rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=nHd, unit=unt, sub=sub) - CALL msg("can't display outliers table", sub, lerr, unt) - RETURN - END IF - - !--- OTHER CASES: one table for each tracer (last index) - ttl = [(ACHAR(k), k = 105, 104+rk)] !--- Titles list ('i', 'j', 'k'...) - s = strStack( ttl(1:rk-1) ) !--- Tracer name dummy indexes: (i, j, k, ... - - DO itr=1,n(rk) - nm = PRODUCT(n(1:rk-1)) !--- number of elements per tracer - ie = itr*nm; ib = ie-nm+1; m=ll(ib:ie) !--- section bounds for tracer "itr" ; outlayers mask - IF(.NOT.ANY(m)) CYCLE !--- no outlayers for tracer "itr" - v = TRIM(vnm(MIN(itr,SIZE(vnm))))//'('//TRIM(s) !--- "(" - IF(nv == 1) ttl(rk) = TRIM(v)//','//num2str(itr)//')' !--- "(i,j,itr)" (single name) - IF(nv /= 1) ttl(rk) = TRIM(v)//')' !--- "(i,j)" (one name each table/itr index) - IF(rk==2) lerr = dispTable('ir', ttl, i=cat(PACK(ki,m)), r=cat(PACK(a(ib:ie),m)), & - rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=nHd, unit=unt, sub=sub) - IF(rk==3) lerr = dispTable('iir', ttl, i=cat(PACK(ki,m),PACK(kj,m)), r=cat(PACK(a(ib:ie),m)), & - rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=nHd, unit=unt, sub=sub) - CALL msg("can't display outliers table", sub, lerr, unt) - IF(lerr) RETURN - END DO -END FUNCTION dispOutliers_1 -!============================================================================================================================== -LOGICAL FUNCTION dispOutliers_2(ll, a, n, err_msg, nam, subn, nRowMax, nColMax, nHead, unit) RESULT(lerr) - IMPLICIT NONE -! Display outliers list in tables -! If "nam" is supplied and, 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 arrays of values stacked along 2nd dim. - INTEGER, INTENT(IN) :: n(:) !--- Profile before linearization - CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: err_msg, nam(:), subn !--- 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) :: nHead !--- Number of front columns to duplicate (default: 1) - INTEGER, OPTIONAL, INTENT(IN) :: unit !--- Output unit (def: lunout) -!------------------------------------------------------------------------------------------------------------------------------ - CHARACTER(LEN=maxlen) :: mes, sub, fm='(f12.9)', prf - CHARACTER(LEN=maxlen), ALLOCATABLE :: ttl(:), vnm(:) - INTEGER, ALLOCATABLE :: ki(:), kj(:), kl(:) - INTEGER :: i, j, k, rk, nv, unt, nRmx, nCmx, nHd - REAL, ALLOCATABLE :: val(:,:) - - lerr = ANY(ll); IF(.NOT.lerr) RETURN !--- No outliers -> finished - rk = SIZE(n); nv = SIZE(a,2) - mes = 'outliers found'; IF(PRESENT(err_msg)) mes = err_msg !--- Error message - vnm = [(ACHAR(k+96),k=1,nv)]; IF(PRESENT(nam )) vnm = nam !--- Variables names - sub = 'dispOutliers'; IF(PRESENT(subn)) sub = subn !--- 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 - nHd = 1; IF(PRESENT(nHead)) nHd = nHead !--- Number of front columns to duplicate - unt = lunout; IF(PRESENT(unit)) unt = unit !--- Unit to print messages - lerr= SIZE(vnm) /= nv; CALL msg('SIZE(nam) /= SIZE(a,2)', sub, lerr, unt); IF(lerr) RETURN - lerr= SIZE(a,1) /= SIZE(ll); CALL msg('"ll" and "a" sizes mismatch', sub, lerr, unt); IF(lerr) RETURN - lerr= SIZE(a,1) /= PRODUCT(n); CALL msg('profile "n" does not match "a" and "ll"', sub, lerr, unt); IF(lerr) RETURN - - SELECT CASE(rk) !--- Indices list - CASE(0); IF(ll(1)) THEN; WRITE(unt,'(a,", ",a," = ",2f12.9)')TRIM(vnm(1)),TRIM(vnm(2)),a(1,1),a(1,2); RETURN; END IF - CASE(1); ki = [ (i,i=1,n(1)) ] - CASE(2); ki = [ ((i,i=1,n(1)),j=1,n(2))]; kj = [ ((j,i=1,n(1)),j=1,n(2))] - CASE(3); ki = [(((i,i=1,n(1)),j=1,n(2)),k=1,n(3))]; kj = [(((j,i=1,n(1)),j=1,n(2)),k=1,n(3))] - kl = [(((k,i=1,n(1)),j=1,n(2)),k=1,n(3))] - CASE DEFAULT; WRITE(unt,*)'Sorry: routine "dispOutliers_2" is limited to rank 3'; RETURN - END SELECT - - ttl = [(ACHAR(k), k = 105, 104+rk), vnm] !--- Titles list ('i', 'j', 'k'...'var1', 'var2', ...) - prf = REPEAT('i',rk)//REPEAT('r',nv) !--- Profile - ALLOCATE(val(COUNT(ll),nv)); DO k=1, nv; val(:,k) = PACK(a(:,k),ll); END DO - IF(rk == 1) lerr = dispTable(prf, ttl, i = cat(PACK(ki,ll)), r = val, & - rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=nHd, unit=unt, sub=sub) - IF(rk == 2) lerr = dispTable(prf, ttl, i = cat(PACK(ki,ll),PACK(kj,ll)), r = val, & - rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=nHd, unit=unt, sub=sub) - IF(rk == 3) lerr = dispTable(prf, ttl, i = cat(PACK(ki,ll),PACK(kj,ll),PACK(kl,ll)), r = val, & - rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=nHd, unit=unt, sub=sub) - CALL msg("can't display outliers table", sub, lerr, unt) -END FUNCTION dispOutliers_2 -!============================================================================================================================== - - -!============================================================================================================================== !=== Reduce an algebrical expression (basic operations and parenthesis) to a single number (string format) ==================== !==============================================================================================================================