source: branches/UKMO/r6232_tracer_advection/NEMOGCM/EXTERNAL/IOIPSL/src/stringop.f90 @ 9295

Last change on this file since 9295 was 9295, checked in by jcastill, 3 years ago

Remove svn keywords

File size: 5.4 KB
Line 
1MODULE stringop
2!-
3!$Id$
4!-
5! This software is governed by the CeCILL license
6! See IOIPSL/IOIPSL_License_CeCILL.txt
7!---------------------------------------------------------------------
8CONTAINS
9!=
10SUBROUTINE cmpblank (str)
11!---------------------------------------------------------------------
12!- Compact blanks
13!---------------------------------------------------------------------
14  CHARACTER(LEN=*),INTENT(inout) :: str
15!-
16  INTEGER :: lcc,ipb
17!---------------------------------------------------------------------
18  lcc = LEN_TRIM(str)
19  ipb = 1
20  DO
21    IF (ipb >= lcc)   EXIT
22    IF (str(ipb:ipb+1) == '  ') THEN
23      str(ipb+1:) = str(ipb+2:lcc)
24      lcc = lcc-1
25    ELSE
26      ipb = ipb+1
27    ENDIF
28  ENDDO
29!----------------------
30END SUBROUTINE cmpblank
31!===
32INTEGER FUNCTION cntpos (c_c,l_c,c_r,l_r)
33!---------------------------------------------------------------------
34!- Finds number of occurences of c_r in c_c
35!---------------------------------------------------------------------
36  IMPLICIT NONE
37!-
38  CHARACTER(LEN=*),INTENT(in) :: c_c
39  INTEGER,INTENT(IN) :: l_c
40  CHARACTER(LEN=*),INTENT(in) :: c_r
41  INTEGER,INTENT(IN) :: l_r
42!-
43  INTEGER :: ipos,indx
44!---------------------------------------------------------------------
45  cntpos = 0
46  ipos   = 1
47  DO
48    indx = INDEX(c_c(ipos:l_c),c_r(1:l_r))
49    IF (indx > 0) THEN
50      cntpos = cntpos+1
51      ipos   = ipos+indx+l_r-1
52    ELSE
53      EXIT
54    ENDIF
55  ENDDO
56!------------------
57END FUNCTION cntpos
58!===
59INTEGER FUNCTION findpos (c_c,l_c,c_r,l_r)
60!---------------------------------------------------------------------
61!- Finds position of c_r in c_c
62!---------------------------------------------------------------------
63  IMPLICIT NONE
64!-
65  CHARACTER(LEN=*),INTENT(in) :: c_c
66  INTEGER,INTENT(IN) :: l_c
67  CHARACTER(LEN=*),INTENT(in) :: c_r
68  INTEGER,INTENT(IN) :: l_r
69!---------------------------------------------------------------------
70  findpos = INDEX(c_c(1:l_c),c_r(1:l_r))
71  IF (findpos == 0)  findpos=-1
72!-------------------
73END FUNCTION findpos
74!===
75SUBROUTINE find_str (str_tab,str,pos)
76!---------------------------------------------------------------------
77!- This subroutine looks for a string in a table
78!---------------------------------------------------------------------
79!- INPUT
80!-   str_tab  : Table  of strings
81!-   str      : Target we are looking for
82!- OUTPUT
83!-   pos      : -1 if str not found, else value in the table
84!---------------------------------------------------------------------
85  IMPLICIT NONE
86!-
87  CHARACTER(LEN=*),DIMENSION(:),INTENT(in) :: str_tab
88  CHARACTER(LEN=*),INTENT(in) :: str
89  INTEGER,INTENT(out) :: pos
90!-
91  INTEGER :: nb_str,i
92!---------------------------------------------------------------------
93  pos = -1
94  nb_str=SIZE(str_tab)
95  IF ( nb_str > 0 ) THEN
96    DO i=1,nb_str
97      IF ( TRIM(str_tab(i)) == TRIM(str) ) THEN
98        pos = i
99        EXIT
100      ENDIF
101    ENDDO
102  ENDIF
103!----------------------
104END SUBROUTINE find_str
105!===
106SUBROUTINE nocomma (str)
107!---------------------------------------------------------------------
108!- Replace commas with blanks
109!---------------------------------------------------------------------
110  IMPLICIT NONE
111!-
112  CHARACTER(LEN=*) :: str
113!-
114  INTEGER :: i
115!---------------------------------------------------------------------
116  DO i=1,LEN_TRIM(str)
117    IF (str(i:i) == ',')   str(i:i) = ' '
118  ENDDO
119!---------------------
120END SUBROUTINE nocomma
121!===
122SUBROUTINE strlowercase (str)
123!---------------------------------------------------------------------
124!- Converts a string into lowercase
125!---------------------------------------------------------------------
126  IMPLICIT NONE
127!-
128  CHARACTER(LEN=*) :: str
129!-
130  INTEGER :: i,ic
131!---------------------------------------------------------------------
132  DO i=1,LEN_TRIM(str)
133    ic = IACHAR(str(i:i))
134    IF ( (ic >= 65).AND.(ic <= 90) )  str(i:i) = ACHAR(ic+32)
135  ENDDO
136!--------------------------
137END SUBROUTINE strlowercase
138!===
139SUBROUTINE struppercase (str)
140!---------------------------------------------------------------------
141!- Converts a string into uppercase
142!---------------------------------------------------------------------
143  IMPLICIT NONE
144!-
145  CHARACTER(LEN=*) :: str
146!-
147  INTEGER :: i,ic
148!---------------------------------------------------------------------
149  DO i=1,LEN_TRIM(str)
150    ic = IACHAR(str(i:i))
151    IF ( (ic >= 97).AND.(ic <= 122) )  str(i:i) = ACHAR(ic-32)
152  ENDDO
153!--------------------------
154END SUBROUTINE struppercase
155!===
156SUBROUTINE str_xfw (c_string,c_word,l_ok)
157!---------------------------------------------------------------------
158!- Given a character string "c_string", of arbitrary length,
159!- returns a logical flag "l_ok" if a word is found in it,
160!- the first word "c_word" if found and the new string "c_string"
161!- without the first word "c_word"
162!---------------------------------------------------------------------
163  CHARACTER(LEN=*),INTENT(INOUT) :: c_string
164  CHARACTER(LEN=*),INTENT(OUT) :: c_word
165  LOGICAL,INTENT(OUT) :: l_ok
166!-
167  INTEGER :: i_b,i_e
168!---------------------------------------------------------------------
169  l_ok = (LEN_TRIM(c_string) > 0)
170  IF (l_ok) THEN
171    i_b = VERIFY(c_string,' ')
172    i_e = INDEX(c_string(i_b:),' ')
173    IF (i_e == 0) THEN
174      c_word = c_string(i_b:)
175      c_string = ""
176    ELSE
177      c_word = c_string(i_b:i_b+i_e-2)
178      c_string = ADJUSTL(c_string(i_b+i_e-1:))
179    ENDIF
180  ENDIF
181!---------------------
182END SUBROUTINE str_xfw
183!===
184!------------------
185END MODULE stringop
Note: See TracBrowser for help on using the repository browser.