[19] | 1 | MODULE stringop |
---|
| 2 | !- |
---|
[7] | 3 | !$Id$ |
---|
[386] | 4 | !- |
---|
| 5 | ! This software is governed by the CeCILL license |
---|
| 6 | ! See IOIPSL/IOIPSL_License_CeCILL.txt |
---|
[4] | 7 | !--------------------------------------------------------------------- |
---|
[4863] | 8 | CHARACTER(LEN=1), PARAMETER :: COMMENT_TAG = "#" ! Comment symbol |
---|
| 9 | |
---|
[4] | 10 | CONTAINS |
---|
| 11 | != |
---|
[5] | 12 | SUBROUTINE cmpblank (str) |
---|
[4] | 13 | !--------------------------------------------------------------------- |
---|
[5] | 14 | !- Compact blanks |
---|
[4] | 15 | !--------------------------------------------------------------------- |
---|
[5] | 16 | CHARACTER(LEN=*),INTENT(inout) :: str |
---|
[4] | 17 | !- |
---|
[5] | 18 | INTEGER :: lcc,ipb |
---|
[4] | 19 | !--------------------------------------------------------------------- |
---|
[5] | 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 | !---------------------- |
---|
| 32 | END SUBROUTINE cmpblank |
---|
| 33 | !=== |
---|
| 34 | INTEGER FUNCTION cntpos (c_c,l_c,c_r,l_r) |
---|
[4] | 35 | !--------------------------------------------------------------------- |
---|
| 36 | !- Finds number of occurences of c_r in c_c |
---|
| 37 | !--------------------------------------------------------------------- |
---|
[5] | 38 | IMPLICIT NONE |
---|
[4] | 39 | !- |
---|
[5] | 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 |
---|
[4] | 44 | !- |
---|
[5] | 45 | INTEGER :: ipos,indx |
---|
[4] | 46 | !--------------------------------------------------------------------- |
---|
[5] | 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 | !------------------ |
---|
| 59 | END FUNCTION cntpos |
---|
| 60 | !=== |
---|
| 61 | INTEGER FUNCTION findpos (c_c,l_c,c_r,l_r) |
---|
[4] | 62 | !--------------------------------------------------------------------- |
---|
| 63 | !- Finds position of c_r in c_c |
---|
| 64 | !--------------------------------------------------------------------- |
---|
[5] | 65 | IMPLICIT NONE |
---|
[4] | 66 | !- |
---|
[5] | 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 |
---|
[4] | 71 | !--------------------------------------------------------------------- |
---|
[5] | 72 | findpos = INDEX(c_c(1:l_c),c_r(1:l_r)) |
---|
| 73 | IF (findpos == 0) findpos=-1 |
---|
| 74 | !------------------- |
---|
| 75 | END FUNCTION findpos |
---|
| 76 | !=== |
---|
[122] | 77 | SUBROUTINE find_str (str_tab,str,pos) |
---|
[4] | 78 | !--------------------------------------------------------------------- |
---|
| 79 | !- This subroutine looks for a string in a table |
---|
| 80 | !--------------------------------------------------------------------- |
---|
| 81 | !- INPUT |
---|
[122] | 82 | !- str_tab : Table of strings |
---|
| 83 | !- str : Target we are looking for |
---|
[4] | 84 | !- OUTPUT |
---|
[122] | 85 | !- pos : -1 if str not found, else value in the table |
---|
[4] | 86 | !--------------------------------------------------------------------- |
---|
[5] | 87 | IMPLICIT NONE |
---|
[4] | 88 | !- |
---|
[122] | 89 | CHARACTER(LEN=*),DIMENSION(:),INTENT(in) :: str_tab |
---|
| 90 | CHARACTER(LEN=*),INTENT(in) :: str |
---|
| 91 | INTEGER,INTENT(out) :: pos |
---|
[4] | 92 | !- |
---|
[122] | 93 | INTEGER :: nb_str,i |
---|
[4] | 94 | !--------------------------------------------------------------------- |
---|
[5] | 95 | pos = -1 |
---|
[122] | 96 | nb_str=SIZE(str_tab) |
---|
[5] | 97 | IF ( nb_str > 0 ) THEN |
---|
| 98 | DO i=1,nb_str |
---|
[122] | 99 | IF ( TRIM(str_tab(i)) == TRIM(str) ) THEN |
---|
[5] | 100 | pos = i |
---|
| 101 | EXIT |
---|
| 102 | ENDIF |
---|
| 103 | ENDDO |
---|
| 104 | ENDIF |
---|
| 105 | !---------------------- |
---|
| 106 | END SUBROUTINE find_str |
---|
| 107 | !=== |
---|
| 108 | SUBROUTINE nocomma (str) |
---|
[4] | 109 | !--------------------------------------------------------------------- |
---|
[5] | 110 | !- Replace commas with blanks |
---|
[4] | 111 | !--------------------------------------------------------------------- |
---|
[5] | 112 | IMPLICIT NONE |
---|
[4] | 113 | !- |
---|
[5] | 114 | CHARACTER(LEN=*) :: str |
---|
[4] | 115 | !- |
---|
[5] | 116 | INTEGER :: i |
---|
[4] | 117 | !--------------------------------------------------------------------- |
---|
[5] | 118 | DO i=1,LEN_TRIM(str) |
---|
| 119 | IF (str(i:i) == ',') str(i:i) = ' ' |
---|
| 120 | ENDDO |
---|
| 121 | !--------------------- |
---|
| 122 | END SUBROUTINE nocomma |
---|
| 123 | !=== |
---|
[4863] | 124 | SUBROUTINE 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 | !--------------------- |
---|
| 147 | END SUBROUTINE nocomment |
---|
| 148 | !=== |
---|
[5] | 149 | SUBROUTINE strlowercase (str) |
---|
[4] | 150 | !--------------------------------------------------------------------- |
---|
| 151 | !- Converts a string into lowercase |
---|
| 152 | !--------------------------------------------------------------------- |
---|
[5] | 153 | IMPLICIT NONE |
---|
[4] | 154 | !- |
---|
[5] | 155 | CHARACTER(LEN=*) :: str |
---|
[4] | 156 | !- |
---|
[5] | 157 | INTEGER :: i,ic |
---|
[4] | 158 | !--------------------------------------------------------------------- |
---|
[5] | 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 | !-------------------------- |
---|
| 164 | END SUBROUTINE strlowercase |
---|
| 165 | !=== |
---|
| 166 | SUBROUTINE struppercase (str) |
---|
[4] | 167 | !--------------------------------------------------------------------- |
---|
| 168 | !- Converts a string into uppercase |
---|
| 169 | !--------------------------------------------------------------------- |
---|
[5] | 170 | IMPLICIT NONE |
---|
[4] | 171 | !- |
---|
[5] | 172 | CHARACTER(LEN=*) :: str |
---|
[4] | 173 | !- |
---|
[5] | 174 | INTEGER :: i,ic |
---|
[4] | 175 | !--------------------------------------------------------------------- |
---|
[5] | 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 | !-------------------------- |
---|
| 181 | END SUBROUTINE struppercase |
---|
| 182 | !=== |
---|
[936] | 183 | SUBROUTINE str_xfw (c_string,c_word,l_ok) |
---|
[4] | 184 | !--------------------------------------------------------------------- |
---|
[936] | 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" |
---|
[4] | 189 | !--------------------------------------------------------------------- |
---|
[936] | 190 | CHARACTER(LEN=*),INTENT(INOUT) :: c_string |
---|
| 191 | CHARACTER(LEN=*),INTENT(OUT) :: c_word |
---|
| 192 | LOGICAL,INTENT(OUT) :: l_ok |
---|
[4] | 193 | !- |
---|
[936] | 194 | INTEGER :: i_b,i_e |
---|
[4] | 195 | !--------------------------------------------------------------------- |
---|
[936] | 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:)) |
---|
[5] | 206 | ENDIF |
---|
| 207 | ENDIF |
---|
[936] | 208 | !--------------------- |
---|
| 209 | END SUBROUTINE str_xfw |
---|
[5] | 210 | !=== |
---|
[4] | 211 | !------------------ |
---|
| 212 | END MODULE stringop |
---|