Changeset 936


Ignore:
Timestamp:
03/04/10 12:01:32 (15 years ago)
Author:
bellier
Message:

stringop :

  • added a subroutine ("str_xfw") to extract the words of a string
  • suppressed unused subroutines ("gensig" and "find_sig")

fliocom :

  • modified the syntax of the file creating mode (in "fliocrfd") to be on the road to NETCDF4
Location:
IOIPSL/trunk/src
Files:
2 edited

Legend:

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

    r886 r936  
    1212 &                    ioconf_calendar,ju2ymds,ymds2ju 
    1313USE errioipsl, ONLY : ipslerr,ipsldbg 
    14 USE stringop,  ONLY : strlowercase 
     14USE stringop,  ONLY : strlowercase,str_xfw 
    1515!- 
    1616IMPLICIT NONE 
     
    8686!!              This argument can be equal to FLIO_DOM_DEFAULT 
    8787!!              (see "flio_dom_defset"). 
    88 !! (C) mode   : Mode used to create the file. 
    89 !!              Supported modes : REPLACE, REP, 32, 64, REP32, REP64. 
    90 !!              If this argument is present with the value "REP[32/64]" 
    91 !!              or the value "REPLACE", the file will be created 
    92 !!              in mode "CLOBBER", else the file will be created 
    93 !!              in mode "NOCLOBBER". 
     88!! (C) mode   : String of (case insensitive) blank-separated words 
     89!!              defining the mode used to create the file. 
     90!!              Supported keywords : REPLACE, 32, 64 
     91!!              If this argument is present with the keyword "REPLACE", 
     92!!              the file will be created in mode "CLOBBER", 
     93!!              else the file will be created in mode "NOCLOBBER". 
    9494!!              "32/64" defines the offset mode. 
    95 !!              The default offset mode is 32 bits. 
     95!!              The default offset mode is 64 bits. 
     96!!              Keywords "NETCDF4" and "CLASSIC" are reserved 
     97!!              for future use. 
    9698!! 
    9799!! Optional OUTPUT arguments 
     
    849851  INTEGER :: i_rc,f_e,idid,ii,m_c,n_u 
    850852  CHARACTER(LEN=NF90_MAX_NAME) :: f_nw 
     853  INTEGER,PARAMETER :: l_string=80,l_word=10 
     854  CHARACTER(LEN=l_string) :: c_string 
     855  CHARACTER(LEN=l_word)   :: c_word 
     856  LOGICAL :: l_ok 
     857  INTEGER,PARAMETER :: k_replace=1 
     858  INTEGER,PARAMETER :: k_32=1,k_64=2 
     859!- !? : Code to be activated for NETCDF4 
     860!?  INTEGER,PARAMETER :: k_netcdf4=1,k_classic=1 
     861  INTEGER,PARAMETER :: n_opt=4 
     862  INTEGER,DIMENSION(n_opt) :: i_opt 
    851863!- 
    852864  LOGICAL :: l_dbg 
     
    882894!- 
    883895! Check the mode 
     896!- 
     897  i_opt(:)=-1 
     898!- 
    884899  IF (PRESENT(mode)) THEN 
    885     SELECT CASE (TRIM(mode)) 
    886     CASE('REPLACE','REP','REP64') 
    887       m_c = IOR(NF90_CLOBBER,NF90_64BIT_OFFSET) 
    888     CASE('REP32') 
    889       m_c = NF90_CLOBBER 
    890     CASE('32') 
    891       m_c = NF90_NOCLOBBER 
    892     CASE('64') 
    893       m_c = IOR(NF90_NOCLOBBER,NF90_64BIT_OFFSET) 
    894     CASE DEFAULT 
    895       m_c = IOR(NF90_NOCLOBBER,NF90_64BIT_OFFSET) 
    896     END SELECT 
     900!--- 
     901    IF (LEN_TRIM(mode) > l_string) THEN 
     902      CALL ipslerr (3,'fliocrfd', & 
     903 &     '"mode" argument','too long','to be treated') 
     904    ENDIF 
     905    c_string = mode(:) 
     906    CALL strlowercase (c_string) 
     907!--- 
     908    DO 
     909      CALL str_xfw  (c_string,c_word,l_ok) 
     910      IF (l_ok) THEN 
     911!- !? : Code to be activated for NETCDF4 
     912        SELECT CASE (TRIM(c_word)) 
     913        CASE('replace') 
     914          IF (i_opt(1) > 0) THEN 
     915            CALL ipslerr (3,'fliocrfd', & 
     916 &           'Replace option','already','defined') 
     917          ELSE 
     918            i_opt(1) = k_replace 
     919          ENDIF 
     920!?      CASE('netcdf4') 
     921!?        IF (i_opt(2) > 0) THEN 
     922!?          CALL ipslerr (3,'fliocrfd', & 
     923!? &         'Netcdf4 format','already','defined') 
     924!?        ELSE 
     925!?          i_opt(2) = k_netcdf4 
     926!?        ENDIF 
     927        CASE('32') 
     928          IF (i_opt(3) > 0) THEN 
     929            CALL ipslerr (3,'fliocrfd', & 
     930 &           'Offset format','already','defined') 
     931          ELSE 
     932            i_opt(3) = k_32 
     933          ENDIF 
     934        CASE('64') 
     935          IF (i_opt(3) > 0) THEN 
     936            CALL ipslerr (3,'fliocrfd', & 
     937 &           'Offset format','already','defined') 
     938          ELSE 
     939            i_opt(3) = k_64 
     940          ENDIF 
     941!?      CASE('CLASSIC') 
     942!?        IF (i_opt(4) > 0) THEN 
     943!?          CALL ipslerr (3,'fliocrfd', & 
     944!? &         'Netcdf4 classic format','already','defined') 
     945!?        ELSE 
     946!?          i_opt(4) = k_classic 
     947!?        ENDIF 
     948        CASE DEFAULT 
     949          CALL ipslerr (3,'fliocrfd', & 
     950 &         'Option '//TRIM(c_word),'not','supported') 
     951        END SELECT 
     952      ELSE 
     953        EXIT 
     954      ENDIF 
     955    ENDDO 
     956  ENDIF 
     957!- 
     958  IF (i_opt(1) == k_replace) THEN 
     959    m_c = NF90_CLOBBER 
    897960  ELSE 
    898     m_c = IOR(NF90_NOCLOBBER,NF90_64BIT_OFFSET) 
    899   ENDIF 
     961    m_c = NF90_NOCLOBBER 
     962  ENDIF 
     963!- 
     964!- Code to be replaced by the following for NETCDF4 
     965  IF (i_opt(3) /= k_32) THEN 
     966    m_c = IOR(m_c,NF90_64BIT_OFFSET) 
     967  ENDIF 
     968!?  IF (i_opt(2) == k_netcdf4) THEN 
     969!?    m_c = IOR(m_c,NF90_NETCDF4) 
     970!?    IF (i_opt(3) > 0) THEN 
     971!?      CALL ipslerr (3,'fliocrfd', & 
     972!? &     'Netcdf4 format','and offset option','are not compatible') 
     973!?    ELSE IF (i_opt(4) == k_classic) THEN 
     974!?      m_c = IOR(m_c,NF90_CLASSIC_MODEL) 
     975!?    ENDIF 
     976!?   LSE IF (i_opt(4) > 0) THEN 
     977!?    CALL ipslerr (3,'fliocrfd', & 
     978!? &   'Netcdf default format','and classic option','are not compatible') 
     979!?  ELSE IF (i_opt(3) /= k_32) THEN 
     980!?    m_c = IOR(m_c,NF90_64BIT_OFFSET) 
     981!?  ENDIF 
    900982!- 
    901983! Create file (and enter the definition mode) 
     
    12301312! Ensuring data mode 
    12311313!- 
    1232     CALL flio_hdm (f_i,f_e,.FALSE.) 
     1314  CALL flio_hdm (f_i,f_e,.FALSE.) 
    12331315!- 
    12341316! Create the longitude axis 
     
    22252307!- 
    22262308  IF (PRESENT(mode)) THEN 
    2227     IF (TRIM(MODE) == "WRITE") THEN 
     2309    IF (TRIM(mode) == "WRITE") THEN 
    22282310      m_c = NF90_WRITE 
    22292311    ELSE 
     
    49415023  INTEGER :: kv,k,n_r,l_d,n_d,i_rc,dimnb 
    49425024  CHARACTER(LEN=1)  :: c_ax 
    4943   CHARACTER(LEN=9) :: c_sn 
     5025  CHARACTER(LEN=18) :: c_sn 
    49445026  CHARACTER(LEN=15),DIMENSION(10) :: c_r 
    49455027  CHARACTER(LEN=40) :: c_t1,c_t2 
  • IOIPSL/trunk/src/stringop.f90

    r386 r936  
    55! This software is governed by the CeCILL license 
    66! See IOIPSL/IOIPSL_License_CeCILL.txt 
    7 !--------------------------------------------------------------------- 
    8 !- 
    9   INTEGER,DIMENSION(30) :: & 
    10  & prime=(/1,2,3,5,7,11,13,17,19,23,29,31,37,41,43, & 
    11  & 47,53,59,61,67,71,73,79,83,89,97,101,103,107,109/) 
    12 !- 
    137!--------------------------------------------------------------------- 
    148CONTAINS 
     
    160154END SUBROUTINE struppercase 
    161155!=== 
    162 SUBROUTINE gensig (str,sig) 
     156SUBROUTINE str_xfw (c_string,c_word,l_ok) 
    163157!--------------------------------------------------------------------- 
    164 !- Generate a signature from the first 30 characters of the string 
    165 !- This signature is not unique and thus when one looks for the 
    166 !- one needs to also verify the string. 
     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" 
    167162!--------------------------------------------------------------------- 
    168   IMPLICIT NONE 
     163  CHARACTER(LEN=*),INTENT(INOUT) :: c_string 
     164  CHARACTER(LEN=*),INTENT(OUT) :: c_word 
     165  LOGICAL,INTENT(OUT) :: l_ok 
    169166!- 
    170   CHARACTER(LEN=*) :: str 
    171   INTEGER          :: sig 
    172 !- 
    173   INTEGER :: i 
     167  INTEGER :: i_b,i_e 
    174168!--------------------------------------------------------------------- 
    175   sig = 0 
    176   DO i=1,MIN(LEN_TRIM(str),30) 
    177     sig = sig + prime(i)*IACHAR(str(i:i)) 
    178   ENDDO 
    179 !-------------------- 
    180 END SUBROUTINE gensig 
    181 !=== 
    182 SUBROUTINE find_sig (nb_sig,str_tab,str,sig_tab,sig,pos) 
    183 !--------------------------------------------------------------------- 
    184 !- Find the string signature in a list of signatures 
    185 !--------------------------------------------------------------------- 
    186 !- INPUT 
    187 !-   nb_sig      : length of table of signatures 
    188 !-   str_tab     : Table of strings 
    189 !-   str         : Target string we are looking for 
    190 !-   sig_tab     : Table of signatures 
    191 !-   sig         : Target signature we are looking for 
    192 !- OUTPUT 
    193 !-   pos         : -1 if str not found, else value in the table 
    194 !--------------------------------------------------------------------- 
    195   IMPLICIT NONE 
    196 !- 
    197   INTEGER :: nb_sig 
    198   CHARACTER(LEN=*),DIMENSION(nb_sig) :: str_tab 
    199   CHARACTER(LEN=*) :: str 
    200   INTEGER,DIMENSION(nb_sig) :: sig_tab 
    201   INTEGER :: sig 
    202 !- 
    203   INTEGER :: pos 
    204   INTEGER,DIMENSION(nb_sig) :: loczeros 
    205 !- 
    206   INTEGER :: il,len 
    207   INTEGER,DIMENSION(1) :: minpos 
    208 !--------------------------------------------------------------------- 
    209   pos = -1 
    210   il = LEN_TRIM(str) 
    211 !- 
    212   IF ( nb_sig > 0 ) THEN 
    213     loczeros = ABS(sig_tab(1:nb_sig)-sig) 
    214     IF ( COUNT(loczeros < 1) == 1 ) THEN 
    215       minpos = MINLOC(loczeros) 
    216       len = LEN_TRIM(str_tab(minpos(1))) 
    217       IF (     (INDEX(str_tab(minpos(1)),str(1:il)) > 0) & 
    218           .AND.(len == il) ) THEN 
    219         pos = minpos(1) 
    220       ENDIF 
    221     ELSE IF ( COUNT(loczeros < 1) > 1 ) THEN 
    222       DO WHILE (COUNT(loczeros < 1) >= 1 .AND. pos < 0 ) 
    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         ELSE 
    229           loczeros(minpos(1)) = 99999 
    230         ENDIF 
    231       ENDDO 
     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:)) 
    232179    ENDIF 
    233180  ENDIF 
    234 !----------------------- 
    235  END SUBROUTINE find_sig 
     181!--------------------- 
     182END SUBROUTINE str_xfw 
    236183!=== 
    237184!------------------ 
Note: See TracChangeset for help on using the changeset viewer.