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