Changeset 4120 for LMDZ6/trunk/libf/misc/strings_mod.F90

Timestamp:

Apr 5, 2022, 3:44:30 PM (2 years ago)

Author:

dcugnet

Message:

• New water names: H2Ov, H2Ol, H2Oi, H2Or -> H2O_g, H2O_l, H2O_s, H2O_r.
• Corrections for the lOldCode=.FALSE., not activated yet.

File:

• LMDZ6/trunk/libf/misc/strings_mod.F90 (modified) (15 diffs)

LMDZ6/trunk/libf/misc/strings_mod.F90

@@ -26 +26 @@
 !                 horzcat_d1,  horzcat_dm,
                                            horzcat_sm,  horzcat_im,  horzcat_rm; END INTERFACE cat
-  INTERFACE find;       MODULE PROCEDURE      strFind,    find_int,    find_boo; END INTERFACE find
+  INTERFACE find;         MODULE PROCEDURE    strFind,    find_int,    find_boo; END INTERFACE find
   INTERFACE dispOutliers; MODULE PROCEDURE dispOutliers_1, dispOutliers_2; END INTERFACE dispOutliers
   INTERFACE reduceExpr;   MODULE PROCEDURE   reduceExpr_1,   reduceExpr_m; END INTERFACE reduceExpr
@@ -105 +105 @@
   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(PRESENT(modname)) THEN
-    WRITE(unt,'(a)') TRIM(modname)//': '//str              !--- Routine name provided
-  ELSE
-    WRITE(unt,'(a)') str                                   !--- Simple message
-  END IF
+  IF(subn == '') WRITE(unt,'(a)') str                                          !--- Simple message
+  IF(subn /= '') WRITE(unt,'(a)') TRIM(subn)//': '//str                        !--- Routine name provided
 END SUBROUTINE msg_1
 !==============================================================================================================================
@@ -123 +122 @@
   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)
-  IF(PRESENT(modname)) THEN
-    DO k=1,SIZE(s); CALL msg_1(s(k), modname, l, unt); END DO
-  ELSE
-    DO k=1,SIZE(s); CALL msg_1(s(k), ll=l, unit=unt);  END DO
-  END IF
+  DO k=1,SIZE(s); CALL msg_1(s(k), subn,  l,   unt); END DO
 END SUBROUTINE msg_m
 !==============================================================================================================================
@@ -141 +138 @@
   LOGICAL,          OPTIONAL, INTENT(IN) :: ll
   INTEGER,          OPTIONAL, INTENT(IN) :: unit
+  CHARACTER(LEN=maxlen) :: subn
   INTEGER :: unt
+  subn = '';    IF(PRESENT(modname)) subn = modname
   l   = .TRUE.; IF(PRESENT(ll))     l = ll
   unt = lunout; IF(PRESENT(unit)) unt = unit
-  IF(PRESENT(modname)) THEN
-    CALL msg_1(str, modname, l, unt)
-  ELSE
-    CALL msg_1(str, ll=l, unit=unt)
-  END IF
+  CALL msg_1(str, subn, l, unt)
 END FUNCTION fmsg_1
 !==============================================================================================================================
@@ -157 +152 @@
   INTEGER,          OPTIONAL, INTENT(IN) :: unit
   INTEGER,          OPTIONAL, INTENT(IN)  :: nmax
+  CHARACTER(LEN=maxlen) :: subn
   INTEGER :: unt, nmx
+  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
-  IF(PRESENT(modname)) THEN
-    CALL msg_m(str, modname, l, unt, nmx)
-  ELSE
-    CALL msg_m(str, ll=l, unit=unt, nmax=nmx)
-  END IF
+  CALL msg_m(str, subn, l, unt, nmx)
 END FUNCTION fmsg_m
 !==============================================================================================================================
@@ -178 +171 @@
   out = str
   DO k=1,LEN_TRIM(str)
-    IF(str(k:k)>='A'.OR.str(k:k)<='Z') out(k:k)=ACHAR(IACHAR(str(k:k))+32)
+    IF(str(k:k)>='A' .AND. str(k:k)<='Z') out(k:k)=ACHAR(IACHAR(str(k:k))+32)
   END DO
 END FUNCTION strLower
@@ -187 +180 @@
   out = str
   DO k=1,LEN_TRIM(str)
-    IF(str(k:k)>='a'.OR.str(k:k)<='z') out(k:k)=ACHAR(IACHAR(str(k:k))-32)
+    IF(str(k:k)>='a' .AND. str(k:k)<='z') out(k:k)=ACHAR(IACHAR(str(k:k))-32)
   END DO
 END FUNCTION strUpper
@@ -222 +215 @@
   lf = .FALSE.; IF(PRESENT(lFirst)) lf=lFirst
   IF(PRESENT(sep)) THEN
-    out = [(strHead_1(str(k),sep,.NOT.lf),    k=1, SIZE(str))]
+    out = [(strHead_1(str(k), sep,   lf), k=1, SIZE(str))]
   ELSE
-    out = [(strHead_1(str(k),lFirst=.NOT.lf), k=1, SIZE(str))]
+    out = [(strHead_1(str(k), lFirst=lf), k=1, SIZE(str))]
   END IF
 END FUNCTION strHead_m
@@ -230 +223 @@
 !=== Extract the substring following the last (first if lFirst==TRUE) occurrence of separator "sep" in "str"   ================
 !=== Examples for str='a_b_c' and sep='_' and the bash command with the same effect:                           ================
-!===    * strHead(..,.FALSE.) = 'b_c'         ${str#*$sep}                                                     ================
-!===    * strHead(..,.TRUE.)  = 'c'           ${str##*$sep}                                                    ================
+!===    * strTail(..,.FALSE.) = 'c'           ${str#*$sep}                                                     ================
+!===    * strTail(..,.TRUE.)  = 'b_c'         ${str##*$sep}                                                    ================
 !==============================================================================================================================
 CHARACTER(LEN=maxlen) FUNCTION strTail_1(str,sep,lFirst) RESULT(out)
@@ -256 +249 @@
   lf = .FALSE.; IF(PRESENT(lFirst)) lf=lFirst
   IF(PRESENT(sep)) THEN
-    out = [(strTail_1(str(k),sep,.NOT.lf),    k=1, SIZE(str))]
+    out = [(strTail_1(str(k), sep,   lf), k=1, SIZE(str))]
   ELSE
-    out = [(strTail_1(str(k),lFirst=.NOT.lf), k=1, SIZE(str))]
+    out = [(strTail_1(str(k), lFirst=lf), k=1, SIZE(str))]
   END IF
 END FUNCTION strTail_m
@@ -861 +854 @@
 !=== The profile "p" describe in which order to pick up the columns from "s", "i" and "r" for display.
 !==============================================================================================================================
-LOGICAL FUNCTION dispTable(p, titles, s, i, r, rFmt, nmax, unit) RESULT(lerr)
+LOGICAL FUNCTION dispTable(p, titles, s, i, r, rFmt, nmax, unit, sub) RESULT(lerr)
   CHARACTER(LEN=*),           INTENT(IN)  :: p             !--- DISPLAY MAP: s/i/r
   CHARACTER(LEN=*),           INTENT(IN)  :: titles(:)     !--- TITLES (ONE EACH COLUMN)
@@ -870 +863 @@
   INTEGER,          OPTIONAL, INTENT(IN)  :: nmax          !--- Display less than "nrow" rows
   INTEGER,          OPTIONAL, INTENT(IN)  :: unit          !--- Output unit (default: screen)
+  CHARACTER(LEN=*), OPTIONAL, INTENT(IN)  :: sub           !--- Subroutine name
 
   CHARACTER(LEN=2048) :: row
-  CHARACTER(LEN=maxlen)  :: rFm, el
+  CHARACTER(LEN=maxlen)  :: rFm, el, subn
   CHARACTER(LEN=maxlen), ALLOCATABLE :: d(:,:)
   CHARACTER(LEN=1) :: s1, sp
@@ -881 +875 @@
   LOGICAL :: ls, li, lr
 
-!  modname = 'dispTable'
+  subn = '';    IF(PRESENT(sub)) subn = sub
   rFm = '*';    IF(PRESENT(rFmt)) rFm = rFmt               !--- Specified format for reals
   unt = lunout; IF(PRESENT(unit)) unt = unit               !--- Specified output unit
@@ -890 +884 @@
 
   !--- CHECK ARGUMENTS COHERENCE
-  lerr = np /= SIZE(titles); IF(fmsg('string "pattern" length and titles list mismatch', ll=lerr)) RETURN
-  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
-  IF(fmsg('string "pattern" length and arguments number mismatch', ll=lerr)) RETURN
-  lerr = ncol /= SIZE(titles); IF(fmsg('"titles" length and arguments number mismatch', ll=lerr)) RETURN
-  lerr = ls.AND.li.AND.ns/=ni; IF(fmsg('string and integer arguments lengths mismatch', ll=lerr)) RETURN
-  lerr = ls.AND.lr.AND.ns/=nr; IF(fmsg(   'string and real arguments lengths mismatch', ll=lerr)) RETURN
-  lerr = li.AND.lr.AND.ni/=nr; IF(fmsg(  'integer and real arguments lengths mismatch', ll=lerr)) RETURN
+  lerr = np /= SIZE(titles); IF(fmsg('string "pattern" length and titles list mismatch', subn, lerr)) RETURN
+  IF(ls) THEN
+    ns = SIZE(s, 1); ncol = ncol + SIZE(s, 2); lerr = COUNT([(p(ic:ic)=='s', ic=1, np)]) /= SIZE(s, 2)
+  END IF
+  IF(li) THEN
+    ni = SIZE(i, 1); ncol = ncol + SIZE(i, 2); lerr = COUNT([(p(ic:ic)=='i', ic=1, np)]) /= SIZE(i, 2)
+  END IF
+  IF(lr) THEN
+    nr = SIZE(r, 1); ncol = ncol + SIZE(r, 2); lerr = COUNT([(p(ic:ic)=='r', ic=1, np)]) /= SIZE(r, 2)
+  END IF
+  IF(fmsg('string "pattern" length and arguments number mismatch', subn, lerr)) RETURN
+  lerr = ncol /= SIZE(titles); IF(fmsg('"titles" length and arguments number mismatch', subn, lerr)) RETURN
+  lerr = ls.AND.li.AND.ns/=ni; IF(fmsg('string and integer arguments lengths mismatch', subn, lerr)) RETURN
+  lerr = ls.AND.lr.AND.ns/=nr; IF(fmsg(   'string and real arguments lengths mismatch', subn, lerr)) RETURN
+  lerr = li.AND.lr.AND.ni/=nr; IF(fmsg(  'integer and real arguments lengths mismatch', subn, lerr)) RETURN
   nrow = MAX(ns,ni,nr)+1
   nmx = nrow; IF(PRESENT(nmax)) nmx = MIN(nmx,nmax+1)
@@ -931 +925 @@
     END DO
     nr = LEN_TRIM(row)-1                                             !--- Final separator removed
-    CALL msg(row(1:nr), unit=unt)
+    CALL msg(row(1:nr), subn, unit=unt)
     IF(ir /= 1) CYCLE                                                !--- Titles are underlined
     row=''; DO ic=1,ncol; row=TRIM(row)//REPEAT('-',n(ic))//'+'; END DO
-    CALL msg(row(1:LEN_TRIM(row)-1), unit=unt)
+    CALL msg(row(1:LEN_TRIM(row)-1), subn, unit=unt)
   END DO