Changeset 936 for IOIPSL

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:

• fliocom.f90 (modified) (7 diffs)
• stringop.f90 (modified) (2 diffs)

IOIPSL/trunk/src/fliocom.f90

@@ -12 +12 @@
  &                    ioconf_calendar,ju2ymds,ymds2ju
 USE errioipsl, ONLY : ipslerr,ipsldbg
-USE stringop,  ONLY : strlowercase
+USE stringop,  ONLY : strlowercase,str_xfw
 !-
 IMPLICIT NONE
@@ -86 +86 @@
 !!              This argument can be equal to FLIO_DOM_DEFAULT
 !!              (see "flio_dom_defset").
-!! (C) mode   : Mode used to create the file.
-!!              Supported modes : REPLACE, REP, 32, 64, REP32, REP64.
-!!              If this argument is present with the value "REP[32/64]"
-!!              or the value "REPLACE", the file will be created
-!!              in mode "CLOBBER", else the file will be created
-!!              in mode "NOCLOBBER".
+!! (C) mode   : String of (case insensitive) blank-separated words
+!!              defining the mode used to create the file.
+!!              Supported keywords : REPLACE, 32, 64
+!!              If this argument is present with the keyword "REPLACE",
+!!              the file will be created in mode "CLOBBER",
+!!              else the file will be created in mode "NOCLOBBER".
 !!              "32/64" defines the offset mode.
-!!              The default offset mode is 32 bits.
+!!              The default offset mode is 64 bits.
+!!              Keywords "NETCDF4" and "CLASSIC" are reserved
+!!              for future use.
 !!
 !! Optional OUTPUT arguments
@@ -849 +851 @@
   INTEGER :: i_rc,f_e,idid,ii,m_c,n_u
   CHARACTER(LEN=NF90_MAX_NAME) :: f_nw
+  INTEGER,PARAMETER :: l_string=80,l_word=10
+  CHARACTER(LEN=l_string) :: c_string
+  CHARACTER(LEN=l_word)   :: c_word
+  LOGICAL :: l_ok
+  INTEGER,PARAMETER :: k_replace=1
+  INTEGER,PARAMETER :: k_32=1,k_64=2
+!- !? : Code to be activated for NETCDF4
+!?  INTEGER,PARAMETER :: k_netcdf4=1,k_classic=1
+  INTEGER,PARAMETER :: n_opt=4
+  INTEGER,DIMENSION(n_opt) :: i_opt
 !-
   LOGICAL :: l_dbg
@@ -882 +894 @@
 !-
 ! Check the mode
+!-
+  i_opt(:)=-1
+!-
   IF (PRESENT(mode)) THEN
-    SELECT CASE (TRIM(mode))
-    CASE('REPLACE','REP','REP64')
-      m_c = IOR(NF90_CLOBBER,NF90_64BIT_OFFSET)
-    CASE('REP32')
-      m_c = NF90_CLOBBER
-    CASE('32')
-      m_c = NF90_NOCLOBBER
-    CASE('64')
-      m_c = IOR(NF90_NOCLOBBER,NF90_64BIT_OFFSET)
-    CASE DEFAULT
-      m_c = IOR(NF90_NOCLOBBER,NF90_64BIT_OFFSET)
-    END SELECT
+!---
+    IF (LEN_TRIM(mode) > l_string) THEN
+      CALL ipslerr (3,'fliocrfd', &
+ &     '"mode" argument','too long','to be treated')
+    ENDIF
+    c_string = mode(:)
+    CALL strlowercase (c_string)
+!---
+    DO
+      CALL str_xfw  (c_string,c_word,l_ok)
+      IF (l_ok) THEN
+!- !? : Code to be activated for NETCDF4
+        SELECT CASE (TRIM(c_word))
+        CASE('replace')
+          IF (i_opt(1) > 0) THEN
+            CALL ipslerr (3,'fliocrfd', &
+ &           'Replace option','already','defined')
+          ELSE
+            i_opt(1) = k_replace
+          ENDIF
+!?      CASE('netcdf4')
+!?        IF (i_opt(2) > 0) THEN
+!?          CALL ipslerr (3,'fliocrfd', &
+!? &         'Netcdf4 format','already','defined')
+!?        ELSE
+!?          i_opt(2) = k_netcdf4
+!?        ENDIF
+        CASE('32')
+          IF (i_opt(3) > 0) THEN
+            CALL ipslerr (3,'fliocrfd', &
+ &           'Offset format','already','defined')
+          ELSE
+            i_opt(3) = k_32
+          ENDIF
+        CASE('64')
+          IF (i_opt(3) > 0) THEN
+            CALL ipslerr (3,'fliocrfd', &
+ &           'Offset format','already','defined')
+          ELSE
+            i_opt(3) = k_64
+          ENDIF
+!?      CASE('CLASSIC')
+!?        IF (i_opt(4) > 0) THEN
+!?          CALL ipslerr (3,'fliocrfd', &
+!? &         'Netcdf4 classic format','already','defined')
+!?        ELSE
+!?          i_opt(4) = k_classic
+!?        ENDIF
+        CASE DEFAULT
+          CALL ipslerr (3,'fliocrfd', &
+ &         'Option '//TRIM(c_word),'not','supported')
+        END SELECT
+      ELSE
+        EXIT
+      ENDIF
+    ENDDO
+  ENDIF
+!-
+  IF (i_opt(1) == k_replace) THEN
+    m_c = NF90_CLOBBER
   ELSE
-    m_c = IOR(NF90_NOCLOBBER,NF90_64BIT_OFFSET)
-  ENDIF
+    m_c = NF90_NOCLOBBER
+  ENDIF
+!-
+!- Code to be replaced by the following for NETCDF4
+  IF (i_opt(3) /= k_32) THEN
+    m_c = IOR(m_c,NF90_64BIT_OFFSET)
+  ENDIF
+!?  IF (i_opt(2) == k_netcdf4) THEN
+!?    m_c = IOR(m_c,NF90_NETCDF4)
+!?    IF (i_opt(3) > 0) THEN
+!?      CALL ipslerr (3,'fliocrfd', &
+!? &     'Netcdf4 format','and offset option','are not compatible')
+!?    ELSE IF (i_opt(4) == k_classic) THEN
+!?      m_c = IOR(m_c,NF90_CLASSIC_MODEL)
+!?    ENDIF
+!?   LSE IF (i_opt(4) > 0) THEN
+!?    CALL ipslerr (3,'fliocrfd', &
+!? &   'Netcdf default format','and classic option','are not compatible')
+!?  ELSE IF (i_opt(3) /= k_32) THEN
+!?    m_c = IOR(m_c,NF90_64BIT_OFFSET)
+!?  ENDIF
 !-
 ! Create file (and enter the definition mode)
@@ -1230 +1312 @@
 ! Ensuring data mode
 !-
-    CALL flio_hdm (f_i,f_e,.FALSE.)
+  CALL flio_hdm (f_i,f_e,.FALSE.)
 !-
 ! Create the longitude axis
@@ -2225 +2307 @@
 !-
   IF (PRESENT(mode)) THEN
-    IF (TRIM(MODE) == "WRITE") THEN
+    IF (TRIM(mode) == "WRITE") THEN
       m_c = NF90_WRITE
     ELSE
@@ -4941 +5023 @@
   INTEGER :: kv,k,n_r,l_d,n_d,i_rc,dimnb
   CHARACTER(LEN=1)  :: c_ax
-  CHARACTER(LEN=9)  :: c_sn
+  CHARACTER(LEN=18) :: c_sn
   CHARACTER(LEN=15),DIMENSION(10) :: c_r
   CHARACTER(LEN=40) :: c_t1,c_t2

IOIPSL/trunk/src/stringop.f90

@@ -5 +5 @@
 ! This software is governed by the CeCILL license
 ! See IOIPSL/IOIPSL_License_CeCILL.txt
-!---------------------------------------------------------------------
-!-
-  INTEGER,DIMENSION(30) :: &
- & prime=(/1,2,3,5,7,11,13,17,19,23,29,31,37,41,43, &
- & 47,53,59,61,67,71,73,79,83,89,97,101,103,107,109/)
-!-
 !---------------------------------------------------------------------
 CONTAINS
@@ -160 +154 @@
 END SUBROUTINE struppercase
 !===
-SUBROUTINE gensig (str,sig)
+SUBROUTINE str_xfw (c_string,c_word,l_ok)
 !---------------------------------------------------------------------
-!- Generate a signature from the first 30 characters of the string
-!- This signature is not unique and thus when one looks for the
-!- one needs to also verify the string.
+!- Given a character string "c_string", of arbitrary length,
+!- returns a logical flag "l_ok" if a word is found in it,
+!- the first word "c_word" if found and the new string "c_string"
+!- without the first word "c_word"
 !---------------------------------------------------------------------
-  IMPLICIT NONE
+  CHARACTER(LEN=*),INTENT(INOUT) :: c_string
+  CHARACTER(LEN=*),INTENT(OUT) :: c_word
+  LOGICAL,INTENT(OUT) :: l_ok
 !-
-  CHARACTER(LEN=*) :: str
-  INTEGER          :: sig
-!-
-  INTEGER :: i
+  INTEGER :: i_b,i_e
 !---------------------------------------------------------------------
-  sig = 0
-  DO i=1,MIN(LEN_TRIM(str),30)
-    sig = sig + prime(i)*IACHAR(str(i:i))
-  ENDDO
-!--------------------
-END SUBROUTINE gensig
-!===
-SUBROUTINE find_sig (nb_sig,str_tab,str,sig_tab,sig,pos)
-!---------------------------------------------------------------------
-!- Find the string signature in a list of signatures
-!---------------------------------------------------------------------
-!- INPUT
-!-   nb_sig      : length of table of signatures
-!-   str_tab     : Table of strings
-!-   str         : Target string we are looking for
-!-   sig_tab     : Table of signatures
-!-   sig         : Target signature we are looking for
-!- OUTPUT
-!-   pos         : -1 if str not found, else value in the table
-!---------------------------------------------------------------------
-  IMPLICIT NONE
-!-
-  INTEGER :: nb_sig
-  CHARACTER(LEN=*),DIMENSION(nb_sig) :: str_tab
-  CHARACTER(LEN=*) :: str
-  INTEGER,DIMENSION(nb_sig) :: sig_tab
-  INTEGER :: sig
-!-
-  INTEGER :: pos
-  INTEGER,DIMENSION(nb_sig) :: loczeros
-!-
-  INTEGER :: il,len
-  INTEGER,DIMENSION(1) :: minpos
-!---------------------------------------------------------------------
-  pos = -1
-  il = LEN_TRIM(str)
-!-
-  IF ( nb_sig > 0 ) THEN
-    loczeros = ABS(sig_tab(1:nb_sig)-sig)
-    IF ( COUNT(loczeros < 1) == 1 ) THEN
-      minpos = MINLOC(loczeros)
-      len = LEN_TRIM(str_tab(minpos(1)))
-      IF (     (INDEX(str_tab(minpos(1)),str(1:il)) > 0) &
-          .AND.(len == il) ) THEN
-        pos = minpos(1)
-      ENDIF
-    ELSE IF ( COUNT(loczeros < 1) > 1 ) THEN
-      DO WHILE (COUNT(loczeros < 1) >= 1 .AND. pos < 0 )
-        minpos = MINLOC(loczeros)
-        len = LEN_TRIM(str_tab(minpos(1)))
-        IF (     (INDEX(str_tab(minpos(1)),str(1:il)) > 0) &
-            .AND.(len == il) ) THEN
-          pos = minpos(1)
-        ELSE
-          loczeros(minpos(1)) = 99999
-        ENDIF
-      ENDDO
+  l_ok = (LEN_TRIM(c_string) > 0)
+  IF (l_ok) THEN
+    i_b = VERIFY(c_string,' ')
+    i_e = INDEX(c_string(i_b:),' ')
+    IF (i_e == 0) THEN
+      c_word = c_string(i_b:)
+      c_string = ""
+    ELSE
+      c_word = c_string(i_b:i_b+i_e-2)
+      c_string = ADJUSTL(c_string(i_b+i_e-1:))
     ENDIF
   ENDIF
-!-----------------------
- END SUBROUTINE find_sig
+!---------------------
+END SUBROUTINE str_xfw
 !===
 !------------------