libf/IOIPSL/stringop.f90

MODULE stringop

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