MODULE strings_mod USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: REAL64, REAL32 IMPLICIT NONE PRIVATE PUBLIC :: maxlen, init_printout, msg, get_in, lunout, prt_level, maxTableWidth PUBLIC :: strLower, strHead, strStack, strCount, strReduce, strClean, strIdx PUBLIC :: strUpper, strTail, strStackm, strParse, strReplace, strFind, find, duplicate, cat PUBLIC :: dispTable, dispOutliers, dispNameList PUBLIC :: is_numeric, num2str, str2bool, str2int, str2real, str2dble PUBLIC :: reduceExpr, addQuotes, checkList, removeComment INTERFACE get_in; MODULE PROCEDURE getin_s, getin_i, getin_r, getin_l; END INTERFACE get_in INTERFACE num2str; MODULE PROCEDURE bool2str, int2str, real2str, dble2str; END INTERFACE num2str INTERFACE msg; MODULE PROCEDURE msg_1, msg_m; END INTERFACE msg INTERFACE strHead; MODULE PROCEDURE strHead_1, strHead_m; END INTERFACE strHead INTERFACE strTail; MODULE PROCEDURE strTail_1, strTail_m; END INTERFACE strTail INTERFACE strClean; MODULE PROCEDURE strClean_1, strClean_m; END INTERFACE strClean INTERFACE strReduce; MODULE PROCEDURE strReduce_1, strReduce_2; END INTERFACE strReduce INTERFACE strIdx; MODULE PROCEDURE strIdx_1, strIdx_m; END INTERFACE strIdx INTERFACE strCount; MODULE PROCEDURE strCount_m1, strCount_11, strCount_1m; END INTERFACE strCount INTERFACE strReplace; MODULE PROCEDURE strReplace_1, strReplace_m; END INTERFACE strReplace INTERFACE cat; MODULE PROCEDURE horzcat_s00, horzcat_i00, horzcat_r00, horzcat_d00, horzcat_l00, & horzcat_s10, horzcat_i10, horzcat_r10, horzcat_d10, horzcat_l10, & horzcat_s11, horzcat_i11, horzcat_r11, horzcat_d11, horzcat_l11, & horzcat_s21, horzcat_i21, horzcat_r21, horzcat_d21, horzcat_l21, & horzcat_s22, horzcat_i22, horzcat_r22, horzcat_d22, horzcat_l22; END INTERFACE cat INTERFACE strFind; MODULE PROCEDURE strFind_1, strFind_m; END INTERFACE strFind INTERFACE find; MODULE PROCEDURE strFind_1, strFind_m, intFind_1, intFind_m, booFind; END INTERFACE find INTERFACE duplicate; MODULE PROCEDURE dupl_s, dupl_i, dupl_r, dupl_l; END INTERFACE duplicate INTERFACE dispTable; MODULE PROCEDURE dispTable_1, dispTable_2; END INTERFACE dispTable INTERFACE dispOutliers; MODULE PROCEDURE dispOutliers_1, dispOutliers_2; END INTERFACE dispOutliers INTERFACE reduceExpr; MODULE PROCEDURE reduceExpr_1, reduceExpr_m; END INTERFACE reduceExpr INTERFACE addQuotes; MODULE PROCEDURE addQuotes_1, addQuotes_m; END INTERFACE addQuotes INTEGER, PARAMETER :: maxlen = 256 !--- Standard maximum length for strings INTEGER, SAVE :: lunout = 6 !--- Printing unit (default: 6, ie. on screen) INTEGER, SAVE :: prt_level = 1 !--- Printing level (default: 1, ie. print all) INTEGER, SAVE :: maxTableWidth = 192 !--- Default max. number of characters per lines in dispTable CONTAINS !============================================================================================================================== SUBROUTINE init_printout(lunout_, prt_level_) IMPLICIT NONE INTEGER, INTENT(IN) :: lunout_, prt_level_ lunout = lunout_ prt_level = prt_level_ END SUBROUTINE init_printout !============================================================================================================================== !============================================================================================================================== !=== Same as getin ; additional last argument: the default value. !============================================================================================================================== SUBROUTINE getin_s(nam, val, def) USE ioipsl, ONLY: getin IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: nam CHARACTER(LEN=*), INTENT(INOUT) :: val CHARACTER(LEN=*), INTENT(IN) :: def val = def; CALL getin(nam, val) IF(val/=def) WRITE(lunout,*)TRIM(nam)//' = '//TRIM(val) END SUBROUTINE getin_s !============================================================================================================================== SUBROUTINE getin_i(nam, val, def) USE ioipsl, ONLY: getin IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: nam INTEGER, INTENT(INOUT) :: val INTEGER, INTENT(IN) :: def val = def; CALL getin(nam, val) IF(val/=def) WRITE(lunout,*)TRIM(nam)//' = '//TRIM(num2str(val)) END SUBROUTINE getin_i !============================================================================================================================== SUBROUTINE getin_r(nam, val, def) USE ioipsl, ONLY: getin IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: nam REAL, INTENT(INOUT) :: val REAL, INTENT(IN) :: def val = def; CALL getin(nam, val) IF(val/=def) WRITE(lunout,*)TRIM(nam)//' = '//TRIM(num2str(val)) END SUBROUTINE getin_r !============================================================================================================================== SUBROUTINE getin_l(nam, val, def) USE ioipsl, ONLY: getin IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: nam LOGICAL, INTENT(INOUT) :: val LOGICAL, INTENT(IN) :: def val = def; CALL getin(nam, val) IF(val.NEQV.def) WRITE(lunout,*)TRIM(nam)//' = '//TRIM(num2str(val)) END SUBROUTINE getin_l !============================================================================================================================== !============================================================================================================================== !=== Display one or several messages, one each line, starting with the current routine name "modname". !============================================================================================================================== SUBROUTINE msg_1(str, modname, ll, unit) IMPLICIT NONE !--- Display a simple message "str". Optional parameters: ! * "modname": module name, displayed in front of the message (with ": " separator) if present. ! * "ll": message trigger ; message is displayed only if ll==.TRUE. ! * "unit": write unit (by default: "lunout") CHARACTER(LEN=*), INTENT(IN) :: str CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: modname LOGICAL, OPTIONAL, INTENT(IN) :: ll INTEGER, OPTIONAL, INTENT(IN) :: unit !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=maxlen) :: subn INTEGER :: unt subn = ''; IF(PRESENT(modname)) subn = modname IF(PRESENT(ll)) THEN; IF(.NOT.ll) RETURN; END IF unt = lunout; IF(PRESENT(unit)) unt = unit IF(subn == '') WRITE(unt,'(a)') str !--- Simple message IF(subn /= '') WRITE(unt,'(a)') TRIM(subn)//': '//str !--- Routine name provided END SUBROUTINE msg_1 !============================================================================================================================== SUBROUTINE msg_m(str, modname, ll, unit, nmax) IMPLICIT NONE !--- Same as msg_1 with multiple strings that are stacked (separator: coma) on up to "nmax" full lines. CHARACTER(LEN=*), INTENT(IN) :: str(:) CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: modname LOGICAL, OPTIONAL, INTENT(IN) :: ll INTEGER, OPTIONAL, INTENT(IN) :: unit INTEGER, OPTIONAL, INTENT(IN) :: nmax !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=maxlen), ALLOCATABLE :: s(:) CHARACTER(LEN=maxlen) :: subn INTEGER :: unt, nmx, k LOGICAL :: l subn = ''; IF(PRESENT(modname)) subn = modname l = .TRUE.; IF(PRESENT(ll)) l = ll unt = lunout; IF(PRESENT(unit)) unt = unit nmx = 128; IF(PRESENT(nmax)) nmx = nmax s = strStackm(str, ', ', nmx) DO k=1,SIZE(s); CALL msg_1(s(k), subn, l, unt); END DO END SUBROUTINE msg_m !============================================================================================================================== !============================================================================================================================== !=== Lower/upper case conversion function. ==================================================================================== !============================================================================================================================== ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION strLower(str) RESULT(out) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: str INTEGER :: k out = str DO k=1,LEN_TRIM(str) IF(str(k:k)>='A' .AND. str(k:k)<='Z') out(k:k)=ACHAR(IACHAR(str(k:k))+32) END DO END FUNCTION strLower !============================================================================================================================== ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION strUpper(str) RESULT(out) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: str INTEGER :: k out = str DO k=1,LEN_TRIM(str) IF(str(k:k)>='a' .AND. str(k:k)<='z') out(k:k)=ACHAR(IACHAR(str(k:k))-32) END DO END FUNCTION strUpper !============================================================================================================================== !============================================================================================================================== !=== Extract the substring in front of the first (last if lBackward==TRUE) occurrence of "sep" in "str" ================ !=== Examples for str='a_b_c' and sep='_' and the bash command with the same effect: ================ !=== * strHead(..,.FALSE.) = 'a' ${str%%$sep*} ================ !=== * strHead(..,.TRUE.) = 'a_b' ${str%$sep*} ================ !============================================================================================================================== CHARACTER(LEN=maxlen) FUNCTION strHead_1(str, sep, lBackward) RESULT(out) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: str CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sep LOGICAL, OPTIONAL, INTENT(IN) :: lBackward !------------------------------------------------------------------------------------------------------------------------------ IF(PRESENT(sep)) THEN IF( PRESENT(lBackWard)) out = str(1:INDEX(str,sep,lBackWard)-1) IF(.NOT.PRESENT(lBackWard)) out = str(1:INDEX(str,sep)-1) ELSE IF( PRESENT(lBackWard)) out = str(1:INDEX(str,'/',lBackWard)-1) IF(.NOT.PRESENT(lBackWard)) out = str(1:INDEX(str,'/')-1) END IF IF(out == '') out = str END FUNCTION strHead_1 !============================================================================================================================== FUNCTION strHead_m(str, sep, lBackward) RESULT(out) IMPLICIT NONE CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:) CHARACTER(LEN=*), INTENT(IN) :: str(:) CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sep LOGICAL, OPTIONAL, INTENT(IN) :: lBackward !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: k IF(PRESENT(sep)) THEN IF( PRESENT(lBackWard)) out = [(strHead_1(str(k), sep, lBackWard), k=1, SIZE(str))] IF(.NOT.PRESENT(lBackWard)) out = [(strHead_1(str(k), sep), k=1, SIZE(str))] ELSE IF( PRESENT(lBackWard)) out = [(strHead_1(str(k), '/', lBackWard), k=1, SIZE(str))] IF(.NOT.PRESENT(lBackWard)) out = [(strHead_1(str(k), '/'), k=1, SIZE(str))] END IF END FUNCTION strHead_m !============================================================================================================================== !=== Extract the substring following the first (last if lBackward==TRUE) occurrence of "sep" in "str" ================ !=== Examples for str='a_b_c' and sep='_' and the bash command with the same effect: ================ !=== * strTail(str, '_', .FALSE.) = 'b_c' ${str#*$sep} ================ !=== * strTail(str, '_', .TRUE.) = 'c' ${str##*$sep} ================ !============================================================================================================================== CHARACTER(LEN=maxlen) FUNCTION strTail_1(str, sep, lBackWard) RESULT(out) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: str CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sep LOGICAL, OPTIONAL, INTENT(IN) :: lBackWard !------------------------------------------------------------------------------------------------------------------------------ IF(PRESENT(sep)) THEN IF( PRESENT(lBackWard)) out = str(INDEX(str,sep,lBackWard)+LEN(sep):LEN_TRIM(str)) IF(.NOT.PRESENT(lBackWard)) out = str(INDEX(str,sep) +LEN(sep):LEN_TRIM(str)) ELSE IF( PRESENT(lBackWard)) out = str(INDEX(str,'/',lBackWard)+1:LEN_TRIM(str)) IF(.NOT.PRESENT(lBackWard)) out = str(INDEX(str,'/') +1:LEN_TRIM(str)) END IF IF(out == '') out = str END FUNCTION strTail_1 !============================================================================================================================== FUNCTION strTail_m(str, sep, lBackWard) RESULT(out) IMPLICIT NONE CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:) CHARACTER(LEN=*), INTENT(IN) :: str(:) CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sep LOGICAL, OPTIONAL, INTENT(IN) :: lBackWard !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: k IF(PRESENT(sep)) THEN IF( PRESENT(lBackWard)) out = [(strTail_1(str(k), sep, lBackWard), k=1, SIZE(str))] IF(.NOT.PRESENT(lBackWard)) out = [(strTail_1(str(k), sep), k=1, SIZE(str))] ELSE IF( PRESENT(lBackWard)) out = [(strTail_1(str(k), '/', lBackWard), k=1, SIZE(str))] IF(.NOT.PRESENT(lBackWard)) out = [(strTail_1(str(k), '/'), k=1, SIZE(str))] END IF END FUNCTION strTail_m !============================================================================================================================== !============================================================================================================================== !=== Concatenates the strings "str(:)" with separator "sep" into a single string using a separator (',' by default). ========== !============================================================================================================================== FUNCTION strStack(str, sep, mask) RESULT(out) IMPLICIT NONE CHARACTER(LEN=:), ALLOCATABLE :: out CHARACTER(LEN=*), INTENT(IN) :: str(:) CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sep LOGICAL, OPTIONAL, INTENT(IN) :: mask(:) !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=:), ALLOCATABLE :: s INTEGER :: is, i0 IF(SIZE(str) == 0) THEN; out = ''; RETURN; END IF ALLOCATE(s, SOURCE=', '); IF(PRESENT(sep)) s=sep IF(PRESENT(mask)) THEN IF(ALL(.NOT.mask)) THEN; out = ''; RETURN; END IF i0 = 0; DO WHILE(.NOT.mask(i0+1)); i0 = i0+1; END DO out = str(i0); DO is=i0+1,SIZE(str, DIM=1); IF(.NOT.mask(is)) CYCLE; out = TRIM(out)//s//TRIM(str(is)); END DO ELSE out = str(1); DO is=2,SIZE(str, DIM=1); out = TRIM(out)//s//TRIM(str(is)); END DO END IF END FUNCTION strStack !============================================================================================================================== !=== Concatenate the strings "str(:)" with separator "sep" into one or several lines of "nmax" characters max (for display) === !============================================================================================================================== FUNCTION strStackm(str, sep, nmax) RESULT(out) IMPLICIT NONE CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:) CHARACTER(LEN=*), INTENT(IN) :: str(:) CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sep INTEGER, OPTIONAL, INTENT(IN) :: nmax !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=maxlen), ALLOCATABLE :: t(:) CHARACTER(LEN=maxlen) :: sp INTEGER :: is, ns, no, mx, n IF(SIZE(str) == 0) THEN; out = ['']; RETURN; END IF sp =', '; IF(PRESENT(sep )) sp = sep ns = 2 ; IF(PRESENT(sep )) ns = LEN(sep) mx = 256; IF(PRESENT(nmax)) mx = nmax no = 1; out = [''] DO is = 1, SIZE(str) n = LEN_TRIM(str(is)); IF(out(no)/='') n = n+ns+LEN_TRIM(out(no)) !--- Line length after "str(is)" inclusion IF(out(no) == '') THEN out(no) = str(is) !--- Empty new line: set to "str(is)" ELSE IF(n <= mx) THEN out(no) = TRIM(out(no))//sp(1:ns)//TRIM(str(is)) !--- Append "str(is)" to the current line ELSE ALLOCATE(t(no+1)); t(1:no) = out; no=no+1; t(no) = str(is) !--- Full line: "str(si)" put in next line CALL MOVE_ALLOC(FROM=t, TO=out) END IF END DO END FUNCTION strStackm !============================================================================================================================== !============================================================================================================================== !=== String cleaning: replace tabulation by spaces, remove NULL characters and comments. ====================================== !============================================================================================================================== SUBROUTINE strClean_1(str) IMPLICIT NONE CHARACTER(LEN=*), INTENT(INOUT) :: str INTEGER :: k, n, m n = LEN(str) DO k = n, 1, -1 m = IACHAR(str(k:k)) IF(m==9) str(k:k) = ' ' !--- Replace the tabulations with spaces IF(m==0) str(k:n) = str(k+1:n)//' ' !--- Remove the NULL characters END DO m = INDEX(str,'!')-1; IF(m==-1) m = LEN_TRIM(str) !--- Remove end of line comment str = ADJUSTL(str(1:m)) END SUBROUTINE strClean_1 !============================================================================================================================== SUBROUTINE strClean_m(str) IMPLICIT NONE CHARACTER(LEN=*), INTENT(INOUT) :: str(:) INTEGER :: k DO k = 1, SIZE(str); CALL strClean_1(str(k)); END DO END SUBROUTINE strClean_m !============================================================================================================================== !============================================================================================================================== !=== strReduce_1(str1) : Remove duplicated elements of str1. =========================================================== !=== strReduce_2(str1,str2): Append str1 with new elements of str2. =========================================================== !============================================================================================================================== SUBROUTINE strReduce_1(str, nb) IMPLICIT NONE CHARACTER(LEN=*), ALLOCATABLE, INTENT(INOUT) :: str(:) INTEGER, OPTIONAL, INTENT(OUT) :: nb !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=maxlen), ALLOCATABLE :: s1(:) INTEGER :: k, n, n1 IF(PRESENT(nb)) nb = 0 CALL MOVE_ALLOC(FROM=str, TO=s1); CALL strClean(s1) n1 = SIZE(s1, DIM=1) !--- Total nb. of elements in "s1" n = COUNT( [( ALL(s1(1:k-1)/=s1(k)), k=1, n1 )] ) !--- Nb of unique elements in "s1" ALLOCATE(str(n)) IF(n==0) RETURN str(1) = s1(1) n=1; DO k=2,n1; IF(ANY(s1(1:k-1)==s1(k))) CYCLE; n=n+1; str(n)=s1(k); END DO IF(PRESENT(nb)) nb=n END SUBROUTINE strReduce_1 !============================================================================================================================== SUBROUTINE strReduce_2(str1, str2) IMPLICIT NONE CHARACTER(LEN=*), ALLOCATABLE, INTENT(INOUT) :: str1(:) CHARACTER(LEN=*), INTENT(IN) :: str2(:) !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=maxlen), ALLOCATABLE :: s1(:), s2(:) INTEGER :: k IF(SIZE(str2)==0) RETURN s2 = str2; CALL strClean(s2) IF(.NOT.ALLOCATED(s2)) RETURN IF(SIZE(s2) == 0) THEN; DEALLOCATE(s2); RETURN; END IF IF(.NOT.ALLOCATED(str1)) THEN str1 = s2 ELSE IF(SIZE(str1)==0) THEN str1 = s2 ELSE s1 = str1; CALL strClean(s1) str1 = [s1, PACK(s2, MASK= [( ALL(s1(:) /= s2(k)), k=1, SIZE(s2) )] ) ] END IF END SUBROUTINE strReduce_2 !============================================================================================================================== !============================================================================================================================== !=== GET THE INDEX OF THE FIRST APPEARANCE IN THE STRING VECTOR "str(:)" OF THE STRING(s) "s[(:)]" ============================ !=== OPTIONALY: GET THE NUMBER OF FOUND ELEMENTS "n". NB: UNFOUND => INDEX=0 ============================ !============================================================================================================================== INTEGER FUNCTION strIdx_1(str, s) RESULT(out) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: str(:), s DO out = 1, SIZE(str); IF(str(out) == s) EXIT; END DO IF(out == 1+SIZE(str) .OR. SIZE(str)==0) out = 0 END FUNCTION strIdx_1 !============================================================================================================================== FUNCTION strIdx_m(str, s, n) RESULT(out) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: str(:), s(:) INTEGER, OPTIONAL, INTENT(OUT) :: n INTEGER, ALLOCATABLE :: out(:) !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: k out = [(strIdx_1(str(:), s(k)), k=1, SIZE(s))] IF(PRESENT(n)) n = COUNT(out(:)/=0) END FUNCTION strIdx_m !============================================================================================================================== !============================================================================================================================== !=== GET THE INDEX LIST OF THE ELEMENTS OF "str(:)" EQUAL TO "s" AND OPTIONALY, ITS LENGTH "n" ================================ !============================================================================================================================== FUNCTION strFind_1(str, s, n) RESULT(out) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: str(:), s INTEGER, OPTIONAL, INTENT(OUT) :: n INTEGER, ALLOCATABLE :: out(:) !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: k out = PACK( [(k, k=1, SIZE(str(:), DIM=1))], MASK = str(:) == s ) IF(PRESENT(n)) n = SIZE(out(:), DIM=1) END FUNCTION strFind_1 !============================================================================================================================== FUNCTION strFind_m(str, s, n) RESULT(out) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: str(:), s(:) INTEGER, OPTIONAL, INTENT(OUT) :: n INTEGER, ALLOCATABLE :: out(:) !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: k out = [(strFind_1(str, s(k)), k=1, SIZE(s))] IF(PRESENT(n)) n = SIZE(out(:), DIM=1) END FUNCTION strFind_m !============================================================================================================================== FUNCTION intFind_1(i,j,n) RESULT(out) IMPLICIT NONE INTEGER, INTENT(IN) :: i(:), j INTEGER, OPTIONAL, INTENT(OUT) :: n INTEGER, ALLOCATABLE :: out(:) !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: k out = PACK( [(k, k=1, SIZE(i(:), DIM=1))], MASK = i(:) == j ) IF(PRESENT(n)) n = SIZE(out(:), DIM=1) END FUNCTION intFind_1 !============================================================================================================================== FUNCTION intFind_m(i,j,n) RESULT(out) IMPLICIT NONE INTEGER, INTENT(IN) :: i(:), j(:) INTEGER, OPTIONAL, INTENT(OUT) :: n INTEGER, ALLOCATABLE :: out(:) !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: k out = [(intFind_1(i, j(k)), k=1, SIZE(j))] IF(PRESENT(n)) n = SIZE(out(:), DIM=1) END FUNCTION intFind_m !============================================================================================================================== FUNCTION booFind(l,n) RESULT(out) IMPLICIT NONE LOGICAL, INTENT(IN) :: l(:) INTEGER, OPTIONAL, INTENT(OUT) :: n INTEGER, ALLOCATABLE :: out(:) !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: k out = PACK( [(k, k=1, SIZE(l(:), DIM=1))], MASK = l(:) ) IF(PRESENT(n)) n = SIZE(out(:), DIM=1) END FUNCTION booFind !============================================================================================================================== !============================================================================================================================== !=== DUPLICATE A VECTOR "v(:)" "n" times ====================================================================================== !============================================================================================================================== SUBROUTINE dupl_s(v, n, vdup) CHARACTER(LEN=*), INTENT(IN) :: v(:) INTEGER, INTENT(IN) :: n CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: vdup(:) !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: nv, i nv = SIZE(v) ALLOCATE(vdup(n*nv)) DO i = 1, n; vdup(1+(i-1)*nv:i*nv) = v; END DO END SUBROUTINE dupl_s !============================================================================================================================== SUBROUTINE dupl_i(v, n, vdup) INTEGER, INTENT(IN) :: v(:) INTEGER, INTENT(IN) :: n INTEGER, ALLOCATABLE, INTENT(OUT) :: vdup(:) !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: nv, i nv = SIZE(v) ALLOCATE(vdup(n*nv)) DO i = 1, n; vdup(1+(i-1)*nv:i*nv) = v; END DO END SUBROUTINE dupl_i !============================================================================================================================== SUBROUTINE dupl_r(v, n, vdup) REAL, INTENT(IN) :: v(:) INTEGER, INTENT(IN) :: n REAL, ALLOCATABLE, INTENT(OUT) :: vdup(:) !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: nv, i nv = SIZE(v) ALLOCATE(vdup(n*nv)) DO i = 1, n; vdup(1+(i-1)*nv:i*nv) = v; END DO END SUBROUTINE dupl_r !============================================================================================================================== SUBROUTINE dupl_l(v, n, vdup) LOGICAL, INTENT(IN) :: v(:) INTEGER, INTENT(IN) :: n LOGICAL, ALLOCATABLE, INTENT(OUT) :: vdup(:) !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: nv, i nv = SIZE(v) ALLOCATE(vdup(n*nv)) DO i = 1, n; vdup(1+(i-1)*nv:i*nv) = v; END DO END SUBROUTINE dupl_l !============================================================================================================================== !============================================================================================================================== !=== GET THE INDEX IN "rawList" OF THE 1ST APPEARANCE OF ONE OF THE "del(:)" SEPARATORS (0 IF NONE OF THEM ARE PRESENT) !=== IF lSc == .TRUE.: * SKIP HEAD SIGNS OR EXPONENTS SIGNS THAT SHOULD NOT BE CONFUSED WITH SEPARATORS !=== * THEN TEST WHETHER THE STRING FROM START TO THE FOUND SEPARATOR IS A CORRECTLY FORMATTED NUMBER !============================================================================================================================== LOGICAL FUNCTION strIdx_prv(rawList, del, ibeg, idx, idel, lSc) RESULT(lerr) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: rawList !--- String in which delimiters have to be identified CHARACTER(LEN=*), INTENT(IN) :: del(:) !--- List of delimiters INTEGER, INTENT(IN) :: ibeg !--- Start index INTEGER, INTENT(OUT) :: idx !--- Index of the first identified delimiter in "rawList" INTEGER, INTENT(OUT) :: idel !--- Index of the identified delimiter (0 if idx==0) LOGICAL, OPTIONAL, INTENT(IN) :: lSc !--- Care about nbs with front sign or in scient. notation !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: idx0 !--- Used to display an identified non-numeric string lerr = .FALSE. idx = strIdx1(rawList, del, ibeg, idel) !--- idx/=0: del(idel) is at position "idx" in "rawList" IF(.NOT.PRESENT(lSc)) RETURN !--- No need to check exceptions for numbers => finished IF(.NOT. lSc ) RETURN !--- No need to check exceptions for numbers => finished !=== No delimiter found: the whole string must be a valid number IF(idx == 0) THEN !--- No element of "del" in "rawList" lerr = .NOT.is_numeric(rawList(ibeg:LEN_TRIM(rawList))) !--- String must be a number IF(lerr) idx = LEN_TRIM(rawList); RETURN !--- Set idx so that rawList(ibeg:idx-1) = whole string END IF lerr = idx == 1 .AND. INDEX('+-',del(idel)) /= 0; IF(lerr) RETURN !--- The front delimiter is different from +/-: error IF( idx /= 1 .AND. is_numeric(rawList(ibeg:idx-1))) RETURN !--- The input string head is a valid number !=== The string part in front of the 1st delimiter is not a valid number: search for next delimiter index "idx" idx0 = idx ; idx = strIdx1(rawList, del, idx+1, idel) !--- Keep start index because idx is recycled IF(idx == 0) THEN lerr = .NOT.is_numeric(rawList(ibeg:LEN_TRIM(rawList))) !--- No other delimiter: whole string must be a valid numb IF(lerr) idx = idx0; RETURN END IF lerr = .NOT.is_numeric(rawList(ibeg:idx-1)) CONTAINS !------------------------------------------------------------------------------------------------------------------------------ INTEGER FUNCTION strIdx1(str, del, ib, id) RESULT(i) !--- Get the index of the first appereance of one of the delimiters "del(:)" in "str" starting from position "ib". !--- "id" is the index in "del(:)" of the first delimiter found. IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: str, del(:) INTEGER, INTENT(IN) :: ib INTEGER, INTENT(OUT) :: id !------------------------------------------------------------------------------------------------------------------------------ DO i = ib, LEN_TRIM(str); id = strIdx(del, str(i:i)); IF(id /= 0) EXIT; END DO IF(i > LEN_TRIM(str)) THEN; i = 0; id = 0; END IF END FUNCTION strIdx1 END FUNCTION strIdx_prv !============================================================================================================================== !============================================================================================================================== !=== Count the number of elements separated by "delimiter" in list "rawList". ================================================= !============================================================================================================================== LOGICAL FUNCTION strCount_11(rawList, delimiter, nb, lSc) RESULT(lerr) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: rawList CHARACTER(LEN=*), INTENT(IN) :: delimiter INTEGER, INTENT(OUT) :: nb LOGICAL, OPTIONAL, INTENT(IN) :: lSc !------------------------------------------------------------------------------------------------------------------------------ LOGICAL :: ll ll = .FALSE.; IF(PRESENT(lSc)) ll = lSc lerr = strCount_1m(rawList, [delimiter], nb, ll) END FUNCTION strCount_11 !============================================================================================================================== LOGICAL FUNCTION strCount_m1(rawList, delimiter, nb, lSc) RESULT(lerr) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: rawList(:) CHARACTER(LEN=*), INTENT(IN) :: delimiter INTEGER, ALLOCATABLE, INTENT(OUT) :: nb(:) LOGICAL, OPTIONAL, INTENT(IN) :: lSc !------------------------------------------------------------------------------------------------------------------------------ LOGICAL :: ll INTEGER :: id ll = .FALSE.; IF(PRESENT(lSc)) ll = lSc .AND. INDEX('+-', delimiter) /= 0 lerr = .TRUE. ALLOCATE(nb(SIZE(rawList))) DO id = 1, SIZE(rawList) lerr = lerr .AND. strCount_1m(rawList(id), [delimiter], nb(id), ll) END DO END FUNCTION strCount_m1 !============================================================================================================================== LOGICAL FUNCTION strCount_1m(rawList, delimiter, nb, lSc) RESULT(lerr) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: rawList CHARACTER(LEN=*), INTENT(IN) :: delimiter(:) INTEGER, INTENT(OUT) :: nb LOGICAL, OPTIONAL, INTENT(IN) :: lSc !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: ib, ie, jd, nr LOGICAL :: ll CHARACTER(LEN=1024) :: r lerr = .FALSE. ll = .FALSE.; IF(PRESENT(lSc)) ll = lSc r = TRIM(ADJUSTL(rawList)) nr = LEN_TRIM(r); IF(nr == 0) RETURN nb = 1; ib = 1 DO lerr = strIdx_prv(r, delimiter, ib, ie, jd, ll) CALL msg('"'//TRIM(r(ib:ie-1))//'" is not numeric', ll = lerr); IF(lerr) RETURN IF(ie == 0 .OR. jd == 0) EXIT ib = ie + LEN(delimiter(jd)) DO WHILE(r(ib:ib) == ' ' .AND. ib < nr); ib = ib + 1; END DO !--- Skip spaces before next chain nb = nb + 1 END DO END FUNCTION strCount_1m !============================================================================================================================== !============================================================================================================================== !=== Purpose: Parse "delimiter"-separated list "rawList" into the pair keys(:), vals(:). ==================================== !=== Corresponding "vals" remains empty if the element does not contain "=" sign. ==================================== !============================================================================================================================== LOGICAL FUNCTION strParse(rawList, delimiter, keys, n, vals) RESULT(lerr) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: rawList, delimiter CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: keys(:) INTEGER, OPTIONAL, INTENT(OUT) :: n CHARACTER(LEN=maxlen), ALLOCATABLE, OPTIONAL, INTENT(OUT) :: vals(:) !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=1024) :: r INTEGER :: nr, nk lerr = .FALSE. r = TRIM(ADJUSTL(rawList)) nr = LEN_TRIM(r); IF(nr == 0) THEN; keys = ['']; RETURN; END IF nk = countK() !--- COUNT THE ELEMENTS CALL parseK(keys) !--- PARSE THE KEYS IF(PRESENT(vals)) CALL parseV(vals) !--- PARSE = PAIRS IF(PRESENT(n)) n = nk !--- RETURN THE NUMBER OF KEYS CONTAINS !------------------------------------------------------------------------------------------------------------------------------ INTEGER FUNCTION countK() RESULT(nkeys) !--- Get the number of elements after parsing. IMPLICIT NONE !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: ib, ie, nl nkeys = 1; ib = 1; nl = LEN(delimiter) DO ie = INDEX(rawList(ib:nr), delimiter)+ib-1 !--- Determine the next separator start index IF(ie == ib-1) EXIT ib = ie + nl DO WHILE(ANY([0, 9, 32] == IACHAR(r(ib:ib))) .AND. ib < nr) !--- Skip blanks (ascii): NULL (0), TAB (9), SPACE (32) ib = ib + 1 END DO !--- Skip spaces before next chain nkeys = nkeys+1 END DO END FUNCTION countK !------------------------------------------------------------------------------------------------------------------------------ SUBROUTINE parseK(keys) !--- Parse the string separated by "delimiter" from "rawList" into "keys(:)" IMPLICIT NONE CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: keys(:) !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: ib, ie, ik ALLOCATE(keys(nk)) ib = 1 DO ik = 1, nk ie = INDEX(rawList(ib:nr), delimiter)+ib-1 !--- Determine the next separator start index IF(ie == ib-1) EXIT keys(ik) = r(ib:ie-1) !--- Get the ikth key ib = ie + LEN(delimiter) DO WHILE(r(ib:ib) == ' ' .AND. ib < nr); ib = ib + 1; END DO !--- Skip spaces before next chain END DO keys(ik) = r(ib:nr) !--- Get the last key END SUBROUTINE parseK !------------------------------------------------------------------------------------------------------------------------------ SUBROUTINE parseV(vals) !--- Parse the = pairs in "keys(:)" into "keys" and "vals" IMPLICIT NONE CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: vals(:) !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=maxlen) :: key INTEGER :: ik, ix ALLOCATE(vals(nk)) DO ik = 1, nk; key = keys(ik) vals(ik) = '' ix = INDEX(key, '='); IF(ix == 0) CYCLE !--- First "=" index in "key" vals(ik) = ADJUSTL(key(ix+1:LEN_TRIM(key))) keys(ik) = ADJUSTL(key(1:ix-1)) END DO END SUBROUTINE parseV END FUNCTION strParse !============================================================================================================================== LOGICAL FUNCTION strParse_m(rawList, delimiter, keys, n, vals, lSc, id) RESULT(lerr) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: rawList, delimiter(:) CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: keys(:) !--- Parsed keys vector INTEGER, OPTIONAL, INTENT(OUT) :: n !--- Length of the parsed vector CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: vals(:) !--- Values for = keys LOGICAL, OPTIONAL, INTENT(IN) :: lSc !--- Take care about numbers in scientific notation INTEGER, OPTIONAL, ALLOCATABLE, INTENT(OUT) :: id(:) !--- Indexes of the separators in "delimiter(:)" vector !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=1024) :: r INTEGER :: nr, ik, nk, ib, ie, jd LOGICAL :: ll ll = .FALSE.; IF(PRESENT(lSc)) ll = lSc lerr = strCount_1m(rawList, delimiter, nk, ll) CALL msg("Couldn't parse list: non-numerical strings were found", ll=lerr); IF(lerr) RETURN !--- FEW ALLOCATIONS ALLOCATE(keys(nk)) IF(PRESENT(vals)) ALLOCATE(vals(nk)) IF(PRESENT(id)) ALLOCATE(id(nk-1)) IF(PRESENT(n)) n = nk !--- PARSING r = TRIM(ADJUSTL(rawList)) nr = LEN_TRIM(r); IF(nr == 0) RETURN ib = 1 DO ik = 1, nk-1 lerr = strIdx_prv(r, delimiter, ib, ie, jd, ll) CALL msg('Non-numeric values found', ll=lerr); IF(lerr) RETURN keys(ik) = r(ib:ie-1) IF(PRESENT(vals)) CALL parseKeys(keys(ik), vals(ik)) !--- Parse a = pair IF(PRESENT(id )) id(ik) = jd !--- Index in "delimiter(:)" of the "ik"th delimiter ib = ie + LEN_TRIM( delimiter(jd) ) !--- Length of the current delimiter DO WHILE(r(ib:ib) == ' ' .AND. ib < nr); ib = ib + 1; END DO !--- Skip spaces before next chain END DO keys(nk) = r(ib:nr) IF(PRESENT(vals)) CALL parseKeys(keys(nk), vals(nk)) !--- Parse a = pair CONTAINS !------------------------------------------------------------------------------------------------------------------------------ SUBROUTINE parseKeys(key, val) IMPLICIT NONE CHARACTER(LEN=*), INTENT(INOUT) :: key CHARACTER(LEN=*), INTENT(OUT) :: val !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: ix ix = INDEX(key, '='); IF(ix == 0) RETURN !--- First "=" index in "key" val = ADJUSTL(key(ix+1:LEN_TRIM(key))) key = ADJUSTL(key(1:ix-1)) END SUBROUTINE parseKeys END FUNCTION strParse_m !============================================================================================================================== !============================================================================================================================== !=== String substitution: replace "key" by "val" each time it appears in "str". !============================================================================================================================== SUBROUTINE strReplace_1(str, key, val, lsurr) IMPLICIT NONE CHARACTER(LEN=*), INTENT(INOUT) :: str !--- Main string CHARACTER(LEN=*), INTENT(IN) :: key, val !--- "key" will be replaced by "val" LOGICAL, OPTIONAL, INTENT(IN) :: lsurr !--- TRUE => key must be surrounded by special characters to be substituted !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: i0, ix, nk, ns LOGICAL :: lsur, lb, le lsur = .FALSE.; IF(PRESENT(lsurr)) lsur = lsurr nk = LEN_TRIM(key) i0 = 1 DO ns = LEN_TRIM(str) ix = INDEX(str(i0:ns), TRIM(key)) !--- First appearance index of "key" in "s", starting from index "i0" IF(ix == 0) EXIT ix = ix + i0 -1 IF(lsur) THEN !--- Key must be surrounded by special characters !--- lb=.TRUE.: key is at the very beginning of "str" or located after a special character lb = ix ==1; IF(.NOT.lb) lb = INDEX('+-*/()^', str(ix-1 :ix-1 ))/=0 !--- le=.TRUE.: key is at the very end of "str" or located before a special character le = ix+nk-1==ns; IF(.NOT.le) le = INDEX('+-*/()^', str(ix+nk:ix+nk))/=0 IF(.NOT.(lb.AND.le)) THEN; i0 = i0 + nk; CYCLE; END IF END IF str = str(1:ix-1)//TRIM(val)//str(ix+nk:ns) END DO END SUBROUTINE strReplace_1 !============================================================================================================================== SUBROUTINE strReplace_m(str, key, val, lsurr) IMPLICIT NONE CHARACTER(LEN=*), INTENT(INOUT) :: str(:) !--- Main strings vector CHARACTER(LEN=*), INTENT(IN) :: key, val !--- "key" will be replaced by "val" LOGICAL, OPTIONAL, INTENT(IN) :: lsurr !--- TRUE => key must be surrounded by special characters to be substituted INTEGER :: k LOGICAL :: ll ll=.FALSE.; IF(PRESENT(lsurr)) ll=lsurr DO k=1, SIZE(str); CALL strReplace_1(str(k),key,val,ll); END DO END SUBROUTINE strReplace_m !============================================================================================================================== !============================================================================================================================== !=== Contatenate horizontally scalars/vectors of strings/integers/reals into a vector/array =================================== !============================================================================================================================== FUNCTION horzcat_s00(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: v0 CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: v1, v2, v3, v4, v5, v6, v7, v8, v9 CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:) INTEGER :: ncol, iv, i LOGICAL :: pre(9) !------------------------------------------------------------------------------------------------------------------------------ pre(:) = [PRESENT(v1),PRESENT(v2),PRESENT(v3),PRESENT(v4),PRESENT(v5),PRESENT(v6),PRESENT(v7),PRESENT(v8),PRESENT(v9)] ncol = 1+COUNT(pre) ALLOCATE(out(ncol)) out(1) = v0 i = 2 DO iv = i, ncol; IF(.NOT.pre(iv-1)) CYCLE SELECT CASE(iv-1) CASE(1); out(i) = v1; CASE(2); out(i) = v2; CASE(3); out(i) = v3; CASE(4); out(i) = v4; CASE(5); out(i) = v5 CASE(6); out(i) = v6; CASE(7); out(i) = v7; CASE(8); out(i) = v8; CASE(9); out(i) = v9 END SELECT i = i+1 END DO END FUNCTION horzcat_s00 !============================================================================================================================== FUNCTION horzcat_s10(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: v0(:), v1 CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: v2, v3, v4, v5, v6, v7, v8, v9 CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:), tmp(:) tmp = horzcat_s00(v1, v2, v3, v4, v5, v6, v7, v8, v9) out = [v0 , tmp] END FUNCTION horzcat_s10 !============================================================================================================================== FUNCTION horzcat_s11(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: v0(:) CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: v1(:), v2(:), v3(:), v4(:), v5(:), v6(:), v7(:), v8(:), v9(:) CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:,:) INTEGER :: nrow, ncol, iv, i LOGICAL :: pre(9) !------------------------------------------------------------------------------------------------------------------------------ pre(:) = [PRESENT(v1),PRESENT(v2),PRESENT(v3),PRESENT(v4),PRESENT(v5),PRESENT(v6),PRESENT(v7),PRESENT(v8),PRESENT(v9)] nrow = SIZE(v0) ncol = 1+COUNT(pre) IF(pre(1)) nrow = MAX(nrow,SIZE(v1)); IF(pre(2)) nrow = MAX(nrow,SIZE(v2)); IF(pre(3)) nrow = MAX(nrow,SIZE(v3)) IF(pre(4)) nrow = MAX(nrow,SIZE(v4)); IF(pre(5)) nrow = MAX(nrow,SIZE(v5)); IF(pre(6)) nrow = MAX(nrow,SIZE(v6)) IF(pre(7)) nrow = MAX(nrow,SIZE(v7)); IF(pre(8)) nrow = MAX(nrow,SIZE(v8)); IF(pre(9)) nrow = MAX(nrow,SIZE(v9)) ALLOCATE(out(nrow, ncol)); out(:,:) = '' out(1:SIZE(v0),1) = v0 i = 2 DO iv = i, ncol; IF(.NOT.pre(iv-1)) CYCLE SELECT CASE(iv-1) CASE(1); out(1:SIZE(v1),i) = v1; CASE(2); out(1:SIZE(v2),i) = v2; CASE(3); out(1:SIZE(v3),i) = v3 CASE(4); out(1:SIZE(v4),i) = v4; CASE(5); out(1:SIZE(v5),i) = v5; CASE(6); out(1:SIZE(v5),i) = v6 CASE(7); out(1:SIZE(v7),i) = v7; CASE(8); out(1:SIZE(v8),i) = v8; CASE(9); out(1:SIZE(v9),i) = v9 END SELECT i = i+1 END DO END FUNCTION horzcat_s11 !============================================================================================================================== FUNCTION horzcat_s21(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: v0(:,:), v1(:) CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: v2(:), v3(:), v4(:), v5(:), v6(:), v7(:), v8(:), v9(:) CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:,:), tmp(:,:) tmp = horzcat_s11(v1, v2, v3, v4, v5, v6, v7, v8, v9) out = horzcat_s22(v0, tmp) END FUNCTION horzcat_s21 !============================================================================================================================== FUNCTION horzcat_s22(v0, v1) RESULT(out) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: v0(:,:), v1(:,:) CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:,:), pk(:), tmp(:,:) INTEGER :: n0, n1, nrow n0 = SIZE(v0,1) n1 = SIZE(v1,1) nrow = MAX(n0, n1) IF(n0 == n1) THEN pk = PACK(v0, .TRUE.); pk = [pk, PACK(v1, .TRUE.)] ELSE IF(n0 /= nrow) THEN ALLOCATE(tmp(nrow,SIZE(v0,2))); tmp(:,:) = ''; tmp(1:n0,:) = v0(:,:); pk = PACK(tmp, .TRUE.); pk = [pk, PACK(v1, .TRUE.)] ELSE ALLOCATE(tmp(nrow,SIZE(v1,2))); tmp(:,:) = ''; tmp(1:n1,:) = v1(:,:); pk = PACK(tmp, .TRUE.); pk = [PACK(v0, .TRUE.), pk] END IF out = RESHAPE(pk, SHAPE=[nrow, SIZE(v0, 2) + SIZE(v1, 2)]) END FUNCTION horzcat_s22 !============================================================================================================================== FUNCTION horzcat_i00(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) IMPLICIT NONE INTEGER, INTENT(IN) :: v0 INTEGER, OPTIONAL, INTENT(IN) :: v1, v2, v3, v4, v5, v6, v7, v8, v9 INTEGER, ALLOCATABLE :: out(:) INTEGER :: ncol, iv, i LOGICAL :: pre(9) !------------------------------------------------------------------------------------------------------------------------------ pre(:) = [PRESENT(v1),PRESENT(v2),PRESENT(v3),PRESENT(v4),PRESENT(v5),PRESENT(v6),PRESENT(v7),PRESENT(v8),PRESENT(v9)] ncol = 1+COUNT(pre) ALLOCATE(out(ncol)) out(1) = v0 i = 2 DO iv = i, ncol; IF(.NOT.pre(iv-1)) CYCLE SELECT CASE(iv-1) CASE(1); out(i) = v1; CASE(2); out(i) = v2; CASE(3); out(i) = v3; CASE(4); out(i) = v4; CASE(5); out(i) = v5 CASE(6); out(i) = v6; CASE(7); out(i) = v7; CASE(8); out(i) = v8; CASE(9); out(i) = v9 END SELECT i = i+1 END DO END FUNCTION horzcat_i00 !============================================================================================================================== FUNCTION horzcat_i10(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) IMPLICIT NONE INTEGER, INTENT(IN) :: v0(:), v1 INTEGER, OPTIONAL, INTENT(IN) :: v2, v3, v4, v5, v6, v7, v8, v9 INTEGER, ALLOCATABLE :: out(:), tmp(:) tmp = horzcat_i00(v1, v2, v3, v4, v5, v6, v7, v8, v9) out = [v0, tmp] END FUNCTION horzcat_i10 !============================================================================================================================== FUNCTION horzcat_i11(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) IMPLICIT NONE INTEGER, INTENT(IN) :: v0(:) INTEGER, OPTIONAL, INTENT(IN) :: v1(:), v2(:), v3(:), v4(:), v5(:), v6(:), v7(:), v8(:), v9(:) INTEGER, ALLOCATABLE :: out(:,:) INTEGER :: siz(9), nrow, ncol, iv, i, n LOGICAL :: pre(9) !------------------------------------------------------------------------------------------------------------------------------ pre(:) = [PRESENT(v1),PRESENT(v2),PRESENT(v3),PRESENT(v4),PRESENT(v5),PRESENT(v6),PRESENT(v7),PRESENT(v8),PRESENT(v9)] nrow = SIZE(v0) ncol = 1+COUNT(pre) ALLOCATE(out(nrow, ncol)) out(:,1) = v0 i = 2 DO iv = i, ncol; IF(.NOT.pre(iv-1)) CYCLE SELECT CASE(iv-1) CASE(1); n = SIZE(v1); CASE(2); n = SIZE(v2); CASE(3); n = SIZE(v3); CASE(4); n = SIZE(v4); CASE(5); n = SIZE(v5) CASE(6); n = SIZE(v6); CASE(7); n = SIZE(v7); CASE(8); n = SIZE(v8); CASE(9); n = SIZE(v9) END SELECT IF(n /= nrow) THEN; CALL msg("Can't concatenate integer vectors of differing lengths"); STOP; END IF SELECT CASE(iv-1) CASE(1); out(:,i) = v1; CASE(2); out(:,i) = v2; CASE(3); out(:,i) = v3; CASE(4); out(:,i) = v4; CASE(5); out(:,i) = v5 CASE(6); out(:,i) = v6; CASE(7); out(:,i) = v7; CASE(8); out(:,i) = v8; CASE(9); out(:,i) = v9 END SELECT i = i+1 END DO END FUNCTION horzcat_i11 !============================================================================================================================== FUNCTION horzcat_i21(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) IMPLICIT NONE INTEGER, INTENT(IN) :: v0(:,:), v1(:) INTEGER, OPTIONAL, INTENT(IN) :: v2(:), v3(:), v4(:), v5(:), v6(:), v7(:), v8(:), v9(:) INTEGER, ALLOCATABLE :: out(:,:), tmp(:,:) tmp = horzcat_i11(v1, v2, v3, v4, v5, v6, v7, v8, v9) out = horzcat_i22(v0, tmp) END FUNCTION horzcat_i21 !============================================================================================================================== FUNCTION horzcat_i22(v0, v1) RESULT(out) IMPLICIT NONE INTEGER, INTENT(IN) :: v0(:,:), v1(:,:) INTEGER, ALLOCATABLE :: out(:,:), pk(:) INTEGER :: nrow, ncol nrow = SIZE(v0,1) ncol = SIZE(v0,2)+SIZE(v1,2) IF(nrow /= SIZE(v1,1)) THEN; CALL msg("Can't concatenate integer arrays of differing rows numbers"); STOP; END IF ALLOCATE(out(nrow, ncol)) pk = PACK(v0, .TRUE.) pk = [pk, PACK(v1, .TRUE.)] out = RESHAPE(pk, SHAPE=[nrow, ncol]) END FUNCTION horzcat_i22 !============================================================================================================================== FUNCTION horzcat_r00(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) IMPLICIT NONE REAL(KIND=REAL32), INTENT(IN) :: v0 REAL(KIND=REAL32), OPTIONAL, INTENT(IN) :: v1, v2, v3, v4, v5, v6, v7, v8, v9 REAL(KIND=REAL32), ALLOCATABLE :: out(:) INTEGER :: ncol, iv, i LOGICAL :: pre(9) !------------------------------------------------------------------------------------------------------------------------------ pre(:) = [PRESENT(v1),PRESENT(v2),PRESENT(v3),PRESENT(v4),PRESENT(v5),PRESENT(v6),PRESENT(v7),PRESENT(v8),PRESENT(v9)] ncol = 1+COUNT(pre) ALLOCATE(out(ncol)) out(1) = v0 i = 2 DO iv = i, ncol; IF(.NOT.pre(iv-1)) CYCLE SELECT CASE(iv-1) CASE(1); out(i) = v1; CASE(2); out(i) = v2; CASE(3); out(i) = v3; CASE(4); out(i) = v4; CASE(5); out(i) = v5 CASE(6); out(i) = v6; CASE(7); out(i) = v7; CASE(8); out(i) = v8; CASE(9); out(i) = v9 END SELECT i = i+1 END DO END FUNCTION horzcat_r00 !============================================================================================================================== FUNCTION horzcat_r10(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) IMPLICIT NONE REAL(KIND=REAL32), INTENT(IN) :: v0(:), v1 REAL(KIND=REAL32), OPTIONAL, INTENT(IN) :: v2, v3, v4, v5, v6, v7, v8, v9 REAL(KIND=REAL32), ALLOCATABLE :: out(:), tmp(:) tmp = horzcat_r00(v1, v2, v3, v4, v5, v6, v7, v8, v9) out = [v0 , tmp] END FUNCTION horzcat_r10 !============================================================================================================================== FUNCTION horzcat_r11(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) IMPLICIT NONE REAL(KIND=REAL32), INTENT(IN) :: v0(:) REAL(KIND=REAL32), OPTIONAL, INTENT(IN) :: v1(:), v2(:), v3(:), v4(:), v5(:), v6(:), v7(:), v8(:), v9(:) REAL(KIND=REAL32), ALLOCATABLE :: out(:,:) INTEGER :: siz(9), nrow, ncol, iv, i, n LOGICAL :: pre(9) !------------------------------------------------------------------------------------------------------------------------------ pre(:) = [PRESENT(v1),PRESENT(v2),PRESENT(v3),PRESENT(v4),PRESENT(v5),PRESENT(v6),PRESENT(v7),PRESENT(v8),PRESENT(v9)] nrow = SIZE(v0) ncol = 1+COUNT(pre) ALLOCATE(out(nrow, ncol)) out(:,1) = v0 i = 2 DO iv = i, ncol; IF(.NOT.pre(iv-1)) CYCLE SELECT CASE(iv-1) CASE(1); n = SIZE(v1); CASE(2); n = SIZE(v2); CASE(3); n = SIZE(v3); CASE(4); n = SIZE(v4); CASE(5); n = SIZE(v5) CASE(6); n = SIZE(v6); CASE(7); n = SIZE(v7); CASE(8); n = SIZE(v8); CASE(9); n = SIZE(v9) END SELECT IF(n /= nrow) THEN; CALL msg("Can't concatenate real vectors of differing lengths"); STOP; END IF SELECT CASE(iv-1) CASE(1); out(:,i) = v1; CASE(2); out(:,i) = v2; CASE(3); out(:,i) = v3; CASE(4); out(:,i) = v4; CASE(5); out(:,i) = v5 CASE(6); out(:,i) = v6; CASE(7); out(:,i) = v7; CASE(8); out(:,i) = v8; CASE(9); out(:,i) = v9 END SELECT i = i+1 END DO END FUNCTION horzcat_r11 !============================================================================================================================== FUNCTION horzcat_r21(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) IMPLICIT NONE REAL(KIND=REAL32), INTENT(IN) :: v0(:,:), v1(:) REAL(KIND=REAL32), OPTIONAL, INTENT(IN) :: v2(:), v3(:), v4(:), v5(:), v6(:), v7(:), v8(:), v9(:) REAL(KIND=REAL32), ALLOCATABLE :: out(:,:), tmp(:,:) tmp = horzcat_r11(v1, v2, v3, v4, v5, v6, v7, v8, v9) out = horzcat_r22(v0, tmp) END FUNCTION horzcat_r21 !============================================================================================================================== FUNCTION horzcat_r22(v0, v1) RESULT(out) IMPLICIT NONE REAL(KIND=REAL32), INTENT(IN) :: v0(:,:), v1(:,:) REAL(KIND=REAL32), ALLOCATABLE :: out(:,:), pk(:) INTEGER :: nrow, ncol nrow = SIZE(v0,1) ncol = SIZE(v0,2)+SIZE(v1,2) IF(nrow /= SIZE(v1,1)) THEN; CALL msg("Can't concatenate real arrays of differing rows numbers"); STOP; END IF ALLOCATE(out(nrow, ncol)) pk = PACK(v0, .TRUE.) pk = [pk, PACK(v1, .TRUE.)] out = RESHAPE(pk, SHAPE=[nrow, ncol]) END FUNCTION horzcat_r22 !============================================================================================================================== FUNCTION horzcat_d00(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) IMPLICIT NONE REAL(KIND=REAL64), INTENT(IN) :: v0 REAL(KIND=REAL64), OPTIONAL, INTENT(IN) :: v1, v2, v3, v4, v5, v6, v7, v8, v9 REAL(KIND=REAL64), ALLOCATABLE :: out(:) INTEGER :: ncol, iv, i LOGICAL :: pre(9) !------------------------------------------------------------------------------------------------------------------------------ pre(:) = [PRESENT(v1),PRESENT(v2),PRESENT(v3),PRESENT(v4),PRESENT(v5),PRESENT(v6),PRESENT(v7),PRESENT(v8),PRESENT(v9)] ncol = 1+COUNT(pre) ALLOCATE(out(ncol)) out(1) = v0 i = 2 DO iv = i, ncol; IF(.NOT.pre(iv-1)) CYCLE SELECT CASE(iv-1) CASE(1); out(i) = v1; CASE(2); out(i) = v2; CASE(3); out(i) = v3; CASE(4); out(i) = v4; CASE(5); out(i) = v5 CASE(6); out(i) = v6; CASE(7); out(i) = v7; CASE(8); out(i) = v8; CASE(9); out(i) = v9 END SELECT i = i+1 END DO END FUNCTION horzcat_d00 !============================================================================================================================== FUNCTION horzcat_d10(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) IMPLICIT NONE REAL(KIND=REAL64), INTENT(IN) :: v0(:), v1 REAL(KIND=REAL64), OPTIONAL, INTENT(IN) :: v2, v3, v4, v5, v6, v7, v8, v9 REAL(KIND=REAL64), ALLOCATABLE :: out(:), tmp(:) tmp = horzcat_d00(v1, v2, v3, v4, v5, v6, v7, v8, v9) out = [v0 , tmp] END FUNCTION horzcat_d10 !============================================================================================================================== FUNCTION horzcat_d11(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) IMPLICIT NONE REAL(KIND=REAL64), INTENT(IN) :: v0(:) REAL(KIND=REAL64), OPTIONAL, INTENT(IN) :: v1(:), v2(:), v3(:), v4(:), v5(:), v6(:), v7(:), v8(:), v9(:) REAL(KIND=REAL64), ALLOCATABLE :: out(:,:) INTEGER :: siz(9), nrow, ncol, iv, i, n LOGICAL :: pre(9) !------------------------------------------------------------------------------------------------------------------------------ pre(:) = [PRESENT(v1),PRESENT(v2),PRESENT(v3),PRESENT(v4),PRESENT(v5),PRESENT(v6),PRESENT(v7),PRESENT(v8),PRESENT(v9)] nrow = SIZE(v0) ncol = 1+COUNT(pre) ALLOCATE(out(nrow, ncol)) out(:,1) = v0 i = 2 DO iv = i, ncol; IF(.NOT.pre(iv-1)) CYCLE SELECT CASE(iv-1) CASE(1); n = SIZE(v1); CASE(2); n = SIZE(v2); CASE(3); n = SIZE(v3); CASE(4); n = SIZE(v4); CASE(5); n = SIZE(v5) CASE(6); n = SIZE(v6); CASE(7); n = SIZE(v7); CASE(8); n = SIZE(v8); CASE(9); n = SIZE(v9) END SELECT IF(n /= nrow) THEN; CALL msg("Can't concatenate double vectors of differing lengths"); STOP; END IF SELECT CASE(iv-1) CASE(1); out(:,i) = v1; CASE(2); out(:,i) = v2; CASE(3); out(:,i) = v3; CASE(4); out(:,i) = v4; CASE(5); out(:,i) = v5 CASE(6); out(:,i) = v6; CASE(7); out(:,i) = v7; CASE(8); out(:,i) = v8; CASE(9); out(:,i) = v9 END SELECT i = i+1 END DO END FUNCTION horzcat_d11 !============================================================================================================================== FUNCTION horzcat_d21(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) IMPLICIT NONE REAL(KIND=REAL64), INTENT(IN) :: v0(:,:), v1(:) REAL(KIND=REAL64), OPTIONAL, INTENT(IN) :: v2(:), v3(:), v4(:), v5(:), v6(:), v7(:), v8(:), v9(:) REAL(KIND=REAL64), ALLOCATABLE :: out(:,:), tmp(:,:) tmp = horzcat_d11(v1, v2, v3, v4, v5, v6, v7, v8, v9) out = horzcat_d22(v0, tmp) END FUNCTION horzcat_d21 !============================================================================================================================== FUNCTION horzcat_d22(v0, v1) RESULT(out) IMPLICIT NONE REAL(KIND=REAL64), INTENT(IN) :: v0(:,:), v1(:,:) REAL(KIND=REAL64), ALLOCATABLE :: out(:,:), pk(:) INTEGER :: nrow, ncol nrow = SIZE(v0,1) ncol = SIZE(v0,2)+SIZE(v1,2) IF(nrow /= SIZE(v1,1)) THEN; CALL msg("Can't concatenate double arrays of differing rows numbers"); STOP; END IF ALLOCATE(out(nrow, ncol)) pk = PACK(v0, .TRUE.) pk = [pk, PACK(v1, .TRUE.)] out = RESHAPE(pk, SHAPE=[nrow, ncol]) END FUNCTION horzcat_d22 !============================================================================================================================== FUNCTION horzcat_l00(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) IMPLICIT NONE LOGICAL, INTENT(IN) :: v0 LOGICAL, OPTIONAL, INTENT(IN) :: v1, v2, v3, v4, v5, v6, v7, v8, v9 LOGICAL, ALLOCATABLE :: out(:) INTEGER :: ncol, iv, i LOGICAL :: pre(9) !------------------------------------------------------------------------------------------------------------------------------ pre(:) = [PRESENT(v1),PRESENT(v2),PRESENT(v3),PRESENT(v4),PRESENT(v5),PRESENT(v6),PRESENT(v7),PRESENT(v8),PRESENT(v9)] ncol = 1+COUNT(pre) ALLOCATE(out(ncol)) out(1) = v0 i = 2 DO iv = i, ncol; IF(.NOT.pre(iv-1)) CYCLE SELECT CASE(iv-1) CASE(1); out(i) = v1; CASE(2); out(i) = v2; CASE(3); out(i) = v3; CASE(4); out(i) = v4; CASE(5); out(i) = v5 CASE(6); out(i) = v6; CASE(7); out(i) = v7; CASE(8); out(i) = v8; CASE(9); out(i) = v9 END SELECT i = i+1 END DO END FUNCTION horzcat_l00 !============================================================================================================================== FUNCTION horzcat_l10(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) IMPLICIT NONE LOGICAL, INTENT(IN) :: v0(:), v1 LOGICAL, OPTIONAL, INTENT(IN) :: v2, v3, v4, v5, v6, v7, v8, v9 LOGICAL, ALLOCATABLE :: out(:), tmp(:) tmp = horzcat_l00(v1, v2, v3, v4, v5, v6, v7, v8, v9) out = [v0, tmp] END FUNCTION horzcat_l10 !============================================================================================================================== FUNCTION horzcat_l11(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) IMPLICIT NONE LOGICAL, INTENT(IN) :: v0(:) LOGICAL, OPTIONAL, INTENT(IN) :: v1(:), v2(:), v3(:), v4(:), v5(:), v6(:), v7(:), v8(:), v9(:) LOGICAL, ALLOCATABLE :: out(:,:) INTEGER :: siz(9), nrow, ncol, iv, i, n LOGICAL :: pre(9) !------------------------------------------------------------------------------------------------------------------------------ pre(:) = [PRESENT(v1),PRESENT(v2),PRESENT(v3),PRESENT(v4),PRESENT(v5),PRESENT(v6),PRESENT(v7),PRESENT(v8),PRESENT(v9)] ncol = 1+COUNT(pre) nrow = SIZE(v0) ALLOCATE(out(nrow, ncol)) out(:,1) = v0 i = 2 DO iv = i, ncol; IF(.NOT.pre(iv-1)) CYCLE SELECT CASE(iv-1) CASE(1); n = SIZE(v1); CASE(2); n = SIZE(v2); CASE(3); n = SIZE(v3); CASE(4); n = SIZE(v4); CASE(5); n = SIZE(v5) CASE(6); n = SIZE(v6); CASE(7); n = SIZE(v7); CASE(8); n = SIZE(v8); CASE(9); n = SIZE(v9) END SELECT IF(n /= nrow) THEN; CALL msg("Can't concatenate logical vectors of differing lengths"); STOP; END IF SELECT CASE(iv-1) CASE(1); out(:,i) = v1; CASE(2); out(:,i) = v2; CASE(3); out(:,i) = v3; CASE(4); out(:,i) = v4; CASE(5); out(:,i) = v5 CASE(6); out(:,i) = v6; CASE(7); out(:,i) = v7; CASE(8); out(:,i) = v8; CASE(9); out(:,i) = v9 END SELECT i = i+1 END DO END FUNCTION horzcat_l11 !============================================================================================================================== FUNCTION horzcat_l21(v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) RESULT(out) IMPLICIT NONE LOGICAL, INTENT(IN) :: v0(:,:), v1(:) LOGICAL, OPTIONAL, INTENT(IN) :: v2(:), v3(:), v4(:), v5(:), v6(:), v7(:), v8(:), v9(:) LOGICAL, ALLOCATABLE :: out(:,:), tmp(:,:) tmp = horzcat_l11(v1, v2, v3, v4, v5, v6, v7, v8, v9) out = horzcat_l22(v0, tmp) END FUNCTION horzcat_l21 !============================================================================================================================== FUNCTION horzcat_l22(v0, v1) RESULT(out) IMPLICIT NONE LOGICAL, INTENT(IN) :: v0(:,:), v1(:,:) LOGICAL, ALLOCATABLE :: out(:,:), pk(:) INTEGER :: nrow, ncol nrow = SIZE(v0,1) ncol = SIZE(v0,2)+SIZE(v1,2) IF(nrow /= SIZE(v1,1)) THEN; CALL msg("Can't concatenate logical arrays of differing rows numbers"); STOP; END IF ALLOCATE(out(nrow, ncol)) pk = PACK(v0, .TRUE.) pk = [pk, PACK(v1, .TRUE.)] out = RESHAPE(pk, SHAPE=[nrow, ncol]) END FUNCTION horzcat_l22 !============================================================================================================================== !============================================================================================================================== !=== DISPLAY A TABLE COMPOSED OF HORIZONTALLY CONCATENATED COLUMN VECTORS ===================================================== !============================================================================================================================== !=== The profile "p" describe in which order to pick up the columns from "s", "i" and "r" for display. !=== * nRowMax lines are displayed (default: all lines) !=== * nColMax characters (default: as long as needed) are displayed at most on a line. !=== - narrow tables are stacked horizontally as much as possible (ie: total width must stay lower than nColMax) . !=== - wide tables are cut into several sub-tables of columns subsets, with the first nHead columns repeated. !=== * titles can be a vector (one element each column) or an array (dim 1: number of lines ; dim 2: number of columns) !============================================================================================================================== LOGICAL FUNCTION dispTable_1(p, titles, s, i, r, rFmt, nRowMax, nColMax, nHead, unit, sub) RESULT(lerr) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: p !--- DISPLAY MAP: s/i/r CHARACTER(LEN=*), INTENT(IN) :: titles(:) !--- TITLES (one each column, single line) CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: s(:,:) !--- STRINGS INTEGER, OPTIONAL, INTENT(IN) :: i(:,:) !--- INTEGERS REAL, OPTIONAL, INTENT(IN) :: r(:,:) !--- REALS CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: rFmt !--- Format for reals INTEGER, OPTIONAL, INTENT(IN) :: nRowMax !--- Display at most "nRowMax" rows INTEGER, OPTIONAL, INTENT(IN) :: nColMax !--- Display at most "nColMax" characters each line INTEGER, OPTIONAL, INTENT(IN) :: nHead !--- Head columns repeated for multiple tables display INTEGER, OPTIONAL, INTENT(IN) :: unit !--- Output unit (default: screen) CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sub !--- Subroutine name !------------------------------------------------------------------------------------------------------------------------------ lerr = dispTable_2(p, RESHAPE(titles, [1,SIZE(titles)]), s, i, r, rFmt, nRowMax, nColMax, nHead, unit, sub) END FUNCTION dispTable_1 !============================================================================================================================== LOGICAL FUNCTION dispTable_2(p, titles, s, i, r, rFmt, nRowMax, nColMax, nHead, unit, sub) RESULT(lerr) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: p !--- DISPLAY MAP: s/i/r CHARACTER(LEN=*), INTENT(IN) :: titles(:,:) !--- TITLES (one each column, possibly more than one line) CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: s(:,:) !--- STRINGS INTEGER, OPTIONAL, INTENT(IN) :: i(:,:) !--- INTEGERS REAL, OPTIONAL, INTENT(IN) :: r(:,:) !--- REALS CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: rFmt !--- Format for reals INTEGER, OPTIONAL, INTENT(IN) :: nRowMax !--- Display at most "nRowMax" rows INTEGER, OPTIONAL, INTENT(IN) :: nColMax !--- Display at most "nColMax" characters each line INTEGER, OPTIONAL, INTENT(IN) :: nHead !--- Head columns repeated for multiple tables display INTEGER, OPTIONAL, INTENT(IN) :: unit !--- Output unit (default: screen) CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sub !--- Subroutine name !------------------------------------------------------------------------------------------------------------------------------ INTEGER, PARAMETER :: nm = 1 INTEGER, ALLOCATABLE :: n(:), nmx(:) INTEGER :: nRmx, nCmx, nHd, unt, ib, ic, ie, it, nt, ncol, k, l, l0 CHARACTER(LEN=maxlen), ALLOCATABLE :: c(:,:), c1(:,:), m(:) CHARACTER(LEN=maxlen) :: subn !=== CONVERT THE ELEMENTS INTO A STRINGS ARRAY lerr = convertTable(p, titles, c, s, i, r, rFmt, sub); IF(lerr) RETURN !=== GET VALUES FOR REMAINING OPTIONAL ARGUMENTS nRmx= SIZE(c, 1); IF(PRESENT(nRowMax)) nRmx=MIN(nRmx,nRowMax) !--- Maximum number of lines to print nCmx= maxTableWidth; IF(PRESENT(nColMax)) nCmx=MIN(nCmx,nColMax) !--- Maximum number of characters each line nHd = 0; IF(PRESENT(nHead)) nHd = nHead !--- Number of front columns to duplicate unt = lunout; IF(PRESENT(unit)) unt = unit !--- Unit to print messages subn= 'dispTable'; IF(PRESENT(sub)) subn= sub !--- Calling subroutine name !=== SMALL WIDTH TABLE: STACK AS MUCH VERTICAL SECTIONS HORIZONTALLY AS POSSIBLE CONSIDERING nColMax. UNTOUCHED OTHERWISE. n = tableCellsWidth(c)+2*nm c1 = gatherTable(c, n, SIZE(titles, 1), nRmx, nCmx, subn) ncol = SIZE(c1, DIM=2) IF(ncol /= SIZE(c,2)) n = tableCellsWidth(c1)+2*nm !--- UPDATE "n(:)" IF "c" HAS BEEN STACKED nCmx = 48 !=== HIGH WIDTH TABLE: CUT IT INTO SUB-TABLES, WITH THE FIRST "nHead" COLUMNS REPEATED IN EACH OF THEM !--- Build the vector of max column index in case the rows are too long (table must be displayed in multiple parts) IF(SUM(n+1)-1 > nCmx .AND. ncol > 1) THEN l0 = 1 + LEN_TRIM(subn) + SUM(n(1:nHd)+1) !=== DETERMINE THE NUMBER "nt" OF SUB-TABLES 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 !=== GET THE INDEX OF THE LAST COLUMN FOR EACH SUB-TABLE ALLOCATE(nmx(nt)) 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 nmx(nt) = ncol !=== DISPLAY THE SUB-TABLES DO it = 1, nt ie = nmx(it); ib = nHd+1; IF(it > 1) ib = nmx(it-1)+1 m = buildTable(cat(c1(:,1:nHd),c1(:,ib:ie)), nm, SIZE(titles, 1)) DO k = 1, SIZE(m); CALL msg(TRIM(m(k)), subn, unit=unt); END DO; CALL msg('', subn, unit=unt) END DO ELSE !=== DISPLAY THE SINGLE TABLE m = buildTable(c1, nm, SIZE(titles,1)) DO k = 1, SIZE(m); CALL msg(TRIM(m(k)), subn, unit=unt); END DO END IF CONTAINS FUNCTION tableCellsWidth(t) RESULT(n) !=== COMPUTE FOR EACH COLUMN THE MIMIMUM WIDTH TO DISPLAY ELEMENTS WITHOUT TRUNCATION CHARACTER(LEN=*), INTENT(IN) :: t(:,:) INTEGER, ALLOCATABLE :: n(:) INTEGER :: i, j n = [(MAXVAL([(LEN_TRIM(t(i,j)), i=1, SIZE(t,1))], DIM=1), j=1, SIZE(t,2))] END FUNCTION tableCellsWidth END FUNCTION dispTable_2 !============================================================================================================================== !============================================================================================================================== !--- Concatenate horizontally the table d0(:,:) so that: !=== * total width (number of characters per line) remains lower than nColMax (default: 256 characters) !=== * total number of lines remains lower than nRowMax (default: all lines are kept) !=== If the table d0 starts with nTitle /= 0 lines for titles, they are duplicated at each section top. !============================================================================================================================== FUNCTION gatherTable(d0, n, nTitle, nRowMax, nColMax, sub) RESULT(d1) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: d0(:,:) !--- Input strings array INTEGER, INTENT(IN) :: n(:) !--- Maximum width of elements in each column (excluding separator) INTEGER, OPTIONAL, INTENT(IN) :: nTitle !--- Number of rows for titles INTEGER, OPTIONAL, INTENT(IN) :: nRowMax !--- Maximum number of rows INTEGER, OPTIONAL, INTENT(IN) :: nColMax !--- Maximum number of characters each line CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sub !--- Subroutine name CHARACTER(LEN=maxlen), ALLOCATABLE :: d1(:,:) !--- Array of horizontally gathered sections INTEGER :: nr0, nc0, nr1, nc1 !--- Row and columns numbers for original and gathered array INTEGER :: ih, nh, nv !--- Index and number of stacked sections INTEGER :: nttl, nrMx, ncMx !--- Titles number and effective max. row and columns numbers INTEGER :: nrem, nr, ir0, icb, ice nr0 = SIZE(d0, DIM=1) nc0 = SIZE(d0, DIM=2) nttl = 0; IF(PRESENT(nTitle)) nttl = nTitle ncMx = 256; IF(PRESENT(nColMax)) ncMx = MIN(nCmx, nColMax) nrMx = nr0; IF(PRESENT(nRowMax)) nrMx = MIN(nrMx, nRowMax) nh = MAX(1, ncMx/SUM(n+1)) !--- Max. horiz. stackabled sections for ncMx (+1: last separator) nv = 1+(nr0-nttl-1)/nh !--- Corresponding number ofvertical elements per section nh = 1+(nr0-nttl-1)/nv !--- Effective number of sections nr1 = MIN(nrMx,1+ nttl+(nr0-nttl-1)/nh); nc1 = nc0*nh !--- Shape of the stacked array ALLOCATE(d1(nr1,nc1)) nrem = nr0 !--- Remaining values to fill in DO ih = 1, nh nr = MAX(0,MIN(nr1,nrem)-nttl); nrem=nrem-nr !--- Number of copied rows in ith section (excluding titles) ir0 = nttl+(ih-1)*(nr1-nttl) !--- Row start index in d1 ice = ih*nc0; icb = ice-nc0+1 !--- Column end and start indices in d1 d1(1:nttl, icb:ice) = d0(1:nttl, :) !--- Copy titles line(s) d1(1+nttl:nr+nttl,icb:ice) = d0(1+ir0:nr+ir0,:) !--- Copy ith section IF(nr1 == nr + nttl) CYCLE d1(1+nr+nttl:nr1, icb:ice) =' ' !--- Fill missing cells with a space END DO END FUNCTION gatherTable !============================================================================================================================== !============================================================================================================================== !--- Convert a set of columns of different natures ("s"trings, "i"ntegers, "r"eals) into a strings table. Default value !=== * p: profile giving the order to pick up columns from "s", "i" and "r" to construct "c(:,:)". mandatory !=== * t: titles, one per variable (2nd index), possibly on several lines (1st index). mandatory !=== * c: assembled array mandatory !=== * s: horizontally stacked string column vectors of values / !=== * i: horizontally stacked integer column vectors of values / !=== * r: horizontally stacked real column vectors of values / !=== * rFmt: format for real conversion * !=== * sub: calling subroutine name (for error messages) / !=== NOTE: The vectors s, i and r do not have necessarly the same length. Empty elements are filled at the end. !============================================================================================================================== LOGICAL FUNCTION convertTable(p, t, c, s, i, r, rFmt, sub) RESULT(lerr) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: p !--- DISPLAY MAP: s/i/r CHARACTER(LEN=*), INTENT(IN) :: t(:,:) !--- TITLES (ONE EACH COLUMN) CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: c(:,:) !--- CONVERTED STRINGS TABLE CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: s(:,:) !--- STRINGS INTEGER, OPTIONAL, INTENT(IN) :: i(:,:) !--- INTEGERS REAL, OPTIONAL, INTENT(IN) :: r(:,:) !--- REALS CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: rFmt !--- Format for reals CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sub !--- Subroutine name !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=maxlen), ALLOCATABLE :: d(:,:) CHARACTER(LEN=maxlen) :: rFm, subn CHARACTER(LEN=1) :: sp = '|' !--- Table cells separator INTEGER :: it, is, ii, ir, ic, nmx INTEGER :: nt, ns, ni, nr, ncol LOGICAL :: ls, li, lr, ll rFm = '*'; IF(PRESENT(rFmt)) rFm = rFmt !--- Specified format for reals subn = ''; IF(PRESENT(sub)) subn = sub ls = PRESENT(s); li = PRESENT(i); lr = PRESENT(r) ns = 0; ni = 0; nr = 0; ncol = 0 ncol = LEN_TRIM(p) !--- Number of columns of the table nt = SIZE(t,1) !--- CHECK ARGUMENTS COHERENCE lerr = .NOT.ANY([ls,li,lr]) CALL msg('missing argument(s) "s", "i" and/or "r"', subn, lerr) IF(lerr) RETURN lerr = ncol /= SIZE(t,2) CALL msg('display map "p" length and titles number mismatch', subn, lerr) IF(lerr) RETURN IF(ls) THEN; ns = SIZE(s,1) lerr = COUNT([(p(ic:ic)=='s', ic=1, ncol)]) /= SIZE(s,2) CALL msg('display map "p" and string arguments mismatch: nb(p=="s")/=SIZE(s,2)', subn, lerr) IF(lerr) RETURN END IF IF(li) THEN; ni = SIZE(i,1) lerr = COUNT([(p(ic:ic)=='i', ic=1, ncol)]) /= SIZE(i,2) CALL msg('display map "p" and integer arguments mismatch: nb(p=="i")/=SIZE(i,2)', subn, lerr) IF(lerr) RETURN END IF IF(lr) THEN; nr = SIZE(r,1) lerr = COUNT([(p(ic:ic)=='r', ic=1, ncol)]) /= SIZE(r,2) CALL msg('display map "p" and real arguments mismatch: nb(p=="r")/=SIZE(r,2)', subn, lerr) IF(lerr) RETURN END IF ! lerr = (ls.AND.li .AND. ns /= ni) .OR. (li.AND.lr .AND. ni /= nr) .OR. (lr.AND.ls .AND. nr /= ns) ! CALL msg('mismatching rows numbers for at least "s", "i" or "r"', subn, lerr) ! IF(lerr) RETURN nmx = MAX(ns, ni, nr) + nt !--- Assemble the vectors into a strings array in the order indicated by "pattern" ALLOCATE(c(nmx,ncol)) is = 1; ii = 1; ir = 1 DO ic = 1, ncol c(1:nt,ic) = t(1:nt,ic) !--- Add titles line(s) SELECT CASE(p(ic:ic)) CASE('s'); c(1+nt:nmx,ic) = s(:,is) ; is = is + 1 !--- Add string elements CASE('i'); c(1+nt:nmx,ic) = num2str(i(:,ii) ); ii = ii + 1 !--- Add integer elements CASE('r'); c(1+nt:nmx,ic) = num2str(r(:,ir),rFm); ir = ir + 1 !--- Add real elements END SELECT END DO CALL cleanZeros(c) !--- Remove useless zeros in converted numbers END FUNCTION convertTable !============================================================================================================================== !============================================================================================================================== !--- Build a table from the string array "d(:,:)" as a vector of assembled lines (to be printed as messages). !=== * each column has the minimum width "n(j)" needed to display the elements "d(:,j)" with at least "nm" spaces each side. !=== * the structure of a cell is: | (pay attention to the end separator "|") !=== * n1 and n2 depend on the justification (three methods available) and give a total width of "n(j)", as expected. !=== * each cell ends with the separator "|", except the last one !=== * nTitle/=0 means that the first "nTitle" lines will be separated from the rest of the table with an underline. !============================================================================================================================== FUNCTION buildTable(d, nm, nTitle) RESULT(m) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: d(:,:) !--- Input array INTEGER, INTENT(IN) :: nm !--- Number of spaces before and after values INTEGER, OPTIONAL, INTENT(IN) :: nTitle !--- Number of rows for titles CHARACTER(LEN=10*maxlen), ALLOCATABLE :: m(:) !--- Lines to issue as messages to display the table CHARACTER(LEN=1) :: sp = '|' !--- Separator INTEGER :: ir, ic, nr, nc, i, j, n(SIZE(d,2)), nttl, id, p nr = SIZE(d, DIM=1); nc = SIZE(d, DIM=2) !--- Dimensions of the table nttl = 0; IF(PRESENT(nTitle)) nttl = nTitle n = [(MAXVAL([(LEN_TRIM(d(i,j)), i=1, nr)], DIM=1), j=1, nc)] + 2*nm ALLOCATE(m(nr+1)) !--- Allocate the vector (+1 for header line) i = 1 DO ir = 1, nr IF(ir <= nttl) CALL centerJustified(d(ir,:), n, i, m(i)) IF(ir == nttl) CALL headerLine( n, i, m(i)) IF(ir > nttl) CALL leftJustified(d(ir,:), n, i, m(i)) END DO CONTAINS SUBROUTINE leftJustified(d, n, i, r) CHARACTER(LEN=*), INTENT(IN) :: d(:) INTEGER, INTENT(IN) :: n(:) CHARACTER(LEN=*), INTENT(INOUT) :: r INTEGER, INTENT(INOUT) :: i r = '' DO id = 1, nc; r = TRIM(r)//REPEAT(' ',nm)//TRIM(d(id))//REPEAT(' ',n(id)-LEN_TRIM(d(id))-nm)//sp; END DO r = r(1:LEN_TRIM(r)-1); i = i+1 !--- Final separator removed END SUBROUTINE leftJustified SUBROUTINE centerJustified(d, n, i, r) CHARACTER(LEN=*), INTENT(IN) :: d(:) INTEGER, INTENT(IN) :: n(:) INTEGER, INTENT(INOUT) :: i CHARACTER(LEN=*), INTENT(INOUT) :: r INTEGER :: p 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 r = r(1:LEN_TRIM(r)-1); i = i+1 !--- Final separator removed END SUBROUTINE centerJustified SUBROUTINE rightJustified(d, n, i, r) CHARACTER(LEN=*), INTENT(IN) :: d(:) INTEGER, INTENT(IN) :: n(:) INTEGER, INTENT(INOUT) :: i CHARACTER(LEN=*), INTENT(INOUT) :: r r = ''; DO id = 1, nc; r = TRIM(r)//REPEAT(' ',n(id)-LEN_TRIM(d(id))-nm)//TRIM(d(id))//REPEAT(' ',nm)//sp; END DO r = r(1:LEN_TRIM(r)-1); i = i+1 !--- Final separator removed END SUBROUTINE rightJustified SUBROUTINE headerLine(n, i, r) INTEGER, INTENT(IN) :: n(:) INTEGER, INTENT(INOUT) :: i CHARACTER(LEN=*), INTENT(INOUT) :: r r = ''; DO id= 1 , nc; r = TRIM(r)//REPEAT('-',n(id))//'+'; END DO r = r(1:LEN_TRIM(r)-1); i = i+1 !--- Final '+' removed END SUBROUTINE headerLine END FUNCTION buildTable !============================================================================================================================== !============================================================================================================================== LOGICAL FUNCTION dispNamelist(unt, p, titles, s, i, r, rFmt, llast) RESULT(lerr) IMPLICIT NONE INTEGER, INTENT(IN) :: unt !--- Output unit CHARACTER(LEN=*), INTENT(IN) :: p !--- DISPLAY MAP: s/i/r CHARACTER(LEN=*), INTENT(IN) :: titles(:) !--- TITLES (ONE EACH COLUMN) CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: s(:,:) !--- STRINGS INTEGER, OPTIONAL, INTENT(IN) :: i(:,:) !--- INTEGERS REAL, OPTIONAL, INTENT(IN) :: r(:,:) !--- REALS CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: rFmt !--- Format for reals LOGICAL, OPTIONAL, INTENT(IN) :: llast !--- Last variable: no final ',' !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=maxlen) :: rFm, el CHARACTER(LEN=maxlen), ALLOCATABLE :: d(:,:) CHARACTER(LEN=:), ALLOCATABLE :: sp, row INTEGER :: is, ii, ir, nrow, ic INTEGER :: ns, ni, nr, ncol, np INTEGER, ALLOCATABLE :: n(:) LOGICAL :: ls, li, lr, la rFm = '*'; IF(PRESENT(rFmt)) rFm = rFmt !--- Specified format for reals ls = PRESENT(s); li = PRESENT(i); lr = PRESENT(r) lerr = .FALSE.; IF(.NOT.ANY([ls,li,lr])) RETURN !--- Nothing to do la = .FALSE.; IF(PRESENT(llast)) la = llast !--- CHECK ARGUMENTS COHERENCE ns = 0; ni = 0; nr = 0; np = LEN_TRIM(p); ncol = 0 IF(ls) THEN; ns = SIZE(s, DIM=1); ncol = ncol + SIZE(s, DIM=2) lerr = COUNT([(p(ic:ic)=='s', ic=1, np)]) /= SIZE(s, DIM=2) END IF IF(li) THEN; ni = SIZE(i, DIM=1); ncol = ncol + SIZE(i, DIM=2) lerr = COUNT([(p(ic:ic)=='i', ic=1, np)]) /= SIZE(i, DIM=2) END IF IF(lr) THEN; nr = SIZE(r, DIM=1); ncol = ncol + SIZE(r, DIM=2) lerr = COUNT([(p(ic:ic)=='r', ic=1, np)]) /= SIZE(r, DIM=2) END IF CALL msg('display map "p" length and arguments number mismatch', ll=lerr); IF(lerr) RETURN lerr = ncol /= SIZE(titles); CALL msg('"titles" length and arguments number mismatch', ll=lerr); IF(lerr) RETURN lerr = ls.AND.li.AND.ns/=ni; CALL msg('string and integer arguments lengths mismatch', ll=lerr); IF(lerr) RETURN lerr = ls.AND.lr.AND.ns/=nr; CALL msg( 'string and real arguments lengths mismatch', ll=lerr); IF(lerr) RETURN lerr = li.AND.lr.AND.ni/=nr; CALL msg( 'integer and real arguments lengths mismatch', ll=lerr); IF(lerr) RETURN !--- Allocate the assembled quantities array nrow = MAX(ns,ni,nr)+1 ALLOCATE(d(nrow,ncol), n(ncol)) !--- Assemble the vectors into a strings array in the order indicated by "pattern" is = 1; ii = 1; ir = 1 DO ic = 1, ncol d(1,ic) = TRIM(titles(ic)) SELECT CASE(p(ic:ic)) CASE('s'); d(2:nrow,ic) = s(:,is) ; is = is + 1 CASE('i'); d(2:nrow,ic) = num2str(i(:,ii) ); ii = ii + 1 CASE('r'); d(2:nrow,ic) = num2str(r(:,ir),rFm); ir = ir + 1 END SELECT END DO CALL cleanZeros(d) DO ic = 1, ncol n(ic) = 0; DO ir=1, nrow; n(ic)=MAX(n(ic), LEN_TRIM(d(ir,ic))); END DO IF(needQuotes(d(2,ic)) .AND. ic/=1) n(ic) = n(ic) + 2 !--- For quotes, using second line only END DO !--- Display the strings array as a table DO ir = 1, nrow row = ''; sp = ' '; IF(TRIM(d(ir,1)) /= '') sp = ' = ' DO ic = 1, ncol el = d(ir,ic); IF(ic /= 1) el = addQuotes_1(el) row = row//TRIM(el)//REPEAT(' ',n(ic)-LEN_TRIM(el))//sp sp = ' '; IF(ic /= ncol-1) CYCLE IF(TRIM(d(MIN(ir+1,nrow),1)) /= '' .AND. (ir /= nrow .OR. .NOT.la)) sp = ' , ' END DO WRITE(unt,'(a)')TRIM(row) END DO !--- End of section IF(la) THEN WRITE(unt,'(a)')'/' WRITE(unt,'(a)') END IF END FUNCTION dispNameList !============================================================================================================================== !============================================================================================================================== 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) ==================== !============================================================================================================================== LOGICAL FUNCTION reduceExpr_1(str, val) RESULT(lerr) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: str CHARACTER(LEN=maxlen), INTENT(OUT) :: val !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=maxlen) :: v CHARACTER(LEN=1024) :: s, vv CHARACTER(LEN=1024), ALLOCATABLE :: vl(:) INTEGER, ALLOCATABLE :: ip(:) INTEGER :: nl, nn, i, j, im, ix LOGICAL :: ll s = str !--- Check wether the parenthesis are correctly formed ll = strCount(s,'(',nl) ll = strCount(s,')',nn) lerr = nl /= nn CALL msg('Mismatching number of opening and closing parenthesis: '//TRIM(s), ll=lerr); IF(lerr) RETURN nl = 2*nl-1 !--- Build vectors ; vl: parenthesis-separated elements ; ip: parenthesis types (1: opening, 2: closing) ALLOCATE(ip(nl-1),vl(nl)) j = 1; im = 1 DO i = 1, LEN_TRIM(str) ix = INDEX('()', str(i:i)) IF(ix == 0) CYCLE ip(j) = ix vl(j) = str(im:i-1) j = j + 1; im = i + 1 END DO vl(j) = str(im:LEN_TRIM(str)) !--- Search for each opening/closing parenthesis pair DO WHILE(nl > 1) i = 1; DO WHILE(ip(i) /= 1 .OR. ip(i+1) /= 2); i = i + 1; END DO !IF(i > SIZE(ip)+1) EXIT;END DO lerr = reduceExpr_basic(vl(i+1), v); IF(lerr) RETURN v = TRIM(vl(i))//TRIM(v); IF(i+2<=nl) v=TRIM(v)//TRIM(vl(i+2)) vv = v//REPEAT(' ',768) IF(i == 1) THEN; ip = ip(3:nl-1); vl = [ vv, vl(4 :nl)] ELSE IF(i == nl-1) THEN; ip = ip(1:nl-2); vl = [vl(1:nl-3), vv ] ELSE; ip = [ip(1: i-1), ip(i+2:nl-1)]; vl = [vl(1: i-1), vv, vl(i+3:nl)]; END IF nl = SIZE(vl) END DO lerr = reduceExpr_basic(vl(1), val) END FUNCTION reduceExpr_1 !============================================================================================================================== !=== Reduce a simple algebrical expression (basic operations, no parenthesis) to a single number (string format) ============== !============================================================================================================================== LOGICAL FUNCTION reduceExpr_basic(str, val) RESULT(lerr) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: str CHARACTER(LEN=*), INTENT(OUT) :: val REAL(KIND=REAL64), ALLOCATABLE :: vl(:) INTEGER, ALLOCATABLE :: id(:) CHARACTER(LEN=maxlen), ALLOCATABLE :: ky(:) CHARACTER(LEN=1), ALLOCATABLE :: op(:) !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=1024) :: s REAL(KIND=REAL64) :: v, vm, vp INTEGER :: i, ni, io lerr = .FALSE. IF(is_numeric(str)) THEN; val=TRIM(str); RETURN; END IF op = ['^','/','*','+','-'] !--- List of recognized operations s = str lerr = strParse_m(s, op, ky, lSc=.TRUE., id = id) !--- Parse the values IF(lerr) RETURN !--- Problem with the parsing vl = str2dble(ky) !--- Conversion to doubles lerr = ANY(vl >= HUGE(1._REAL64)) CALL msg('Some values are non-numeric in: '//TRIM(s), ll=lerr) IF(lerr) RETURN !--- Non-numerical values found DO io = 1, SIZE(op) !--- Loop on known operators (order matters !) DO i = SIZE(id), 1, -1 !--- Loop on found operators ni = SIZE(id) IF(id(i) /= io) CYCLE !--- Current found operator is not op(io) vm = vl(i); vp = vl(i+1) !--- Couple of values used for current operation SELECT CASE(op(io)) !--- Perform operation on the two values CASE('^'); v = vm**vp CASE('/'); v = vm/vp CASE('*'); v = vm*vp CASE('+'); v = vm+vp CASE('-'); v = vm-vp END SELECT IF(i == ni) THEN; vl = [vl(1:ni-1), v]; ELSE; vl = [vl(1:i-1), v, vl(i+2:ni+1)]; END IF IF(i == ni) THEN; id = id(1:ni-1); ELSE; id = [id(1:i-1), id(i+1:ni )]; END IF END DO END DO val = num2str(vl(1)) END FUNCTION reduceExpr_basic !============================================================================================================================== !============================================================================================================================== FUNCTION reduceExpr_m(str, val) RESULT(lerr) IMPLICIT NONE LOGICAL, ALLOCATABLE :: lerr(:) CHARACTER(LEN=*), INTENT(IN) :: str(:) CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: val(:) !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: i ALLOCATE(lerr(SIZE(str)),val(SIZE(str))) lerr(:) = [(reduceExpr_1(str(i), val(i)), i=1, SIZE(str))] END FUNCTION reduceExpr_m !============================================================================================================================== !============================================================================================================================== !=== Check whether a string is a number or not ================================================================================ !============================================================================================================================== ELEMENTAL LOGICAL FUNCTION is_numeric(str) RESULT(out) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: str REAL :: x INTEGER :: e CHARACTER(LEN=12) :: fmt IF(TRIM(str) == '') THEN; out = .FALSE.; RETURN; END IF WRITE(fmt,'("(f",i0,".0)")') LEN_TRIM(str) READ(str,fmt,IOSTAT=e) x out = e==0 .AND. INDEX('Ee',str(LEN_TRIM(str):LEN_TRIM(str)))==0 END FUNCTION is_numeric !============================================================================================================================== !============================================================================================================================== !=== Convert a string into a logical/integer integer or an integer/real into a string ========================================= !============================================================================================================================== ELEMENTAL INTEGER FUNCTION str2bool(str) RESULT(out) !--- Result: 0/1 for .FALSE./.TRUE., -1 if not a valid boolean IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: str INTEGER :: ierr LOGICAL :: lout READ(str,*,IOSTAT=ierr) lout out = -HUGE(1) IF(ierr /= 0) THEN IF(ANY(['.false.', 'false ', 'no ', 'f ', 'n '] == strLower(str))) out = 0 IF(ANY(['.true. ', 'true ', 'yes ', 't ', 'y '] == strLower(str))) out = 1 ELSE out = 0; IF(lout) out = 1 END IF END FUNCTION str2bool !============================================================================================================================== ELEMENTAL INTEGER FUNCTION str2int(str) RESULT(out) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: str INTEGER :: ierr READ(str,*,IOSTAT=ierr) out IF(ierr/=0) out = -HUGE(1) END FUNCTION str2int !============================================================================================================================== ELEMENTAL REAL(KIND=REAL32) FUNCTION str2real(str) RESULT(out) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: str INTEGER :: ierr READ(str,*,IOSTAT=ierr) out IF(ierr/=0) out = -HUGE(1._REAL32) END FUNCTION str2real !============================================================================================================================== ELEMENTAL REAL(KIND=REAL64) FUNCTION str2dble(str) RESULT(out) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: str INTEGER :: ierr READ(str,*,IOSTAT=ierr) out IF(ierr/=0) out = -HUGE(1._REAL64) END FUNCTION str2dble !============================================================================================================================== ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION bool2str(b) RESULT(out) IMPLICIT NONE LOGICAL, INTENT(IN) :: b WRITE(out,*)b out = ADJUSTL(out) END FUNCTION bool2str !============================================================================================================================== ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION int2str(i, nDigits) RESULT(out) IMPLICIT NONE INTEGER, INTENT(IN) :: i INTEGER, OPTIONAL, INTENT(IN) :: nDigits !------------------------------------------------------------------------------------------------------------------------------ WRITE(out,*)i out = ADJUSTL(out) IF(.NOT.PRESENT(nDigits)) RETURN IF(nDigits > LEN_TRIM(out)) out = REPEAT('0', nDigits - LEN_TRIM(out))//TRIM(out) END FUNCTION int2str !============================================================================================================================== ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION real2str(r,fmt) RESULT(out) IMPLICIT NONE REAL(KIND=REAL32), INTENT(IN) :: r CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: fmt !------------------------------------------------------------------------------------------------------------------------------ IF( PRESENT(fmt)) WRITE(out,fmt)r IF(.NOT.PRESENT(fmt)) WRITE(out, * )r out = ADJUSTL(out) END FUNCTION real2str !============================================================================================================================== ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION dble2str(d,fmt) RESULT(out) IMPLICIT NONE REAL(KIND=REAL64), INTENT(IN) :: d CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: fmt !------------------------------------------------------------------------------------------------------------------------------ IF( PRESENT(fmt)) WRITE(out,fmt)d IF(.NOT.PRESENT(fmt)) WRITE(out, * )d out = ADJUSTL(out) END FUNCTION dble2str !============================================================================================================================== ELEMENTAL SUBROUTINE cleanZeros(s) IMPLICIT NONE CHARACTER(LEN=*), INTENT(INOUT) :: s INTEGER :: ls, ix, i IF(is_numeric(s)) THEN ls = LEN_TRIM(s) ix = MAX(INDEX(s,'E'),INDEX(s,'e'),INDEX(s,'D'),INDEX(s,'d')) IF(ix == 0) THEN DO ix = ls,1,-1; IF(s(ix:ix) /= '0') EXIT; END DO; s=s(1:ix+1) ELSE IF(INDEX(s,'.')/=0) THEN i = ix-1; DO WHILE(s(i:i) == '0'); i = i-1; END DO; s=s(1:i)//s(ix:ls) END IF END IF END SUBROUTINE cleanZeros !============================================================================================================================== !============================================================================================================================== FUNCTION addQuotes_1(s) RESULT(out) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: s CHARACTER(LEN=:), ALLOCATABLE :: out IF(needQuotes(s)) THEN; out = "'"//TRIM(s)//"'"; ELSE; out = s; END IF END FUNCTION addQuotes_1 !============================================================================================================================== FUNCTION addQuotes_m(s) RESULT(out) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: s(:) CHARACTER(LEN=:), ALLOCATABLE :: out(:) !------------------------------------------------------------------------------------------------------------------------------ INTEGER :: k, n n = MAXVAL(LEN_TRIM(s), MASK=.TRUE.) ALLOCATE(CHARACTER(LEN=n) :: out(SIZE(s))) DO k=1,SIZE(s) IF(needQuotes(s(k))) THEN; out(k) = "'"//TRIM(s(k))//"'"; ELSE; out(k) = s(k); END IF END DO END FUNCTION addQuotes_m !============================================================================================================================== ELEMENTAL LOGICAL FUNCTION needQuotes(s) RESULT(out) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: s CHARACTER(LEN=1) :: b, e !------------------------------------------------------------------------------------------------------------------------------ out = .TRUE.; IF(TRIM(s) == '') RETURN b = s(1:1); e = s(MAX(1,LEN_TRIM(s)):MAX(1,LEN_TRIM(s))) out = .NOT.is_numeric(s) .AND. (b /= "'" .OR. e /= "'") .AND. ( b /= '"' .OR. e /= '"') END FUNCTION needQuotes !============================================================================================================================== !============================================================================================================================== !=== DISPLAY ": the following are " FOLLOWED BY THE LIST OF FOR WHICH ==T. =============== !============================================================================================================================== LOGICAL FUNCTION checkList(str, lerr, message, items, reason, nmax) RESULT(out) IMPLICIT NONE ! Purpose: Messages in case a list contains wrong elements (indicated by lerr boolean vector). ! Note: Return value "out" is .TRUE. if there are errors (ie at least one element of "lerr" is TRUE). CHARACTER(LEN=*), INTENT(IN) :: str(:) LOGICAL, INTENT(IN) :: lerr(:) CHARACTER(LEN=*), INTENT(IN) :: message, items, reason INTEGER, OPTIONAL, INTENT(IN) :: nmax !------------------------------------------------------------------------------------------------------------------------------ CHARACTER(LEN=maxlen), ALLOCATABLE :: s(:) INTEGER :: i, nmx nmx = 256; IF(PRESENT(nmax)) nmx=nmax out = ANY(lerr); IF(.NOT.out) RETURN CALL msg(TRIM(message)//': the following '//TRIM(items)//' are '//TRIM(reason)//':') s = strStackm(PACK(str, MASK=lerr), ', ',nmx) DO i=1,SIZE(s,DIM=1); CALL msg(s(i)); END DO END FUNCTION checkList !============================================================================================================================== !============================================================================================================================== !=== Remove comment in line "str", ie all the characters from the first "#" sign found in "str". ============================== !============================================================================================================================== SUBROUTINE removeComment(str) IMPLICIT NONE CHARACTER(LEN=*), INTENT(INOUT) :: str INTEGER :: ix ix = INDEX(str,'# '); IF(ix /= 0) str = str(1:ix-1)//REPEAT(' ',LEN(str)-ix+1) END SUBROUTINE removeComment !============================================================================================================================== END MODULE strings_mod