[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 | !--------------------------------------------------------------------- |
---|
| 8 | CONTAINS |
---|
| 9 | != |
---|
[5] | 10 | SUBROUTINE cmpblank (str) |
---|
[4] | 11 | !--------------------------------------------------------------------- |
---|
[5] | 12 | !- Compact blanks |
---|
[4] | 13 | !--------------------------------------------------------------------- |
---|
[5] | 14 | CHARACTER(LEN=*),INTENT(inout) :: str |
---|
[4] | 15 | !- |
---|
[5] | 16 | INTEGER :: lcc,ipb |
---|
[4] | 17 | !--------------------------------------------------------------------- |
---|
[5] | 18 | lcc = LEN_TRIM(str) |
---|
| 19 | ipb = 1 |
---|
| 20 | DO |
---|
| 21 | IF (ipb >= lcc) EXIT |
---|
| 22 | IF (str(ipb:ipb+1) == ' ') THEN |
---|
| 23 | str(ipb+1:) = str(ipb+2:lcc) |
---|
| 24 | lcc = lcc-1 |
---|
| 25 | ELSE |
---|
| 26 | ipb = ipb+1 |
---|
| 27 | ENDIF |
---|
| 28 | ENDDO |
---|
| 29 | !---------------------- |
---|
| 30 | END SUBROUTINE cmpblank |
---|
| 31 | !=== |
---|
| 32 | INTEGER FUNCTION cntpos (c_c,l_c,c_r,l_r) |
---|
[4] | 33 | !--------------------------------------------------------------------- |
---|
| 34 | !- Finds number of occurences of c_r in c_c |
---|
| 35 | !--------------------------------------------------------------------- |
---|
[5] | 36 | IMPLICIT NONE |
---|
[4] | 37 | !- |
---|
[5] | 38 | CHARACTER(LEN=*),INTENT(in) :: c_c |
---|
| 39 | INTEGER,INTENT(IN) :: l_c |
---|
| 40 | CHARACTER(LEN=*),INTENT(in) :: c_r |
---|
| 41 | INTEGER,INTENT(IN) :: l_r |
---|
[4] | 42 | !- |
---|
[5] | 43 | INTEGER :: ipos,indx |
---|
[4] | 44 | !--------------------------------------------------------------------- |
---|
[5] | 45 | cntpos = 0 |
---|
| 46 | ipos = 1 |
---|
| 47 | DO |
---|
| 48 | indx = INDEX(c_c(ipos:l_c),c_r(1:l_r)) |
---|
| 49 | IF (indx > 0) THEN |
---|
| 50 | cntpos = cntpos+1 |
---|
| 51 | ipos = ipos+indx+l_r-1 |
---|
| 52 | ELSE |
---|
| 53 | EXIT |
---|
| 54 | ENDIF |
---|
| 55 | ENDDO |
---|
| 56 | !------------------ |
---|
| 57 | END FUNCTION cntpos |
---|
| 58 | !=== |
---|
| 59 | INTEGER FUNCTION findpos (c_c,l_c,c_r,l_r) |
---|
[4] | 60 | !--------------------------------------------------------------------- |
---|
| 61 | !- Finds position of c_r in c_c |
---|
| 62 | !--------------------------------------------------------------------- |
---|
[5] | 63 | IMPLICIT NONE |
---|
[4] | 64 | !- |
---|
[5] | 65 | CHARACTER(LEN=*),INTENT(in) :: c_c |
---|
| 66 | INTEGER,INTENT(IN) :: l_c |
---|
| 67 | CHARACTER(LEN=*),INTENT(in) :: c_r |
---|
| 68 | INTEGER,INTENT(IN) :: l_r |
---|
[4] | 69 | !--------------------------------------------------------------------- |
---|
[5] | 70 | findpos = INDEX(c_c(1:l_c),c_r(1:l_r)) |
---|
| 71 | IF (findpos == 0) findpos=-1 |
---|
| 72 | !------------------- |
---|
| 73 | END FUNCTION findpos |
---|
| 74 | !=== |
---|
[122] | 75 | SUBROUTINE find_str (str_tab,str,pos) |
---|
[4] | 76 | !--------------------------------------------------------------------- |
---|
| 77 | !- This subroutine looks for a string in a table |
---|
| 78 | !--------------------------------------------------------------------- |
---|
| 79 | !- INPUT |
---|
[122] | 80 | !- str_tab : Table of strings |
---|
| 81 | !- str : Target we are looking for |
---|
[4] | 82 | !- OUTPUT |
---|
[122] | 83 | !- pos : -1 if str not found, else value in the table |
---|
[4] | 84 | !--------------------------------------------------------------------- |
---|
[5] | 85 | IMPLICIT NONE |
---|
[4] | 86 | !- |
---|
[122] | 87 | CHARACTER(LEN=*),DIMENSION(:),INTENT(in) :: str_tab |
---|
| 88 | CHARACTER(LEN=*),INTENT(in) :: str |
---|
| 89 | INTEGER,INTENT(out) :: pos |
---|
[4] | 90 | !- |
---|
[122] | 91 | INTEGER :: nb_str,i |
---|
[4] | 92 | !--------------------------------------------------------------------- |
---|
[5] | 93 | pos = -1 |
---|
[122] | 94 | nb_str=SIZE(str_tab) |
---|
[5] | 95 | IF ( nb_str > 0 ) THEN |
---|
| 96 | DO i=1,nb_str |
---|
[122] | 97 | IF ( TRIM(str_tab(i)) == TRIM(str) ) THEN |
---|
[5] | 98 | pos = i |
---|
| 99 | EXIT |
---|
| 100 | ENDIF |
---|
| 101 | ENDDO |
---|
| 102 | ENDIF |
---|
| 103 | !---------------------- |
---|
| 104 | END SUBROUTINE find_str |
---|
| 105 | !=== |
---|
| 106 | SUBROUTINE nocomma (str) |
---|
[4] | 107 | !--------------------------------------------------------------------- |
---|
[5] | 108 | !- Replace commas with blanks |
---|
[4] | 109 | !--------------------------------------------------------------------- |
---|
[5] | 110 | IMPLICIT NONE |
---|
[4] | 111 | !- |
---|
[5] | 112 | CHARACTER(LEN=*) :: str |
---|
[4] | 113 | !- |
---|
[5] | 114 | INTEGER :: i |
---|
[4] | 115 | !--------------------------------------------------------------------- |
---|
[5] | 116 | DO i=1,LEN_TRIM(str) |
---|
| 117 | IF (str(i:i) == ',') str(i:i) = ' ' |
---|
| 118 | ENDDO |
---|
| 119 | !--------------------- |
---|
| 120 | END SUBROUTINE nocomma |
---|
| 121 | !=== |
---|
| 122 | SUBROUTINE strlowercase (str) |
---|
[4] | 123 | !--------------------------------------------------------------------- |
---|
| 124 | !- Converts a string into lowercase |
---|
| 125 | !--------------------------------------------------------------------- |
---|
[5] | 126 | IMPLICIT NONE |
---|
[4] | 127 | !- |
---|
[5] | 128 | CHARACTER(LEN=*) :: str |
---|
[4] | 129 | !- |
---|
[5] | 130 | INTEGER :: i,ic |
---|
[4] | 131 | !--------------------------------------------------------------------- |
---|
[5] | 132 | DO i=1,LEN_TRIM(str) |
---|
| 133 | ic = IACHAR(str(i:i)) |
---|
| 134 | IF ( (ic >= 65).AND.(ic <= 90) ) str(i:i) = ACHAR(ic+32) |
---|
| 135 | ENDDO |
---|
| 136 | !-------------------------- |
---|
| 137 | END SUBROUTINE strlowercase |
---|
| 138 | !=== |
---|
| 139 | SUBROUTINE struppercase (str) |
---|
[4] | 140 | !--------------------------------------------------------------------- |
---|
| 141 | !- Converts a string into uppercase |
---|
| 142 | !--------------------------------------------------------------------- |
---|
[5] | 143 | IMPLICIT NONE |
---|
[4] | 144 | !- |
---|
[5] | 145 | CHARACTER(LEN=*) :: str |
---|
[4] | 146 | !- |
---|
[5] | 147 | INTEGER :: i,ic |
---|
[4] | 148 | !--------------------------------------------------------------------- |
---|
[5] | 149 | DO i=1,LEN_TRIM(str) |
---|
| 150 | ic = IACHAR(str(i:i)) |
---|
| 151 | IF ( (ic >= 97).AND.(ic <= 122) ) str(i:i) = ACHAR(ic-32) |
---|
| 152 | ENDDO |
---|
| 153 | !-------------------------- |
---|
| 154 | END SUBROUTINE struppercase |
---|
| 155 | !=== |
---|
[936] | 156 | SUBROUTINE str_xfw (c_string,c_word,l_ok) |
---|
[4] | 157 | !--------------------------------------------------------------------- |
---|
[936] | 158 | !- Given a character string "c_string", of arbitrary length, |
---|
| 159 | !- returns a logical flag "l_ok" if a word is found in it, |
---|
| 160 | !- the first word "c_word" if found and the new string "c_string" |
---|
| 161 | !- without the first word "c_word" |
---|
[4] | 162 | !--------------------------------------------------------------------- |
---|
[936] | 163 | CHARACTER(LEN=*),INTENT(INOUT) :: c_string |
---|
| 164 | CHARACTER(LEN=*),INTENT(OUT) :: c_word |
---|
| 165 | LOGICAL,INTENT(OUT) :: l_ok |
---|
[4] | 166 | !- |
---|
[936] | 167 | INTEGER :: i_b,i_e |
---|
[4] | 168 | !--------------------------------------------------------------------- |
---|
[936] | 169 | l_ok = (LEN_TRIM(c_string) > 0) |
---|
| 170 | IF (l_ok) THEN |
---|
| 171 | i_b = VERIFY(c_string,' ') |
---|
| 172 | i_e = INDEX(c_string(i_b:),' ') |
---|
| 173 | IF (i_e == 0) THEN |
---|
| 174 | c_word = c_string(i_b:) |
---|
| 175 | c_string = "" |
---|
| 176 | ELSE |
---|
| 177 | c_word = c_string(i_b:i_b+i_e-2) |
---|
| 178 | c_string = ADJUSTL(c_string(i_b+i_e-1:)) |
---|
[5] | 179 | ENDIF |
---|
| 180 | ENDIF |
---|
[936] | 181 | !--------------------- |
---|
| 182 | END SUBROUTINE str_xfw |
---|
[5] | 183 | !=== |
---|
[4] | 184 | !------------------ |
---|
| 185 | END MODULE stringop |
---|