source: trunk/libf/bibio/ioipsl_stringop.F90 @ 6

Last change on this file since 6 was 1, checked in by emillour, 14 years ago

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