strings.F

Go to the documentation of this file.

#include "cppdefs.h"
      MODULE strings_mod
!
!git $Id$
!================================================== Hernan G. Arango ===
!  Copyright (c) 2002-2025 The ROMS Group                              !
!    Licensed under a MIT/X style license                              !
!    See License_ROMS.md                                               !
!=======================================================================
!                                                                      !
!  This module contains several string manipulation functions:         !
!                                                                      !
!    FoundError       checks action flag against no-error code         !
!    GlobalError      global check action flag against no-error code   !
!    StandardName     sets standard_name attribute                     !
!    TaskError        task check action flag against no-error code     !
!    assign_string    allocates and assign string                      !
!    find_string      scans a character array for a specified string   !
!    join_string      concatenate character array into a single string !
!    lowercase        converts input string characters to lowercase    !
!    uppercase        converts input string characters to uppercase    !
!                                                                      !
!  Examples:                                                           !
!                                                                      !
!    IF (.not.find_string(var_name,n_var,'spherical',varid)) THEN      !
!      ...                                                             !
!    END IF                                                            !
!                                                                      !
!    string=lowercase('MY UPPERCASE STRING')                           !
!                                                                      !
!    string=uppercase('my lowercase string')                           !
!                                                                      !
!=======================================================================
!
      implicit none
!
      PRIVATE
!
      PUBLIC :: founderror
      PUBLIC :: globalerror
      PUBLIC :: standardname
      PUBLIC :: taskerror
      PUBLIC :: assign_string
      PUBLIC :: find_string
      PUBLIC :: join_string
      PUBLIC :: lowercase
      PUBLIC :: uppercase
!
      CONTAINS
!
      FUNCTION founderror (flag, NoErr, line, routine) RESULT (foundit)
!
!=======================================================================
!                                                                      !
!  This logical function checks ROMS execution flag against no-error   !
!  code and issue a message if they are not equal.                     !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     flag         ROMS execution flag (integer)                       !
!     NoErr        No Error code (integer)                             !
!     line         Calling model routine line (integer)                !
!     routine      Calling model routine (string)                      !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     foundit      The value of the result is TRUE/FALSE if the        !
!                    execution flag is in error.                       !
!                                                                      !
!=======================================================================
!
      USE mod_iounits,  ONLY : stdout
      USE mod_parallel, ONLY : master
!
!  Imported variable declarations.
!
      integer, intent(in) :: flag, noerr, line
 
      character (len=*), intent(in) :: routine
!
!  Local variable declarations.
!
      logical :: foundit
!
!-----------------------------------------------------------------------
!  Scan array for requested string.
!-----------------------------------------------------------------------
!
      foundit=.false.
      IF (flag.ne.noerr) THEN
        foundit=.true.
        IF (master) THEN
          WRITE (stdout,10) flag, line, trim(routine)
  10      FORMAT (' Found Error: ', i0, t20, 'Line: ', i0,              &
     &            t35, 'Source: ', a)
        END IF
        FLUSH (stdout)
      END IF
 
      RETURN
      END FUNCTION founderror
!
      FUNCTION globalerror (ng, model, flag, NoErr, line, routine)      &
     &                     result(foundit)
!
!=======================================================================
!                                                                      !
!  This logical function checks ROMS execution flag against no-error   !
!  code and issue a message if they are not equal. It can be used in   !
!  split, disjointed, distributed-memory communicators.  All process   !
!  in application needs to call this function and the master process   !
!  knows to flag value to broadcast.                                   !
!                                                                      !
!  If not distributed-memory, this function has the same capability    !
!  as FoundError.                                                      !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng           Nested grid number (integer)                        !
!     model        Calling model identifier (integer)                  !
!     flag         ROMS execution flag (integer)                       !
!     NoErr        No Error code (integer)                             !
!     line         Calling model routine line (integer)                !
!     routine      Calling model routine (string)                      !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     flag         Updated flag value to all processes (integer)       !
!     foundit      The value of the result is TRUE/FALSE if the        !
!                    execution flag is in error.                       !
!                                                                      !
!=======================================================================
!
      USE mod_parallel
      USE mod_iounits,    ONLY : stdout
 
#if defined DISTRIBUTE && defined DISJOINTED
      USE distribute_mod, ONLY : mp_barrier, mp_bcasti
#endif
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, model, noerr, line
      integer, intent(inout) :: flag
 
      character (len=*), intent(in) :: routine
!
!  Local variable declarations.
!
      logical :: foundit
      logical :: masterprocess
#ifdef DISTRIBUTE
      integer :: mycomm
#endif
!
!-----------------------------------------------------------------------
!  Set master process.
#ifdef DISTRIBUTE
!  Set distribute-memory communicator and broadcast flag value to all
!  processes.
#endif
!-----------------------------------------------------------------------
!
#ifdef DISTRIBUTE
# ifdef DISJOINTED
      mycomm=full_comm_world
      masterprocess=fullrank.eq.0
# else
      mycomm=ocn_comm_world
      masterprocess=myrank.eq.0
# endif
#else
      masterprocess=master
#endif
#if defined DISTRIBUTE && defined DISJOINTED
!
      CALL mp_bcasti (ng, model, flag, mycomm)
#endif
!
!-----------------------------------------------------------------------
!  Scan array for requested string.
!-----------------------------------------------------------------------
!
      foundit=.false.
      IF (flag.ne.noerr) THEN
        foundit=.true.
        IF (masterprocess) THEN
          WRITE (stdout,10) flag, line, trim(routine)
  10      FORMAT (' Found Error: ', i2.2, t20, 'Line: ', i0,            &
     &            t35, 'Source: ', a)
        END IF
        FLUSH (stdout)
      END IF
 
      RETURN
      END FUNCTION globalerror
!
      FUNCTION taskerror (ng, model, flag, NoErr, line, routine)        &
     &                    result(foundit)
!
!=======================================================================
!                                                                      !
!  This logical function checks ROMS execution flag against no-error   !
!  code and issue a message if they are not equal. It can be used in   !
!  split, disjointed-tasks, distributed-memory communicators.  All     !
!  processes in the task section needs to call this function and its   !
!  master process knows to flag value to broadcast.                    !
!                                                                      !
!  If not distributed-memory, this function has the same capability    !
!  as FoundError and GlobalError.                                      !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng           Nested grid number (integer)                        !
!     model        Calling model identifier (integer)                  !
!     flag         ROMS execution flag (integer)                       !
!     NoErr        No Error code (integer)                             !
!     line         Calling model routine line (integer)                !
!     routine      Calling model routine (string)                      !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     flag         Updated flag value to all processes (integer)       !
!     foundit      The value of the result is TRUE/FALSE if the        !
!                    execution flag is in error.                       !
!                                                                      !
!=======================================================================
!
      USE mod_parallel
      USE mod_iounits,    ONLY : stdout
 
#if defined DISTRIBUTE && defined DISJOINTED
      USE distribute_mod, ONLY : mp_barrier, mp_bcasti
#endif
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, model, noerr, line
      integer, intent(inout) :: flag
 
      character (len=*), intent(in) :: routine
!
!  Local variable declarations.
!
      logical :: foundit
      logical :: masterprocess
#ifdef DISTRIBUTE
      integer :: mycomm
#endif
!
!-----------------------------------------------------------------------
!  Set master process.
#ifdef DISTRIBUTE
!  Set distribute-memory communicator and broadcast flag value to all
!  processes.
#endif
!-----------------------------------------------------------------------
!
#ifdef DISTRIBUTE
# ifdef DISJOINTED
#  ifdef CONCURRENT_KERNEL
      mycomm=task_comm_world
      masterprocess=taskrank.eq.0
#  else
      mycomm=full_comm_world
      masterprocess=fullrank.eq.0
#  endif
# else
      mycomm=ocn_comm_world
      masterprocess=myrank.eq.0
# endif
#else
      masterprocess=master
#endif
#if defined DISTRIBUTE && defined DISJOINTED
!
      CALL mp_bcasti (ng, model, flag, mycomm)
#endif
!
!-----------------------------------------------------------------------
!  Scan array for requested string.
!-----------------------------------------------------------------------
!
      foundit=.false.
      IF (flag.ne.noerr) THEN
        foundit=.true.
        IF (masterprocess) THEN
          WRITE (stdout,10) flag, line, trim(routine)
  10      FORMAT (' Found Error: ', i2.2, t20, 'Line: ', i0,            &
     &            t35, 'Source: ', a)
        END IF
        FLUSH (stdout)
      END IF
 
      RETURN
      END FUNCTION taskerror
!
      SUBROUTINE standardname (Sname, variable, prefix, suffix)
!
!=======================================================================
!                                                                      !
!  This routine concatenates prefix and suffix strings to generate the !
!  'standard_name' attribute. Blank spaces in the prefix are replaced  !
!  with underscore.                                                    !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     variable     Standard name main variable (character)             !
!     prefix       Standard name prefix (OPTIONAL, character)          !
!     suffix       Standard name suffix (OPTIONAL, character)          !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     Sname        concatenated standard name (character)              !
!                                                                      !
!=======================================================================
!
!  Imported variable declarations.
!
      character (len=*), intent(in) :: variable
      character (len=*), optional, intent(in) :: prefix
      character (len=*), optional, intent(in) :: suffix
      character (len=*), intent(out) :: sname
!
!  Local variable declarations.
!
      integer :: icomma, lstr, i
!
!-----------------------------------------------------------------------
!  Generate 'standard_name' attribute.
!-----------------------------------------------------------------------
!
      DO i=1,len(sname)
        sname(i:i)=char(32)
      END DO
!
!  Replace blank space with underscore, CHAR(95).
!
      lstr=len_trim(variable)
      icomma=index(variable,char(44),back=.false.)
      IF (icomma.gt.0) THEN                               ! remove comma
        sname=variable(1:icomma-1) // variable(icomma+1:lstr)
        lstr=len_trim(sname)
      ELSE
        sname(1:lstr)=variable(1:lstr)
      END IF
!
      DO i=1,lstr
        IF (sname(i:i).eq.char(32)) THEN
          sname(i:i)=char(95)
        END IF
      END DO
!
!  Append prefix and or suffix string(s).
 
      IF (PRESENT(prefix)) THEN
        sname=trim(adjustl(prefix)) // trim(adjustl(sname))
      END IF
!
      IF (PRESENT(suffix)) THEN
        sname=trim(adjustl(sname)) // trim(adjustl(suffix))
      END IF
!
      RETURN
      END SUBROUTINE standardname
!
      FUNCTION assign_string (A, string) RESULT (ErrFlag)
!
!=======================================================================
!                                                                      !
!  This routine assigns allocatable strings.  It allocates/reallocates !
!  output string variable.                                             !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     string       String to be assigned (character)                   !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     A            Assigned allocatable string (character)             !
!     ErrFlag      Error flag (integer)                                !
!                                                                      !
!=======================================================================
!
!  Imported variable declarations.
!
      character (len=:), allocatable, intent(inout) :: a
      character (len=*), intent(in) :: string
!
!  Local variable declarations.
!
      integer :: lstr
      integer :: errflag
!
!-----------------------------------------------------------------------
!  Allocate output string to the size of input string.
!-----------------------------------------------------------------------
!
      errflag=-1
!
      lstr=len_trim(string)
      IF (.not.allocated(a)) THEN
        allocate ( character(LEN=lstr) :: a, stat=errflag)
      ELSE
        deallocate (a)
        allocate ( character(LEN=lstr) :: a, stat=errflag)
      END IF
!
!  Assign requested value.
!
      a=string
!
      RETURN
      END FUNCTION assign_string
!
      FUNCTION find_string (A, Asize, string, Aindex) RESULT (foundit)
!
!=======================================================================
!                                                                      !
!  This logical function scans an array of type character for an       !
!  specific string.                                                    !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     A            Array of strings (character)                        !
!     Asize        Size of A (integer)                                 !
!     string       String to search (character)                        !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     Aindex       Array element containing the string (integer)       !
!     foundit      The value of the result is TRUE/FALSE if the        !
!                    string was found or not.                          !
!                                                                      !
!=======================================================================
!
!  Imported variable declarations.
!
      integer, intent(in) :: asize
 
      integer, intent(out) :: aindex
 
      character (len=*), intent(in) :: a(asize)
      character (len=*), intent(in) :: string
!
!  Local variable declarations.
!
      logical :: foundit
 
      integer :: i
!
!-----------------------------------------------------------------------
!  Scan array for requested string.
!-----------------------------------------------------------------------
!
      foundit=.false.
      aindex=0
      DO i=1,asize
        IF (trim(a(i)).eq.trim(string)) THEN
          foundit=.true.
          aindex=i
          EXIT
        END IF
      END DO
 
      RETURN
      END FUNCTION find_string
!
      SUBROUTINE join_string (A, Asize, string, Lstring)
!
!=======================================================================
!                                                                      !
!  This routine concatenate a character array into a single string     !
!  with each element separated by commas.                              !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     A            Array of strings (character)                        !
!     Asize        Size of A (integer)                                 !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     string       Concatenated string (character)                     !
!     Lstring      Length of concatenated string (integer)             !
!                                                                      !
!=======================================================================
!
!  Imported variable declarations.
!
      integer, intent(in) :: asize
 
      integer, intent(out) :: lstring
 
      character (len=*), intent(in) :: a(asize)
      character (len=*), intent(out) :: string
!
!  Local variable declarations.
!
      integer :: i, ie, is, lstr
!
!-----------------------------------------------------------------------
!  Concatenate input character array.
!-----------------------------------------------------------------------
!
!  Initialize to blank string.
!
      lstr=len(string)
      DO i=1,lstr
        string(i:i)=' '
      END DO
!
!  Concatenate.
!
      is=1
      DO i=1,asize
        lstr=len_trim(a(i))
        IF (lstr.gt.0) THEN
          ie=is+lstr-1
          string(is:ie)=trim(a(i))
          is=ie+1
          string(is:is)=','
          is=is+2
        END IF
      END DO
      lstring=len_trim(string)-1
 
      RETURN
      END SUBROUTINE join_string
!
      FUNCTION lowercase (Sinp) RESULT (Sout)
!
!=======================================================================
!                                                                      !
!  This character function converts input string elements to           !
!  lowercase.                                                          !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     Sinp       String with uppercase elements (character)            !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     Sout       Lowercase string (character)                          !
!                                                                      !
!  Reference:                                                          !
!                                                                      !
!     Cooper Redwine, 1995: "Upgrading to Fortran 90", Springer-       !
!       Verlag, New York, pp 416.                                      !
!                                                                      !
!=======================================================================
!
!  Imported variable declarations.
!
      character (*), intent(in) :: sinp
!
!  Local variable definitions.
!
      integer :: i, j, lstr
 
      character (LEN(Sinp)) :: sout
 
      character (26), parameter :: lcase = 'abcdefghijklmnopqrstuvwxyz'
      character (26), parameter :: ucase = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
!
!-----------------------------------------------------------------------
!  Convert input string to lowercase.
!-----------------------------------------------------------------------
!
      lstr=len(sinp)
      sout=sinp
      DO i=1,lstr
        j=index(ucase, sout(i:i))
        IF (j.ne.0) THEN
          sout(i:i)=lcase(j:j)
        END IF
      END DO
 
      RETURN
      END FUNCTION lowercase
!
      FUNCTION uppercase (Sinp) RESULT (Sout)
!
!=======================================================================
!                                                                      !
!  This character function converts input string elements to           !
!  uppercase.                                                          !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     Sinp       String with lowercase characters (character)          !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     Sout       Uppercase string (character)                          !
!                                                                      !
!  Reference:                                                          !
!                                                                      !
!     Cooper Redwine, 1995: "Upgrading to Fortran 90", Springer-       !
!       Verlag, New York, pp 416.                                      !
!                                                                      !
!=======================================================================
!
!  Imported variable declarations.
!
      character (*), intent(in) :: sinp
!
!  Local variable definitions.
!
      integer :: i, j, lstr
 
      character (LEN(Sinp)) :: sout
 
      character (26), parameter :: lcase = 'abcdefghijklmnopqrstuvwxyz'
      character (26), parameter :: ucase = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
!
!-----------------------------------------------------------------------
!  Convert input string to uppercase.
!-----------------------------------------------------------------------
!
      lstr=len(sinp)
      sout=sinp
      DO i=1,lstr
        j=index(lcase, sout(i:i))
        IF (j.ne.0) THEN
          sout(i:i)=ucase(j:j)
        END IF
      END DO
 
      RETURN
      END FUNCTION uppercase
 
      END MODULE strings_mod