NCEPLIBS-bufr  11.7.0
 All Data Structures Files Functions Variables Pages
strsuc.f
Go to the documentation of this file.
1 C> @file
2 C> @brief Remove leading and trailing blanks from a character string
3 
4 C> This subroutine removes leading and trailing blanks from a
5 C> character string. The string may not contain any embedded blanks.
6 C>
7 C> @author J. Woollen
8 C> @date 1994-01-06
9 C>
10 C> @param[in] STR1 -- character*(*): String
11 C> @param[out] STR2 -- character*(*): Copy of STR1 with leading and
12 C> trailing blanks removed
13 C> @param[out] LENS -- integer: Length of STR2
14 C> - -1 = STR1 contained embedded blanks
15 C>
16 C> <b>Program History Log:</b>
17 C> | Date | Programmer | Comments |
18 C> | -----|------------|----------|
19 C> | 1994-01-06 | J. Woollen | Original author
20 C> | 2003-11-04 | J. Ator | Added documentation
21 C> | 2009-04-21 | J. Ator | Use errwrt()
22 C>
23  SUBROUTINE strsuc(STR1,STR2,LENS)
24 
25  CHARACTER*(*) str1,str2
26 
27  COMMON /quiet / iprt
28 
29 C-----------------------------------------------------------------------
30 C-----------------------------------------------------------------------
31 
32  lens = 0
33  lstr = len(str1)
34 
35 C FIND THE FIRST NON-BLANK IN THE INPUT STRING
36 C --------------------------------------------
37 
38  DO i=1,lstr
39  IF(str1(i:i).NE.' ') goto 2
40  ENDDO
41  goto 100
42 
43 C Now, starting with the first non-blank in the input string,
44 C copy characters from the input string into the output string
45 C until reaching the next blank in the input string.
46 
47 2 DO j=i,lstr
48  IF(str1(j:j).EQ.' ') goto 3
49  lens = lens+1
50  str2(lens:lens) = str1(j:j)
51  ENDDO
52  goto 100
53 
54 C Now, continuing on within the input string, make sure that
55 C there are no more non-blank characters. If there are, then
56 C the blank at which we stopped copying from the input string
57 C into the output string was an embedded blank.
58 
59 3 DO i=j,lstr
60  IF(str1(i:i).NE.' ') lens = -1
61  ENDDO
62 
63  IF(lens.EQ.-1 .AND. iprt.GE.0) THEN
64  CALL errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
65  CALL errwrt('BUFRLIB: STRSUC - INPUT STRING:')
66  CALL errwrt(str1)
67  CALL errwrt('CONTAINS ONE OR MORE EMBEDDED BLANKS')
68  CALL errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
69  CALL errwrt(' ')
70  ENDIF
71 
72 C EXIT
73 C ----
74 
75 100 RETURN
76  END
subroutine strsuc(STR1, STR2, LENS)
This subroutine removes leading and trailing blanks from a character string.
Definition: strsuc.f:23
subroutine errwrt(STR)
This subroutine allows the user to specify a custom location for the logging of error and diagnostic ...
Definition: errwrt.f:41