source: IOIPSL/trunk/src/stringop.f90 @ 6

Last change on this file since 6 was 6, checked in by bellier, 17 years ago

new version to test svn
File size: 7.1 KB
Line 
1!$ID$
2!-
3MODULE stringop
4!---------------------------------------------------------------------
5!-
6  INTEGER,DIMENSION(30) :: &
7 & prime=(/1,2,3,5,7,11,13,17,19,23,29,31,37,41,43, &
8 & 47,53,59,61,67,71,73,79,83,89,97,101,103,107,109/)
9!-
10!---------------------------------------------------------------------
11CONTAINS
12!=
13SUBROUTINE cmpblank (str)
14!---------------------------------------------------------------------
15!- Compact blanks
16!---------------------------------------------------------------------
17  CHARACTER(LEN=*),INTENT(inout) :: str
18!-
19  INTEGER :: lcc,ipb
20!---------------------------------------------------------------------
21  lcc = LEN_TRIM(str)
22  ipb = 1
23  DO
24    IF (ipb >= lcc)   EXIT
25    IF (str(ipb:ipb+1) == '  ') THEN
26      str(ipb+1:) = str(ipb+2:lcc)
27      lcc = lcc-1
28    ELSE
29      ipb = ipb+1
30    ENDIF
31  ENDDO
32!----------------------
33END SUBROUTINE cmpblank
34!===
35INTEGER FUNCTION cntpos (c_c,l_c,c_r,l_r)
36!---------------------------------------------------------------------
37!- Finds number of occurences of c_r in c_c
38!---------------------------------------------------------------------
39  IMPLICIT NONE
40!-
41  CHARACTER(LEN=*),INTENT(in) :: c_c
42  INTEGER,INTENT(IN) :: l_c
43  CHARACTER(LEN=*),INTENT(in) :: c_r
44  INTEGER,INTENT(IN) :: l_r
45!-
46  INTEGER :: ipos,indx
47!---------------------------------------------------------------------
48  cntpos = 0
49  ipos   = 1
50  DO
51    indx = INDEX(c_c(ipos:l_c),c_r(1:l_r))
52    IF (indx > 0) THEN
53      cntpos = cntpos+1
54      ipos   = ipos+indx+l_r-1
55    ELSE
56      EXIT
57    ENDIF
58  ENDDO
59!------------------
60END FUNCTION cntpos
61!===
62INTEGER FUNCTION findpos (c_c,l_c,c_r,l_r)
63!---------------------------------------------------------------------
64!- Finds position of c_r in c_c
65!---------------------------------------------------------------------
66  IMPLICIT NONE
67!-
68  CHARACTER(LEN=*),INTENT(in) :: c_c
69  INTEGER,INTENT(IN) :: l_c
70  CHARACTER(LEN=*),INTENT(in) :: c_r
71  INTEGER,INTENT(IN) :: l_r
72!---------------------------------------------------------------------
73  findpos = INDEX(c_c(1:l_c),c_r(1:l_r))
74  IF (findpos == 0)  findpos=-1
75!-------------------
76END FUNCTION findpos
77!===
78SUBROUTINE find_str (nb_str,str_tab,str_len_tab,str,pos)
79!---------------------------------------------------------------------
80!- This subroutine looks for a string in a table
81!---------------------------------------------------------------------
82!- INPUT
83!-   nb_str      : length of table
84!-   str_tab     : Table  of strings
85!-   str_len_tab : Table  of string-length
86!-   str         : Target we are looking for
87!- OUTPUT
88!-   pos         : -1 if str not found, else value in the table
89!---------------------------------------------------------------------
90  IMPLICIT NONE
91!-
92  INTEGER :: nb_str
93  CHARACTER(LEN=*),DIMENSION(nb_str) :: str_tab
94  INTEGER,DIMENSION(nb_str) :: str_len_tab
95  CHARACTER(LEN=*) :: str
96  INTEGER :: pos
97!-
98  INTEGER :: i,il
99!---------------------------------------------------------------------
100  pos = -1
101  il = LEN_TRIM(str)
102  IF ( nb_str > 0 ) THEN
103    DO i=1,nb_str
104      IF (     (INDEX(str_tab(i),str(1:il)) > 0) &
105          .AND.(str_len_tab(i) == il) ) THEN
106        pos = i
107        EXIT
108      ENDIF
109    ENDDO
110  ENDIF
111!----------------------
112END SUBROUTINE find_str
113!===
114SUBROUTINE nocomma (str)
115!---------------------------------------------------------------------
116!- Replace commas with blanks
117!---------------------------------------------------------------------
118  IMPLICIT NONE
119!-
120  CHARACTER(LEN=*) :: str
121!-
122  INTEGER :: i
123!---------------------------------------------------------------------
124  DO i=1,LEN_TRIM(str)
125    IF (str(i:i) == ',')   str(i:i) = ' '
126  ENDDO
127!---------------------
128END SUBROUTINE nocomma
129!===
130SUBROUTINE strlowercase (str)
131!---------------------------------------------------------------------
132!- Converts a string into lowercase
133!---------------------------------------------------------------------
134  IMPLICIT NONE
135!-
136  CHARACTER(LEN=*) :: str
137!-
138  INTEGER :: i,ic
139!---------------------------------------------------------------------
140  DO i=1,LEN_TRIM(str)
141    ic = IACHAR(str(i:i))
142    IF ( (ic >= 65).AND.(ic <= 90) )  str(i:i) = ACHAR(ic+32)
143  ENDDO
144!--------------------------
145END SUBROUTINE strlowercase
146!===
147SUBROUTINE struppercase (str)
148!---------------------------------------------------------------------
149!- Converts a string into uppercase
150!---------------------------------------------------------------------
151  IMPLICIT NONE
152!-
153  CHARACTER(LEN=*) :: str
154!-
155  INTEGER :: i,ic
156!---------------------------------------------------------------------
157  DO i=1,LEN_TRIM(str)
158    ic = IACHAR(str(i:i))
159    IF ( (ic >= 97).AND.(ic <= 122) )  str(i:i) = ACHAR(ic-32)
160  ENDDO
161!--------------------------
162END SUBROUTINE struppercase
163!===
164SUBROUTINE gensig (str,sig)
165!---------------------------------------------------------------------
166!- Generate a signature from the first 30 characters of the string
167!- This signature is not unique and thus when one looks for the
168!- one needs to also verify the string.
169!---------------------------------------------------------------------
170  IMPLICIT NONE
171!-
172  CHARACTER(LEN=*) :: str
173  INTEGER          :: sig
174!-
175  INTEGER :: i
176!---------------------------------------------------------------------
177  sig = 0
178  DO i=1,MIN(LEN_TRIM(str),30)
179    sig = sig + prime(i)*IACHAR(str(i:i))
180  ENDDO
181!--------------------
182END SUBROUTINE gensig
183!===
184SUBROUTINE find_sig (nb_sig,str_tab,str,sig_tab,sig,pos)
185!---------------------------------------------------------------------
186!- Find the string signature in a list of signatures
187!---------------------------------------------------------------------
188!- INPUT
189!-   nb_sig      : length of table of signatures
190!-   str_tab     : Table of strings
191!-   str         : Target string we are looking for
192!-   sig_tab     : Table of signatures
193!-   sig         : Target signature we are looking for
194!- OUTPUT
195!-   pos         : -1 if str not found, else value in the table
196!---------------------------------------------------------------------
197  IMPLICIT NONE
198!-
199  INTEGER :: nb_sig
200  CHARACTER(LEN=*),DIMENSION(nb_sig) :: str_tab
201  CHARACTER(LEN=*) :: str
202  INTEGER,DIMENSION(nb_sig) :: sig_tab
203  INTEGER :: sig
204!-
205  INTEGER :: pos
206  INTEGER,DIMENSION(nb_sig) :: loczeros
207!-
208  INTEGER :: il,len
209  INTEGER,DIMENSION(1) :: minpos
210!---------------------------------------------------------------------
211  pos = -1
212  il = LEN_TRIM(str)
213!-
214  IF ( nb_sig > 0 ) THEN
215    loczeros = ABS(sig_tab(1:nb_sig)-sig)
216    IF ( COUNT(loczeros < 1) == 1 ) THEN
217      minpos = MINLOC(loczeros)
218      len = LEN_TRIM(str_tab(minpos(1)))
219      IF (     (INDEX(str_tab(minpos(1)),str(1:il)) > 0) &
220          .AND.(len == il) ) THEN
221        pos = minpos(1)
222      ENDIF
223    ELSE IF ( COUNT(loczeros < 1) > 1 ) THEN
224      DO WHILE (COUNT(loczeros < 1) >= 1 .AND. pos < 0 )
225        minpos = MINLOC(loczeros)
226        len = LEN_TRIM(str_tab(minpos(1)))
227        IF (     (INDEX(str_tab(minpos(1)),str(1:il)) > 0) &
228            .AND.(len == il) ) THEN
229          pos = minpos(1)
230        ELSE
231          loczeros(minpos(1)) = 99999
232        ENDIF
233      ENDDO
234    ENDIF
235  ENDIF
236!-----------------------
237 END SUBROUTINE find_sig
238!===
239!------------------
240END MODULE stringop
Note: See TracBrowser for help on using the repository browser.