source: LMDZ4/trunk/libf/bibio/ioipsl_stringop.F90

Last change on this file was 1279, checked in by Laurent Fairhead, 15 years ago

Merged LMDZ4-dev branch changes r1241:1278 into the trunk
Running trunk and LMDZ4-dev in LMDZOR configuration on local
machine (sequential) and SX8 (4-proc) yields identical results
(restart and restartphy are identical binarily)
Log history from r1241 to r1278 is available by switching to
source:LMDZ4/branches/LMDZ4-dev-20091210

File size: 7.1 KB
RevLine 
[1140]1!
[1186]2! $Id$
3!
4! Module/Routines extracted from IOIPSL v2_1_8
5!
[1140]6MODULE ioipsl_stringop
[1186]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
[1140]12!---------------------------------------------------------------------
13!-
[1186]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/)
[1140]17!-
18!---------------------------------------------------------------------
19CONTAINS
20!=
[1186]21SUBROUTINE cmpblank (str)
[1140]22!---------------------------------------------------------------------
[1186]23!- Compact blanks
[1140]24!---------------------------------------------------------------------
[1186]25  CHARACTER(LEN=*),INTENT(inout) :: str
[1140]26!-
[1186]27  INTEGER :: lcc,ipb
[1140]28!---------------------------------------------------------------------
[1186]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)
[1140]44!---------------------------------------------------------------------
45!- Finds number of occurences of c_r in c_c
46!---------------------------------------------------------------------
[1186]47  IMPLICIT NONE
[1140]48!-
[1186]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
[1140]53!-
[1186]54  INTEGER :: ipos,indx
[1140]55!---------------------------------------------------------------------
[1186]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)
[1140]71!---------------------------------------------------------------------
72!- Finds position of c_r in c_c
73!---------------------------------------------------------------------
[1186]74  IMPLICIT NONE
[1140]75!-
[1186]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
[1140]80!---------------------------------------------------------------------
[1186]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)
[1140]87!---------------------------------------------------------------------
88!- This subroutine looks for a string in a table
89!---------------------------------------------------------------------
90!- INPUT
[1186]91!-   str_tab  : Table  of strings
92!-   str      : Target we are looking for
[1140]93!- OUTPUT
[1186]94!-   pos      : -1 if str not found, else value in the table
[1140]95!---------------------------------------------------------------------
[1186]96  IMPLICIT NONE
[1140]97!-
[1186]98  CHARACTER(LEN=*),DIMENSION(:),INTENT(in) :: str_tab
99  CHARACTER(LEN=*),INTENT(in) :: str
100  INTEGER,INTENT(out) :: pos
[1140]101!-
[1186]102  INTEGER :: nb_str,i
[1140]103!---------------------------------------------------------------------
[1186]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)
[1140]118!---------------------------------------------------------------------
[1186]119!- Replace commas with blanks
[1140]120!---------------------------------------------------------------------
[1186]121  IMPLICIT NONE
[1140]122!-
[1186]123  CHARACTER(LEN=*) :: str
[1140]124!-
[1186]125  INTEGER :: i
[1140]126!---------------------------------------------------------------------
[1186]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)
[1140]134!---------------------------------------------------------------------
135!- Converts a string into lowercase
136!---------------------------------------------------------------------
[1186]137  IMPLICIT NONE
[1140]138!-
[1186]139  CHARACTER(LEN=*) :: str
[1140]140!-
[1186]141  INTEGER :: i,ic
[1140]142!---------------------------------------------------------------------
[1186]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)
[1140]151!---------------------------------------------------------------------
152!- Converts a string into uppercase
153!---------------------------------------------------------------------
[1186]154  IMPLICIT NONE
[1140]155!-
[1186]156  CHARACTER(LEN=*) :: str
[1140]157!-
[1186]158  INTEGER :: i,ic
[1140]159!---------------------------------------------------------------------
[1186]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)
[1140]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!---------------------------------------------------------------------
[1186]173  IMPLICIT NONE
[1140]174!-
[1186]175  CHARACTER(LEN=*) :: str
176  INTEGER          :: sig
[1140]177!-
[1186]178  INTEGER :: i
[1140]179!---------------------------------------------------------------------
[1186]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)
[1140]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
[1186]194!-   str         : Target string we are looking for
[1140]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!---------------------------------------------------------------------
[1186]200  IMPLICIT NONE
[1140]201!-
[1186]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
[1140]207!-
[1186]208  INTEGER :: pos
209  INTEGER,DIMENSION(nb_sig) :: loczeros
[1140]210!-
[1186]211  INTEGER :: il,len
212  INTEGER,DIMENSION(1) :: minpos
[1140]213!---------------------------------------------------------------------
[1186]214  pos = -1
215  il = LEN_TRIM(str)
[1140]216!-
[1186]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)
[1140]225      ENDIF
[1186]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!-----------------------
[1140]240 END SUBROUTINE find_sig
[1186]241!===
[1140]242!------------------
243END MODULE ioipsl_stringop
Note: See TracBrowser for help on using the repository browser.