strhandler_mod.F90

Go to the documentation of this file.

!OPTIONS NOOPT
MODULE strhandler_mod

USE parkind1  ,ONLY : jpim, jprm, jprd

IMPLICIT NONE

PRIVATE

PUBLIC :: tolower, toupper, expand_string
PUBLIC :: sadjustl, sadjustr
PUBLIC :: stransfer

INTERFACE stransfer
MODULE PROCEDURE &
  stransfer_r8_to_str, stransfer_str_to_r8, &
& stransfer_r4_to_str, stransfer_str_to_r4
END INTERFACE

CONTAINS

FUNCTION stransfer_r8_to_str(SOURCE, MOLD) RESULT(C)
REAL(KIND=JPRD) , INTENT(IN) :: SOURCE
CHARACTER(LEN=*), INTENT(IN) :: MOLD
CHARACTER(LEN=8) :: C
CALL ecmwf_transfer(c,min(8,len(mold)),source,8)
END FUNCTION stransfer_r8_to_str


FUNCTION stransfer_str_to_r8(SOURCE, MOLD) RESULT(Z)
CHARACTER(LEN=*), INTENT(IN) :: SOURCE
REAL(KIND=JPRD) , INTENT(IN) :: MOLD
REAL(KIND=JPRD) :: Z
CALL ecmwf_transfer(z,8,source,len(source))
END FUNCTION stransfer_str_to_r8


FUNCTION stransfer_r4_to_str(SOURCE, MOLD) RESULT(C)
REAL(KIND=JPRM) , INTENT(IN) :: SOURCE
CHARACTER(LEN=*), INTENT(IN) :: MOLD
CHARACTER(LEN=4) :: C
CALL ecmwf_transfer(c,min(4,len(mold)),source,4)
END FUNCTION stransfer_r4_to_str


FUNCTION stransfer_str_to_r4(SOURCE, MOLD) RESULT(Z)
CHARACTER(LEN=*), INTENT(IN) :: SOURCE
REAL(KIND=JPRM) , INTENT(IN) :: MOLD
REAL(KIND=JPRM) :: Z
CALL ecmwf_transfer(z,4,source,len(source))
END FUNCTION stransfer_str_to_r4


FUNCTION sadjustl(S) RESULT(C)
CHARACTER(LEN=*), INTENT(IN) :: S
CHARACTER(LEN=MAX(1,LEN(S))) C
c = ' '
IF (len(s) > 0) THEN
  IF (s /= ' ') c = adjustl(s)
ENDIF
END FUNCTION sadjustl


FUNCTION sadjustr(S) RESULT(C)
CHARACTER(LEN=*), INTENT(IN) :: S
CHARACTER(LEN=MAX(1,LEN(S))) C
c = ' '
IF (len(s) > 0) THEN
  IF (s /= ' ') c = adjustr(s)
ENDIF
END FUNCTION sadjustr


SUBROUTINE tolower(CDS)
CHARACTER(LEN=*), INTENT(INOUT) :: CDS
INTEGER(KIND=JPIM), PARAMETER :: ICH_A = ichar('a')
INTEGER(KIND=JPIM), PARAMETER :: ICHA  = ichar('A')
INTEGER(KIND=JPIM), PARAMETER :: ICHZ  = ichar('Z')
INTEGER(KIND=JPIM) :: I, ICH, NEW_ICH
CHARACTER(LEN=1) CH
DO i=1,len(cds)
  ch = cds(i:i)
  ich = ichar(ch)
  IF ( ich >= icha .AND. ich <= ichz ) THEN
    new_ich = ich + (ich_a - icha)
    ch = char(new_ich)
    cds(i:i) = ch
  ENDIF
ENDDO
END SUBROUTINE tolower


SUBROUTINE toupper(CDS)
CHARACTER(LEN=*), INTENT(INOUT) :: CDS
INTEGER(KIND=JPIM), PARAMETER :: ICH_A = ichar('A')
INTEGER(KIND=JPIM), PARAMETER :: ICHA  = ichar('a')
INTEGER(KIND=JPIM), PARAMETER :: ICHZ  = ichar('z')
INTEGER(KIND=JPIM) :: I, ICH, NEW_ICH
CHARACTER(LEN=1) CH
DO i=1,len(cds)
  ch = cds(i:i)
  ich = ichar(ch)
  IF ( ich >= icha .AND. ich <= ichz ) THEN
    new_ich = ich + (ich_a - icha)
    ch = char(new_ich)
    cds(i:i) = ch
  ENDIF
ENDDO
END SUBROUTINE toupper


SUBROUTINE expand_string(&
     &MYPROC,               &! %p
     &nproc,                &! %n
     &timestep,             &! %t
     &max_timestep,&
     &s)                   ! %s

INTEGER(KIND=JPIM), INTENT(IN)          :: MYPROC, NPROC
INTEGER(KIND=JPIM), INTENT(IN)          :: TIMESTEP, MAX_TIMESTEP
CHARACTER(LEN=*), INTENT(INOUT) :: S(:)
CHARACTER(LEN=2*LEN(S))  T
CHARACTER(LEN=2*LEN(S)) TT
INTEGER(KIND=JPIM) :: I, J, JJ, LOC_P, LEN_T, N
INTEGER(KIND=JPIM) :: NDIGS(4), NUM(4)
CHARACTER(LEN=6) FMT(4)

n = SIZE(s)

IF (n < 1) RETURN

!*    Setup output formats
num(1) = myproc
num(2) = max(nproc,myproc)
num(3) = n
num(4) = max(max_timestep,timestep)

!*    Count number of digits in each integer
DO j=1,4
  ndigs(j) = 1
  IF (num(j) /= 0) THEN
    ndigs(j) = 1 + log10(dble(abs(num(j))))
    IF (num(j) < 0) ndigs(j) = ndigs(j) + 1 ! Room for minus sign
  ENDIF
  ndigs(j) = min(ndigs(j),9)   ! Max 9 digits supported; i.e. '999999999'
  WRITE(fmt(j),'("(i",i1,")")') ndigs(j)
ENDDO


!*    Expand fields '%s', '%p', '%n' and '%t' with their values


!*    A special treatment with the sequence numbering
IF (n>1) THEN
  loc_p = index(s(1),'%s')
  IF (loc_p > 0) THEN
    s(2:) = s(1)
  ENDIF
ENDIF

DO i=1,n
  t = adjustl(s(i))//' '
  loc_p = index(t,'%')

  IF (loc_p > 0) THEN
    len_t = len_trim(t)
    j = loc_p
    tt(:j-1) = t(:j-1)
    tt(j:) = ' '
    jj = j-1

    DO WHILE (j <= len_t)
      IF (t(j:j) == '%') THEN
        j = j + 1
        IF (j <= len_t) THEN
          SELECT CASE ( t(j:j) )
          CASE ( 'p' )   ! myproc
          WRITE(tt(jj+1:jj+ndigs(1)),fmt(1)) myproc
          jj = jj + ndigs(1)
          CASE ( 'n' )   ! nproc
          WRITE(tt(jj+1:jj+ndigs(2)),fmt(2)) nproc
          jj = jj + ndigs(2)
          CASE ( 's' )   ! sequence number i=[1..n]
          WRITE(tt(jj+1:jj+ndigs(3)),fmt(3)) i
          jj = jj + ndigs(3)
          CASE ( 't' )   ! timestep
          WRITE(tt(jj+1:jj+ndigs(4)),fmt(4)) timestep
          jj = jj + ndigs(4)
          CASE DEFAULT
          tt(jj+1:jj+2) = '%'//t(j:j)
          jj = jj + 2
          END SELECT
        ELSE
          tt(jj+1:jj+1) = '%'
          jj = jj + 1
        ENDIF
      ELSE
        tt(jj+1:jj+1) = t(j:j)
        jj = jj + 1
      ENDIF
      j = j + 1
    ENDDO

    t = adjustl(tt)

!*   Get also rid of any blanks in the middle of the string

    len_t = len_trim(t)
    j = 1
    DO WHILE (j < len_t)
      IF (t(j:j) == ' ') THEN
        t(j:) = t(j+1:)
        len_t = len_trim(t)
      ELSE
        j = j + 1
      ENDIF
    ENDDO

  ENDIF

  s(i) = t
ENDDO

END SUBROUTINE expand_string

END MODULE strhandler_mod