source: CONFIG_DEVT/LMDZOR_V6.2_work_ENSEMBLES/modeles/IOIPSL/src/stringop.f90 @ 5477

Last change on this file since 5477 was 5477, checked in by aclsce, 4 years ago
  • Created CONFIG_DEVT directory
  • First import of LMDZOR_V6.2_work_ENSEMBLES working configuration
File size: 6.1 KB
Line 
1MODULE stringop
2!-
3!$Id: stringop.f90 4863 2019-12-16 13:33:26Z jgipsl $
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.