Changeset 5


Ignore:
Timestamp:
03/12/07 10:26:08 (14 years ago)
Author:
bellier
Message:

new version to test svn

File:
1 edited

Legend:

Unmodified
Added
Removed
  • IOIPSL/trunk/src/stringop.f90

    r4 r5  
    1 !$Header: /home/ioipsl/CVSROOT/IOIPSL/src/stringop.f90,v 2.0 2004/04/05 14:47:51 adm Exp $ 
    2 ! 
     1!$HeadURL$ 
     2!- 
    33MODULE stringop 
    44!--------------------------------------------------------------------- 
    55!- 
    6   INTEGER, DIMENSION(30) :: & 
    7        & prime=(/1,2,3,5,7,11,13,17,19,23,29,31,37,41,43, & 
    8        & 47,53,59,61,67,71,73,79,83,89,97,101,103,107,109/) 
     6  INTEGER,DIMENSION(30) :: & 
     7 & prime=(/1,2,3,5,7,11,13,17,19,23,29,31,37,41,43, & 
     8 & 47,53,59,61,67,71,73,79,83,89,97,101,103,107,109/) 
    99!- 
    1010!--------------------------------------------------------------------- 
    1111CONTAINS 
    1212!= 
    13    SUBROUTINE cmpblank (str) 
    14 !--------------------------------------------------------------------- 
    15 !- 
    16 !--------------------------------------------------------------------- 
    17    CHARACTER(LEN=*),INTENT(inout) :: str 
    18 !- 
    19    INTEGER :: lcc,ipb 
    20 !--------------------------------------------------------------------- 
    21    lcc = LEN_TRIM(str) 
    22    ipb = 1 
    23    DO 
    24      IF (ipb >= lcc)   EXIT 
    25      IF (str(ipb:ipb+1) == '  ') THEN 
    26        str(ipb+1:) = str(ipb+2:lcc) 
    27        lcc = lcc-1 
    28      ELSE 
    29        ipb = ipb+1 
    30      ENDIF 
    31    ENDDO 
    32 !------------------------- 
    33    END SUBROUTINE cmpblank 
    34 != 
    35    INTEGER FUNCTION cntpos (c_c,l_c,c_r,l_r) 
     13SUBROUTINE cmpblank (str) 
     14!--------------------------------------------------------------------- 
     15!- Compact blanks 
     16!--------------------------------------------------------------------- 
     17  CHARACTER(LEN=*),INTENT(inout) :: str 
     18!- 
     19  INTEGER :: lcc,ipb 
     20!--------------------------------------------------------------------- 
     21  lcc = LEN_TRIM(str) 
     22  ipb = 1 
     23  DO 
     24    IF (ipb >= lcc)   EXIT 
     25    IF (str(ipb:ipb+1) == '  ') THEN 
     26      str(ipb+1:) = str(ipb+2:lcc) 
     27      lcc = lcc-1 
     28    ELSE 
     29      ipb = ipb+1 
     30    ENDIF 
     31  ENDDO 
     32!---------------------- 
     33END SUBROUTINE cmpblank 
     34!=== 
     35INTEGER FUNCTION cntpos (c_c,l_c,c_r,l_r) 
    3636!--------------------------------------------------------------------- 
    3737!- Finds number of occurences of c_r in c_c 
    3838!--------------------------------------------------------------------- 
    39    IMPLICIT NONE 
    40 !- 
    41    CHARACTER(LEN=*),INTENT(in) :: c_c 
    42    INTEGER,INTENT(IN) :: l_c 
    43    CHARACTER(LEN=*),INTENT(in) :: c_r 
    44    INTEGER,INTENT(IN) :: l_r 
    45 !- 
    46    INTEGER :: ipos,indx,ires 
    47 !--------------------------------------------------------------------- 
    48    cntpos = 0 
    49    ipos   = 1 
    50    DO 
    51      indx = INDEX(c_c(ipos:l_c),c_r(1:l_r)) 
    52      IF (indx > 0) THEN 
    53        cntpos = cntpos+1 
    54        ipos   = ipos+indx+l_r-1 
    55      ELSE 
    56        EXIT 
    57      ENDIF 
    58    ENDDO 
    59 !--------------------- 
    60    END FUNCTION cntpos 
    61 != 
    62    INTEGER FUNCTION findpos (c_c,l_c,c_r,l_r) 
     39  IMPLICIT NONE 
     40!- 
     41  CHARACTER(LEN=*),INTENT(in) :: c_c 
     42  INTEGER,INTENT(IN) :: l_c 
     43  CHARACTER(LEN=*),INTENT(in) :: c_r 
     44  INTEGER,INTENT(IN) :: l_r 
     45!- 
     46  INTEGER :: ipos,indx 
     47!--------------------------------------------------------------------- 
     48  cntpos = 0 
     49  ipos   = 1 
     50  DO 
     51    indx = INDEX(c_c(ipos:l_c),c_r(1:l_r)) 
     52    IF (indx > 0) THEN 
     53      cntpos = cntpos+1 
     54      ipos   = ipos+indx+l_r-1 
     55    ELSE 
     56      EXIT 
     57    ENDIF 
     58  ENDDO 
     59!------------------ 
     60END FUNCTION cntpos 
     61!=== 
     62INTEGER FUNCTION findpos (c_c,l_c,c_r,l_r) 
    6363!--------------------------------------------------------------------- 
    6464!- Finds position of c_r in c_c 
    6565!--------------------------------------------------------------------- 
    66    IMPLICIT NONE 
    67 !- 
    68    CHARACTER(LEN=*),INTENT(in) :: c_c 
    69    INTEGER,INTENT(IN) :: l_c 
    70    CHARACTER(LEN=*),INTENT(in) :: c_r 
    71    INTEGER,INTENT(IN) :: l_r 
    72 !--------------------------------------------------------------------- 
    73     findpos = INDEX(c_c(1:l_c),c_r(1:l_r)) 
    74     IF (findpos == 0)   findpos=-1 
    75 !---------------------- 
    76    END FUNCTION findpos 
    77 != 
    78    SUBROUTINE find_str (nb_str,str_tab,str_len_tab,str,pos) 
     66  IMPLICIT NONE 
     67!- 
     68  CHARACTER(LEN=*),INTENT(in) :: c_c 
     69  INTEGER,INTENT(IN) :: l_c 
     70  CHARACTER(LEN=*),INTENT(in) :: c_r 
     71  INTEGER,INTENT(IN) :: l_r 
     72!--------------------------------------------------------------------- 
     73  findpos = INDEX(c_c(1:l_c),c_r(1:l_r)) 
     74  IF (findpos == 0)  findpos=-1 
     75!------------------- 
     76END FUNCTION findpos 
     77!=== 
     78SUBROUTINE find_str (nb_str,str_tab,str_len_tab,str,pos) 
    7979!--------------------------------------------------------------------- 
    8080!- This subroutine looks for a string in a table 
     
    8888!-   pos         : -1 if str not found, else value in the table 
    8989!--------------------------------------------------------------------- 
    90    IMPLICIT NONE 
    91 !- 
    92    INTEGER :: nb_str 
    93    CHARACTER(LEN=*),DIMENSION(nb_str) :: str_tab 
    94    INTEGER,DIMENSION(nb_str) :: str_len_tab 
    95    CHARACTER(LEN=*) :: str 
    96    INTEGER :: pos 
    97 !- 
    98    INTEGER :: i,il 
    99 !--------------------------------------------------------------------- 
    100    pos = -1 
    101    il = LEN_TRIM(str) 
    102    IF ( nb_str > 0 ) THEN 
    103       DO i=1,nb_str 
    104          IF (     (INDEX(str_tab(i),str(1:il)) > 0) & 
    105               .AND.(str_len_tab(i) == il) ) THEN 
    106             pos = i 
    107             EXIT 
    108          ENDIF 
    109       ENDDO 
    110    ENDIF 
    111 !------------------------- 
    112    END SUBROUTINE find_str 
    113 != 
    114    SUBROUTINE nocomma (str) 
    115 !--------------------------------------------------------------------- 
    116 !- 
    117 !--------------------------------------------------------------------- 
    118    IMPLICIT NONE 
    119 !- 
    120    CHARACTER(LEN=*) :: str 
    121 !- 
    122    INTEGER :: i 
    123 !--------------------------------------------------------------------- 
    124    DO i=1,LEN_TRIM(str) 
    125      IF (str(i:i) == ',')   str(i:i) = ' ' 
    126    ENDDO 
    127 !------------------------ 
    128    END SUBROUTINE nocomma 
    129 != 
    130    SUBROUTINE strlowercase (str) 
     90  IMPLICIT NONE 
     91!- 
     92  INTEGER :: nb_str 
     93  CHARACTER(LEN=*),DIMENSION(nb_str) :: str_tab 
     94  INTEGER,DIMENSION(nb_str) :: str_len_tab 
     95  CHARACTER(LEN=*) :: str 
     96  INTEGER :: pos 
     97!- 
     98  INTEGER :: i,il 
     99!--------------------------------------------------------------------- 
     100  pos = -1 
     101  il = LEN_TRIM(str) 
     102  IF ( nb_str > 0 ) THEN 
     103    DO i=1,nb_str 
     104      IF (     (INDEX(str_tab(i),str(1:il)) > 0) & 
     105          .AND.(str_len_tab(i) == il) ) THEN 
     106        pos = i 
     107        EXIT 
     108      ENDIF 
     109    ENDDO 
     110  ENDIF 
     111!---------------------- 
     112END SUBROUTINE find_str 
     113!=== 
     114SUBROUTINE nocomma (str) 
     115!--------------------------------------------------------------------- 
     116!- Replace commas with blanks 
     117!--------------------------------------------------------------------- 
     118  IMPLICIT NONE 
     119!- 
     120  CHARACTER(LEN=*) :: str 
     121!- 
     122  INTEGER :: i 
     123!--------------------------------------------------------------------- 
     124  DO i=1,LEN_TRIM(str) 
     125    IF (str(i:i) == ',')   str(i:i) = ' ' 
     126  ENDDO 
     127!--------------------- 
     128END SUBROUTINE nocomma 
     129!=== 
     130SUBROUTINE strlowercase (str) 
    131131!--------------------------------------------------------------------- 
    132132!- Converts a string into lowercase 
    133133!--------------------------------------------------------------------- 
    134    IMPLICIT NONE 
    135 !- 
    136    CHARACTER(LEN=*) :: str 
    137 !- 
    138    INTEGER :: i,ic 
    139 !--------------------------------------------------------------------- 
    140    DO i=1,LEN_TRIM(str) 
    141      ic = IACHAR(str(i:i)) 
    142      IF ( (ic >= 65) .AND. (ic <= 90) )   str(i:i) = ACHAR(ic+32) 
    143    ENDDO 
    144 !----------------------------- 
    145    END SUBROUTINE strlowercase 
    146 != 
    147    SUBROUTINE struppercase (str) 
     134  IMPLICIT NONE 
     135!- 
     136  CHARACTER(LEN=*) :: str 
     137!- 
     138  INTEGER :: i,ic 
     139!--------------------------------------------------------------------- 
     140  DO i=1,LEN_TRIM(str) 
     141    ic = IACHAR(str(i:i)) 
     142    IF ( (ic >= 65).AND.(ic <= 90) )  str(i:i) = ACHAR(ic+32) 
     143  ENDDO 
     144!-------------------------- 
     145END SUBROUTINE strlowercase 
     146!=== 
     147SUBROUTINE struppercase (str) 
    148148!--------------------------------------------------------------------- 
    149149!- Converts a string into uppercase 
    150150!--------------------------------------------------------------------- 
    151    IMPLICIT NONE 
    152 !- 
    153    CHARACTER(LEN=*) :: str 
    154 !- 
    155    INTEGER :: i,ic 
    156 !--------------------------------------------------------------------- 
    157    DO i=1,LEN_TRIM(str) 
    158      ic = IACHAR(str(i:i)) 
    159      IF ( (ic >= 97) .AND. (ic <= 122) )   str(i:i) = ACHAR(ic-32) 
    160    ENDDO 
    161 !----------------------------- 
    162    END SUBROUTINE struppercase 
    163 != 
    164 !------------------ 
    165    SUBROUTINE gensig (str, sig) 
     151  IMPLICIT NONE 
     152!- 
     153  CHARACTER(LEN=*) :: str 
     154!- 
     155  INTEGER :: i,ic 
     156!--------------------------------------------------------------------- 
     157  DO i=1,LEN_TRIM(str) 
     158    ic = IACHAR(str(i:i)) 
     159    IF ( (ic >= 97).AND.(ic <= 122) )  str(i:i) = ACHAR(ic-32) 
     160  ENDDO 
     161!-------------------------- 
     162END SUBROUTINE struppercase 
     163!=== 
     164SUBROUTINE gensig (str,sig) 
    166165!--------------------------------------------------------------------- 
    167166!- Generate a signature from the first 30 characters of the string 
     
    169168!- one needs to also verify the string. 
    170169!--------------------------------------------------------------------- 
    171    IMPLICIT NONE 
    172 !- 
    173    CHARACTER(LEN=*) :: str 
    174    INTEGER          :: sig 
    175 !- 
    176    INTEGER :: i 
    177 !--------------------------------------------------------------------- 
    178    sig = 0 
    179    DO i=1,MIN(len_trim(str),30) 
    180       sig = sig  + prime(i)*IACHAR(str(i:i)) 
    181    ENDDO 
    182 !----------------------------- 
    183  END SUBROUTINE gensig 
    184 != 
    185 !------------------ 
    186    SUBROUTINE find_sig (nb_sig, str_tab, str, sig_tab, sig, pos) 
     170  IMPLICIT NONE 
     171!- 
     172  CHARACTER(LEN=*) :: str 
     173  INTEGER          :: sig 
     174!- 
     175  INTEGER :: i 
     176!--------------------------------------------------------------------- 
     177  sig = 0 
     178  DO i=1,MIN(LEN_TRIM(str),30) 
     179    sig = sig + prime(i)*IACHAR(str(i:i)) 
     180  ENDDO 
     181!-------------------- 
     182END SUBROUTINE gensig 
     183!=== 
     184SUBROUTINE find_sig (nb_sig,str_tab,str,sig_tab,sig,pos) 
    187185!--------------------------------------------------------------------- 
    188186!- Find the string signature in a list of signatures 
     
    191189!-   nb_sig      : length of table of signatures 
    192190!-   str_tab     : Table of strings 
    193 !-   str         : Target string we are looking for  
     191!-   str         : Target string we are looking for 
    194192!-   sig_tab     : Table of signatures 
    195193!-   sig         : Target signature we are looking for 
     
    197195!-   pos         : -1 if str not found, else value in the table 
    198196!--------------------------------------------------------------------- 
    199    IMPLICIT NONE 
    200 !- 
    201    INTEGER :: nb_sig 
    202    CHARACTER(LEN=*),DIMENSION(nb_sig) :: str_tab 
    203    CHARACTER(LEN=*) :: str 
    204    INTEGER, DIMENSION(nb_sig) :: sig_tab 
    205    INTEGER :: sig 
    206 !- 
    207    INTEGER :: pos 
    208    INTEGER, DIMENSION(nb_sig) :: loczeros 
    209 !- 
    210    INTEGER :: il, len 
    211    INTEGER, DIMENSION(1) :: minpos 
    212 !--------------------------------------------------------------------- 
    213 !- 
    214    pos = -1 
    215    il = LEN_TRIM(str) 
    216 !- 
    217    IF ( nb_sig > 0 ) THEN 
    218       ! 
    219       loczeros = ABS(sig_tab(1:nb_sig)-sig) 
    220       ! 
    221       IF ( COUNT(loczeros < 1) == 1 ) THEN 
    222          ! 
    223          minpos = MINLOC(loczeros) 
    224          len = LEN_TRIM(str_tab(minpos(1))) 
    225          IF ( (INDEX(str_tab(minpos(1)),str(1:il)) > 0) & 
    226                  .AND.(len == il) ) THEN 
    227             pos = minpos(1) 
    228          ENDIF 
    229          ! 
    230       ELSE IF ( COUNT(loczeros < 1) > 1 ) THEN 
    231          ! 
    232          DO WHILE (COUNT(loczeros < 1) >= 1 .AND. pos < 0 ) 
    233             minpos = MINLOC(loczeros) 
    234             len = LEN_TRIM(str_tab(minpos(1))) 
    235             IF ( (INDEX(str_tab(minpos(1)),str(1:il)) > 0) & 
    236                  .AND.(len == il) ) THEN 
    237                pos = minpos(1) 
    238             ELSE 
    239                loczeros(minpos(1)) = 99999 
    240             ENDIF 
    241          ENDDO 
    242          ! 
     197  IMPLICIT NONE 
     198!- 
     199  INTEGER :: nb_sig 
     200  CHARACTER(LEN=*),DIMENSION(nb_sig) :: str_tab 
     201  CHARACTER(LEN=*) :: str 
     202  INTEGER,DIMENSION(nb_sig) :: sig_tab 
     203  INTEGER :: sig 
     204!- 
     205  INTEGER :: pos 
     206  INTEGER,DIMENSION(nb_sig) :: loczeros 
     207!- 
     208  INTEGER :: il,len 
     209  INTEGER,DIMENSION(1) :: minpos 
     210!--------------------------------------------------------------------- 
     211  pos = -1 
     212  il = LEN_TRIM(str) 
     213!- 
     214  IF ( nb_sig > 0 ) THEN 
     215    loczeros = ABS(sig_tab(1:nb_sig)-sig) 
     216    IF ( COUNT(loczeros < 1) == 1 ) THEN 
     217      minpos = MINLOC(loczeros) 
     218      len = LEN_TRIM(str_tab(minpos(1))) 
     219      IF (     (INDEX(str_tab(minpos(1)),str(1:il)) > 0) & 
     220          .AND.(len == il) ) THEN 
     221        pos = minpos(1) 
    243222      ENDIF 
    244       ! 
    245    ENDIF 
    246 !- 
     223    ELSE IF ( COUNT(loczeros < 1) > 1 ) THEN 
     224      DO WHILE (COUNT(loczeros < 1) >= 1 .AND. pos < 0 ) 
     225        minpos = MINLOC(loczeros) 
     226        len = LEN_TRIM(str_tab(minpos(1))) 
     227        IF (     (INDEX(str_tab(minpos(1)),str(1:il)) > 0) & 
     228            .AND.(len == il) ) THEN 
     229          pos = minpos(1) 
     230        ELSE 
     231          loczeros(minpos(1)) = 99999 
     232        ENDIF 
     233      ENDDO 
     234    ENDIF 
     235  ENDIF 
     236!----------------------- 
    247237 END SUBROUTINE find_sig 
    248 != 
     238!=== 
    249239!------------------ 
    250240END MODULE stringop 
Note: See TracChangeset for help on using the changeset viewer.