strsuc.f

Go to the documentation of this file.

C> @file
C> @author WOOLLEN @date 1994-01-06
      
C> THIS SUBROUTINE REMOVES LEADING AND TRAILING BLANKS FROM A
C>   STRING.
C>
C> PROGRAM HISTORY LOG:
C> 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
C> 2003-11-04  J. ATOR    -- ADDED DOCUMENTATION
C> 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
C>                           INTERDEPENDENCIES
C> 2003-11-04  D. KEYSER  -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY
C>                           DOCUMENTATION; ADDED MORE COMPLETE
C>                           DIAGNOSTIC INFO WHEN UNUSUAL THINGS HAPPEN
C> 2009-04-21  J. ATOR    -- USE ERRWRT
C>
C> USAGE:    CALL STRSUC (STR1, STR2, LENS)
C>   INPUT ARGUMENT LIST:
C>     STR1     - CHARACTER*(*): STRING
C>
C>   OUTPUT ARGUMENT LIST:
C>     STR2     - CHARACTER*(*): COPY OF STR1 WITH LEADING AND TRAILING
C>                BLANKS REMOVED
C>     LENS     - INTEGER: LENGTH OF STR2:
C>                      -1 = STR1 contained embedded blanks
C>
C> REMARKS:
C>    THIS ROUTINE CALLS:        ERRWRT
C>    THIS ROUTINE IS CALLED BY: DXDUMP   GETTAGRE HOLD4WLC MTFNAM
C>                               MTINFO   NEMSPECS STRNUM   UFDUMP
C>                               Normally not called by any application
C>                               programs but it could be.
C>
      SUBROUTINE strsuc(STR1,STR2,LENS)



      CHARACTER*(*) str1,str2

      COMMON /quiet / iprt

C-----------------------------------------------------------------------
C-----------------------------------------------------------------------

      lens = 0
      lstr = len(str1)

C  FIND THE FIRST NON-BLANK IN THE INPUT STRING
C  --------------------------------------------

      DO i=1,lstr
      IF(str1(i:i).NE.' ') goto 2
      ENDDO
      goto 100

C     Now, starting with the first non-blank in the input string,
C     copy characters from the input string into the output string
C     until reaching the next blank in the input string.

2     DO j=i,lstr
      IF(str1(j:j).EQ.' ') goto 3
      lens = lens+1
      str2(lens:lens) = str1(j:j)
      ENDDO
      goto 100

C     Now, continuing on within the input string, make sure that
C     there are no more non-blank characters.  If there are, then
C     the blank at which we stopped copying from the input string
C     into the output string was an embedded blank.

3     DO i=j,lstr
      IF(str1(i:i).NE.' ') lens = -1
      ENDDO

      IF(lens.EQ.-1 .AND. iprt.GE.0)  THEN
      CALL errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
      CALL errwrt('BUFRLIB: STRSUC - INPUT STRING:')
      CALL errwrt(str1)
      CALL errwrt('CONTAINS ONE OR MORE EMBEDDED BLANKS')
      CALL errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
      CALL errwrt(' ')
      ENDIF

C  EXIT
C  ----

100   RETURN
      END