Changeset 936 for IOIPSL/trunk
- Timestamp:
- 03/04/10 12:01:32 (15 years ago)
- Location:
- IOIPSL/trunk/src
- Files:
-
- 2 edited
Legend:
- Unmodified
- Added
- Removed
-
IOIPSL/trunk/src/fliocom.f90
r886 r936 12 12 & ioconf_calendar,ju2ymds,ymds2ju 13 13 USE errioipsl, ONLY : ipslerr,ipsldbg 14 USE stringop, ONLY : strlowercase 14 USE stringop, ONLY : strlowercase,str_xfw 15 15 !- 16 16 IMPLICIT NONE … … 86 86 !! This argument can be equal to FLIO_DOM_DEFAULT 87 87 !! (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 created92 !! in mode "CLOBBER", else the file will be created93 !! 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". 94 94 !! "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. 96 98 !! 97 99 !! Optional OUTPUT arguments … … 849 851 INTEGER :: i_rc,f_e,idid,ii,m_c,n_u 850 852 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 851 863 !- 852 864 LOGICAL :: l_dbg … … 882 894 !- 883 895 ! Check the mode 896 !- 897 i_opt(:)=-1 898 !- 884 899 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 897 960 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 900 982 !- 901 983 ! Create file (and enter the definition mode) … … 1230 1312 ! Ensuring data mode 1231 1313 !- 1232 1314 CALL flio_hdm (f_i,f_e,.FALSE.) 1233 1315 !- 1234 1316 ! Create the longitude axis … … 2225 2307 !- 2226 2308 IF (PRESENT(mode)) THEN 2227 IF (TRIM( MODE) == "WRITE") THEN2309 IF (TRIM(mode) == "WRITE") THEN 2228 2310 m_c = NF90_WRITE 2229 2311 ELSE … … 4941 5023 INTEGER :: kv,k,n_r,l_d,n_d,i_rc,dimnb 4942 5024 CHARACTER(LEN=1) :: c_ax 4943 CHARACTER(LEN= 9):: c_sn5025 CHARACTER(LEN=18) :: c_sn 4944 5026 CHARACTER(LEN=15),DIMENSION(10) :: c_r 4945 5027 CHARACTER(LEN=40) :: c_t1,c_t2 -
IOIPSL/trunk/src/stringop.f90
r386 r936 5 5 ! This software is governed by the CeCILL license 6 6 ! 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 !-13 7 !--------------------------------------------------------------------- 14 8 CONTAINS … … 160 154 END SUBROUTINE struppercase 161 155 !=== 162 SUBROUTINE gensig (str,sig)156 SUBROUTINE str_xfw (c_string,c_word,l_ok) 163 157 !--------------------------------------------------------------------- 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" 167 162 !--------------------------------------------------------------------- 168 IMPLICIT NONE 163 CHARACTER(LEN=*),INTENT(INOUT) :: c_string 164 CHARACTER(LEN=*),INTENT(OUT) :: c_word 165 LOGICAL,INTENT(OUT) :: l_ok 169 166 !- 170 CHARACTER(LEN=*) :: str 171 INTEGER :: sig 172 !- 173 INTEGER :: i 167 INTEGER :: i_b,i_e 174 168 !--------------------------------------------------------------------- 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:)) 232 179 ENDIF 233 180 ENDIF 234 !--------------------- --235 END SUBROUTINE find_sig 181 !--------------------- 182 END SUBROUTINE str_xfw 236 183 !=== 237 184 !------------------
Note: See TracChangeset
for help on using the changeset viewer.