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

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

JB: some cleaning (-> fortran 90)
  • Property svn:keywords set to Id
File size: 6.9 KB
Line 
1MODULE stringop
2!-
3!$Id$
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 (str_tab,str,pos)
79!---------------------------------------------------------------------
80!- This subroutine looks for a string in a table
81!---------------------------------------------------------------------
82!- INPUT
83!-   str_tab  : Table  of strings
84!-   str      : Target we are looking for
85!- OUTPUT
86!-   pos      : -1 if str not found, else value in the table
87!---------------------------------------------------------------------
88  IMPLICIT NONE
89!-
90  CHARACTER(LEN=*),DIMENSION(:),INTENT(in) :: str_tab
91  CHARACTER(LEN=*),INTENT(in) :: str
92  INTEGER,INTENT(out) :: pos
93!-
94  INTEGER :: nb_str,i
95!---------------------------------------------------------------------
96  pos = -1
97  nb_str=SIZE(str_tab)
98  IF ( nb_str > 0 ) THEN
99    DO i=1,nb_str
100      IF ( TRIM(str_tab(i)) == TRIM(str) ) THEN
101        pos = i
102        EXIT
103      ENDIF
104    ENDDO
105  ENDIF
106!----------------------
107END SUBROUTINE find_str
108!===
109SUBROUTINE nocomma (str)
110!---------------------------------------------------------------------
111!- Replace commas with blanks
112!---------------------------------------------------------------------
113  IMPLICIT NONE
114!-
115  CHARACTER(LEN=*) :: str
116!-
117  INTEGER :: i
118!---------------------------------------------------------------------
119  DO i=1,LEN_TRIM(str)
120    IF (str(i:i) == ',')   str(i:i) = ' '
121  ENDDO
122!---------------------
123END SUBROUTINE nocomma
124!===
125SUBROUTINE strlowercase (str)
126!---------------------------------------------------------------------
127!- Converts a string into lowercase
128!---------------------------------------------------------------------
129  IMPLICIT NONE
130!-
131  CHARACTER(LEN=*) :: str
132!-
133  INTEGER :: i,ic
134!---------------------------------------------------------------------
135  DO i=1,LEN_TRIM(str)
136    ic = IACHAR(str(i:i))
137    IF ( (ic >= 65).AND.(ic <= 90) )  str(i:i) = ACHAR(ic+32)
138  ENDDO
139!--------------------------
140END SUBROUTINE strlowercase
141!===
142SUBROUTINE struppercase (str)
143!---------------------------------------------------------------------
144!- Converts a string into uppercase
145!---------------------------------------------------------------------
146  IMPLICIT NONE
147!-
148  CHARACTER(LEN=*) :: str
149!-
150  INTEGER :: i,ic
151!---------------------------------------------------------------------
152  DO i=1,LEN_TRIM(str)
153    ic = IACHAR(str(i:i))
154    IF ( (ic >= 97).AND.(ic <= 122) )  str(i:i) = ACHAR(ic-32)
155  ENDDO
156!--------------------------
157END SUBROUTINE struppercase
158!===
159SUBROUTINE gensig (str,sig)
160!---------------------------------------------------------------------
161!- Generate a signature from the first 30 characters of the string
162!- This signature is not unique and thus when one looks for the
163!- one needs to also verify the string.
164!---------------------------------------------------------------------
165  IMPLICIT NONE
166!-
167  CHARACTER(LEN=*) :: str
168  INTEGER          :: sig
169!-
170  INTEGER :: i
171!---------------------------------------------------------------------
172  sig = 0
173  DO i=1,MIN(LEN_TRIM(str),30)
174    sig = sig + prime(i)*IACHAR(str(i:i))
175  ENDDO
176!--------------------
177END SUBROUTINE gensig
178!===
179SUBROUTINE find_sig (nb_sig,str_tab,str,sig_tab,sig,pos)
180!---------------------------------------------------------------------
181!- Find the string signature in a list of signatures
182!---------------------------------------------------------------------
183!- INPUT
184!-   nb_sig      : length of table of signatures
185!-   str_tab     : Table of strings
186!-   str         : Target string we are looking for
187!-   sig_tab     : Table of signatures
188!-   sig         : Target signature we are looking for
189!- OUTPUT
190!-   pos         : -1 if str not found, else value in the table
191!---------------------------------------------------------------------
192  IMPLICIT NONE
193!-
194  INTEGER :: nb_sig
195  CHARACTER(LEN=*),DIMENSION(nb_sig) :: str_tab
196  CHARACTER(LEN=*) :: str
197  INTEGER,DIMENSION(nb_sig) :: sig_tab
198  INTEGER :: sig
199!-
200  INTEGER :: pos
201  INTEGER,DIMENSION(nb_sig) :: loczeros
202!-
203  INTEGER :: il,len
204  INTEGER,DIMENSION(1) :: minpos
205!---------------------------------------------------------------------
206  pos = -1
207  il = LEN_TRIM(str)
208!-
209  IF ( nb_sig > 0 ) THEN
210    loczeros = ABS(sig_tab(1:nb_sig)-sig)
211    IF ( COUNT(loczeros < 1) == 1 ) THEN
212      minpos = MINLOC(loczeros)
213      len = LEN_TRIM(str_tab(minpos(1)))
214      IF (     (INDEX(str_tab(minpos(1)),str(1:il)) > 0) &
215          .AND.(len == il) ) THEN
216        pos = minpos(1)
217      ENDIF
218    ELSE IF ( COUNT(loczeros < 1) > 1 ) THEN
219      DO WHILE (COUNT(loczeros < 1) >= 1 .AND. pos < 0 )
220        minpos = MINLOC(loczeros)
221        len = LEN_TRIM(str_tab(minpos(1)))
222        IF (     (INDEX(str_tab(minpos(1)),str(1:il)) > 0) &
223            .AND.(len == il) ) THEN
224          pos = minpos(1)
225        ELSE
226          loczeros(minpos(1)) = 99999
227        ENDIF
228      ENDDO
229    ENDIF
230  ENDIF
231!-----------------------
232 END SUBROUTINE find_sig
233!===
234!------------------
235END MODULE stringop
Note: See TracBrowser for help on using the repository browser.