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

Last change on this file since 4863 was 4863, checked in by jgipsl, 4 years ago

Following changes have been done by A.Jornet/LSCE. No change is results and no change in usage have been seen. Some more error checking might stop the model for example if dimensions are not correct in call to histcom module.

Restcom:

  • Define a new var size length (20 to 100 )→ pbs found without no errors
  • Raise an error when var name is too long
  • Deallocate any buffer at the end of all restput/restcget calls → buffers only increase size. After loading/saving nothing is done with this memory

Histcom:

  • Raise an error if given history declared variables do not match with given dimensions from histwrite

getincom and stringop:

  • Enable any length character for the run.def → useful for long filepaths

flincom

  • Enable filenames longer than 80 chars to any
  • Deallocate buffers at the end of any flinget subroutine
  • Property svn:keywords set to Id
File size: 6.0 KB
Line 
1MODULE stringop
2!-
3!$Id$
4!-
5! This software is governed by the CeCILL license
6! See IOIPSL/IOIPSL_License_CeCILL.txt
7!---------------------------------------------------------------------
8CHARACTER(LEN=1), PARAMETER :: COMMENT_TAG = "#" ! Comment symbol
9
10CONTAINS
11!=
12SUBROUTINE cmpblank (str)
13!---------------------------------------------------------------------
14!- Compact blanks
15!---------------------------------------------------------------------
16  CHARACTER(LEN=*),INTENT(inout) :: str
17!-
18  INTEGER :: lcc,ipb
19!---------------------------------------------------------------------
20  lcc = LEN_TRIM(str)
21  ipb = 1
22  DO
23    IF (ipb >= lcc)   EXIT
24    IF (str(ipb:ipb+1) == '  ') THEN
25      str(ipb+1:) = str(ipb+2:lcc)
26      lcc = lcc-1
27    ELSE
28      ipb = ipb+1
29    ENDIF
30  ENDDO
31!----------------------
32END SUBROUTINE cmpblank
33!===
34INTEGER FUNCTION cntpos (c_c,l_c,c_r,l_r)
35!---------------------------------------------------------------------
36!- Finds number of occurences of c_r in c_c
37!---------------------------------------------------------------------
38  IMPLICIT NONE
39!-
40  CHARACTER(LEN=*),INTENT(in) :: c_c
41  INTEGER,INTENT(IN) :: l_c
42  CHARACTER(LEN=*),INTENT(in) :: c_r
43  INTEGER,INTENT(IN) :: l_r
44!-
45  INTEGER :: ipos,indx
46!---------------------------------------------------------------------
47  cntpos = 0
48  ipos   = 1
49  DO
50    indx = INDEX(c_c(ipos:l_c),c_r(1:l_r))
51    IF (indx > 0) THEN
52      cntpos = cntpos+1
53      ipos   = ipos+indx+l_r-1
54    ELSE
55      EXIT
56    ENDIF
57  ENDDO
58!------------------
59END FUNCTION cntpos
60!===
61INTEGER FUNCTION findpos (c_c,l_c,c_r,l_r)
62!---------------------------------------------------------------------
63!- Finds position of c_r in c_c
64!---------------------------------------------------------------------
65  IMPLICIT NONE
66!-
67  CHARACTER(LEN=*),INTENT(in) :: c_c
68  INTEGER,INTENT(IN) :: l_c
69  CHARACTER(LEN=*),INTENT(in) :: c_r
70  INTEGER,INTENT(IN) :: l_r
71!---------------------------------------------------------------------
72  findpos = INDEX(c_c(1:l_c),c_r(1:l_r))
73  IF (findpos == 0)  findpos=-1
74!-------------------
75END FUNCTION findpos
76!===
77SUBROUTINE find_str (str_tab,str,pos)
78!---------------------------------------------------------------------
79!- This subroutine looks for a string in a table
80!---------------------------------------------------------------------
81!- INPUT
82!-   str_tab  : Table  of strings
83!-   str      : Target we are looking for
84!- OUTPUT
85!-   pos      : -1 if str not found, else value in the table
86!---------------------------------------------------------------------
87  IMPLICIT NONE
88!-
89  CHARACTER(LEN=*),DIMENSION(:),INTENT(in) :: str_tab
90  CHARACTER(LEN=*),INTENT(in) :: str
91  INTEGER,INTENT(out) :: pos
92!-
93  INTEGER :: nb_str,i
94!---------------------------------------------------------------------
95  pos = -1
96  nb_str=SIZE(str_tab)
97  IF ( nb_str > 0 ) THEN
98    DO i=1,nb_str
99      IF ( TRIM(str_tab(i)) == TRIM(str) ) THEN
100        pos = i
101        EXIT
102      ENDIF
103    ENDDO
104  ENDIF
105!----------------------
106END SUBROUTINE find_str
107!===
108SUBROUTINE nocomma (str)
109!---------------------------------------------------------------------
110!- Replace commas with blanks
111!---------------------------------------------------------------------
112  IMPLICIT NONE
113!-
114  CHARACTER(LEN=*) :: str
115!-
116  INTEGER :: i
117!---------------------------------------------------------------------
118  DO i=1,LEN_TRIM(str)
119    IF (str(i:i) == ',')   str(i:i) = ' '
120  ENDDO
121!---------------------
122END SUBROUTINE nocomma
123!===
124SUBROUTINE nocomment (str)
125!---------------------------------------------------------------------
126!- Delete comment part from a line
127!
128!- line: TIME_SKIP=1D   # skip one day
129! to
130!  line: TIME_SKIP=1D
131!---------------------------------------------------------------------
132  IMPLICIT NONE
133!-
134  CHARACTER(LEN=*), INTENT(INOUT) :: str
135!-
136  INTEGER :: pos
137!---------------------------------------------------------------------
138  pos = INDEX(str, COMMENT_TAG)
139  IF (pos > 0) THEN
140    IF (pos == 1) THEN
141      str=""
142    ELSE
143      str=TRIM(str(1:pos-1))
144    ENDIF
145  ENDIF
146!---------------------
147END SUBROUTINE nocomment
148!===
149SUBROUTINE strlowercase (str)
150!---------------------------------------------------------------------
151!- Converts a string into lowercase
152!---------------------------------------------------------------------
153  IMPLICIT NONE
154!-
155  CHARACTER(LEN=*) :: str
156!-
157  INTEGER :: i,ic
158!---------------------------------------------------------------------
159  DO i=1,LEN_TRIM(str)
160    ic = IACHAR(str(i:i))
161    IF ( (ic >= 65).AND.(ic <= 90) )  str(i:i) = ACHAR(ic+32)
162  ENDDO
163!--------------------------
164END SUBROUTINE strlowercase
165!===
166SUBROUTINE struppercase (str)
167!---------------------------------------------------------------------
168!- Converts a string into uppercase
169!---------------------------------------------------------------------
170  IMPLICIT NONE
171!-
172  CHARACTER(LEN=*) :: str
173!-
174  INTEGER :: i,ic
175!---------------------------------------------------------------------
176  DO i=1,LEN_TRIM(str)
177    ic = IACHAR(str(i:i))
178    IF ( (ic >= 97).AND.(ic <= 122) )  str(i:i) = ACHAR(ic-32)
179  ENDDO
180!--------------------------
181END SUBROUTINE struppercase
182!===
183SUBROUTINE str_xfw (c_string,c_word,l_ok)
184!---------------------------------------------------------------------
185!- Given a character string "c_string", of arbitrary length,
186!- returns a logical flag "l_ok" if a word is found in it,
187!- the first word "c_word" if found and the new string "c_string"
188!- without the first word "c_word"
189!---------------------------------------------------------------------
190  CHARACTER(LEN=*),INTENT(INOUT) :: c_string
191  CHARACTER(LEN=*),INTENT(OUT) :: c_word
192  LOGICAL,INTENT(OUT) :: l_ok
193!-
194  INTEGER :: i_b,i_e
195!---------------------------------------------------------------------
196  l_ok = (LEN_TRIM(c_string) > 0)
197  IF (l_ok) THEN
198    i_b = VERIFY(c_string,' ')
199    i_e = INDEX(c_string(i_b:),' ')
200    IF (i_e == 0) THEN
201      c_word = c_string(i_b:)
202      c_string = ""
203    ELSE
204      c_word = c_string(i_b:i_b+i_e-2)
205      c_string = ADJUSTL(c_string(i_b+i_e-1:))
206    ENDIF
207  ENDIF
208!---------------------
209END SUBROUTINE str_xfw
210!===
211!------------------
212END MODULE stringop
Note: See TracBrowser for help on using the repository browser.