Changeset 1991 for vendors/IOIPSL/current/src/fliocom.f90
- Timestamp:
- 2010-07-08T15:39:26+02:00 (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
vendors/IOIPSL/current/src/fliocom.f90
r1895 r1991 1 1 MODULE fliocom 2 2 !- 3 !$Id: fliocom.f90 386 2008-09-04 08:38:48Z bellier $3 !$Id: fliocom.f90 965 2010-04-07 08:38:54Z bellier $ 4 4 !- 5 5 ! This software is governed by the CeCILL license … … 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 … … 205 207 !! SUBROUTINE fliodefv & 206 208 !! & (f_i,v_n,[v_d],v_t, & 207 !! & axis,standard_name,long_name,units,valid_min,valid_max) 209 !! & axis,standard_name,long_name,units, & 210 !! & valid_min,valid_max,fillvalue) 208 211 !! 209 212 !! INPUT … … 227 230 !! (C) axis,standard_name,long_name,units : Attributes 228 231 !! (axis should be used only for coordinates) 229 !! (R) valid_min,valid_max : Attributes232 !! (R) valid_min,valid_max,fillvalue : Attributes 230 233 !!-------------------------------------------------------------------- 231 234 MODULE PROCEDURE & … … 805 808 !- 806 809 ! Maximum number of simultaneously defined domains 807 INTEGER,PARAMETER :: dom_max_nb= 10810 INTEGER,PARAMETER :: dom_max_nb=64 808 811 !- 809 812 ! Maximum number of distributed dimensions for each domain … … 848 851 INTEGER :: i_rc,f_e,idid,ii,m_c,n_u 849 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 850 863 !- 851 864 LOGICAL :: l_dbg … … 881 894 !- 882 895 ! Check the mode 896 !- 897 i_opt(:)=-1 898 !- 883 899 IF (PRESENT(mode)) THEN 884 SELECT CASE (TRIM(mode)) 885 CASE('REPLACE','REP','REP32') 886 m_c = NF90_CLOBBER 887 CASE('32') 888 m_c = NF90_NOCLOBBER 889 CASE('64') 890 m_c = IOR(NF90_NOCLOBBER,NF90_64BIT_OFFSET) 891 CASE('REP64') 892 m_c = IOR(NF90_CLOBBER,NF90_64BIT_OFFSET) 893 CASE DEFAULT 894 m_c = NF90_NOCLOBBER 895 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 896 960 ELSE 897 961 m_c = NF90_NOCLOBBER 898 962 ENDIF 963 !- 964 !- Code to be replaced by the following for NETCDF4 965 !? IF (i_opt(2) == k_netcdf4) THEN 966 !? m_c = IOR(m_c,NF90_NETCDF4) 967 !? IF (i_opt(3) > 0) THEN 968 !? CALL ipslerr (3,'fliocrfd', & 969 !? & 'Netcdf4 format','and offset option','are not compatible') 970 !? ELSE IF (i_opt(4) == k_classic) THEN 971 !? m_c = IOR(m_c,NF90_CLASSIC_MODEL) 972 !? ENDIF 973 !? LSE IF (i_opt(4) > 0) THEN 974 !? CALL ipslerr (3,'fliocrfd', & 975 !? & 'Classic option','is reserved','for the Netcdf4 format') 976 !? ELSE 977 IF (i_opt(3) /= k_32) THEN 978 m_c = IOR(m_c,NF90_64BIT_OFFSET) 979 ENDIF 980 !? ENDIF 899 981 !- 900 982 ! Create file (and enter the definition mode) … … 1229 1311 ! Ensuring data mode 1230 1312 !- 1231 1313 CALL flio_hdm (f_i,f_e,.FALSE.) 1232 1314 !- 1233 1315 ! Create the longitude axis … … 1287 1369 SUBROUTINE fliodv_r0d & 1288 1370 & (f_i,v_n,v_t, & 1289 & axis,standard_name,long_name,units,valid_min,valid_max )1371 & axis,standard_name,long_name,units,valid_min,valid_max,fillvalue) 1290 1372 !--------------------------------------------------------------------- 1291 1373 IMPLICIT NONE … … 1296 1378 CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: & 1297 1379 & axis,standard_name,long_name,units 1298 REAL,OPTIONAL,INTENT(IN) :: valid_min,valid_max 1380 REAL,OPTIONAL,INTENT(IN) :: valid_min,valid_max,fillvalue 1299 1381 !--------------------------------------------------------------------- 1300 1382 CALL flio_udv & 1301 1383 & (f_i,0,v_n,(/0/),v_t, & 1302 & axis,standard_name,long_name,units,valid_min,valid_max )1384 & axis,standard_name,long_name,units,valid_min,valid_max,fillvalue) 1303 1385 !------------------------ 1304 1386 END SUBROUTINE fliodv_r0d … … 1306 1388 SUBROUTINE fliodv_rnd & 1307 1389 & (f_i,v_n,v_d,v_t, & 1308 & axis,standard_name,long_name,units,valid_min,valid_max )1390 & axis,standard_name,long_name,units,valid_min,valid_max,fillvalue) 1309 1391 !--------------------------------------------------------------------- 1310 1392 IMPLICIT NONE … … 1316 1398 CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: & 1317 1399 & axis,standard_name,long_name,units 1318 REAL,OPTIONAL,INTENT(IN) :: valid_min,valid_max 1400 REAL,OPTIONAL,INTENT(IN) :: valid_min,valid_max,fillvalue 1319 1401 !--------------------------------------------------------------------- 1320 1402 CALL flio_udv & 1321 1403 & (f_i,SIZE(v_d),v_n,v_d,v_t, & 1322 & axis,standard_name,long_name,units,valid_min,valid_max )1404 & axis,standard_name,long_name,units,valid_min,valid_max,fillvalue) 1323 1405 !------------------------ 1324 1406 END SUBROUTINE fliodv_rnd … … 1326 1408 SUBROUTINE flio_udv & 1327 1409 & (f_i,n_d,v_n,v_d,v_t, & 1328 & axis,standard_name,long_name,units,valid_min,valid_max )1410 & axis,standard_name,long_name,units,valid_min,valid_max,fillvalue) 1329 1411 !--------------------------------------------------------------------- 1330 1412 IMPLICIT NONE … … 1336 1418 CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: & 1337 1419 & axis,standard_name,long_name,units 1338 REAL,OPTIONAL,INTENT(IN) :: valid_min,valid_max 1420 REAL,OPTIONAL,INTENT(IN) :: valid_min,valid_max,fillvalue 1339 1421 !- 1340 1422 INTEGER :: f_e,m_k,i_v,i_rc,ii,idd … … 1380 1462 !--- 1381 1463 IF (PRESENT(v_t)) THEN 1382 IF (v_t == flio_i) THEN 1464 SELECT CASE (v_t) 1465 CASE(flio_i) 1383 1466 IF (i_std == i_8) THEN 1384 !-------- Not yet supported by NETCDF1467 !-------- I8 not yet supported by NETCDF 1385 1468 !-------- m_k = flio_i8 1386 1469 m_k = flio_i4 … … 1388 1471 m_k = flio_i4 1389 1472 ENDIF 1390 ELSE IF (v_t == flio_r) THEN1473 CASE(flio_r) 1391 1474 IF (r_std == r_8) THEN 1392 1475 m_k = flio_r8 … … 1394 1477 m_k = flio_r4 1395 1478 ENDIF 1396 ELSE1479 CASE(flio_c,flio_i1,flio_i2,flio_i4,flio_r4,flio_r8) 1397 1480 m_k = v_t 1398 ENDIF 1481 CASE DEFAULT 1482 CALL ipslerr (3,'fliodefv', & 1483 & 'Variable '//TRIM(v_n),'External type','not supported') 1484 END SELECT 1399 1485 ELSE IF (r_std == r_8) THEN 1400 1486 m_k = flio_r8 … … 1402 1488 m_k = flio_r4 1403 1489 ENDIF 1490 !--- 1404 1491 IF (n_d > 0) THEN 1405 1492 i_rc = NF90_DEF_VAR(f_e,v_n,m_k,a_i(1:n_d),i_v) … … 1427 1514 ENDIF 1428 1515 IF (PRESENT(valid_min)) THEN 1429 i_rc = NF90_PUT_ATT(f_e,i_v,'valid_min',valid_min) 1516 SELECT CASE (m_k) 1517 CASE(flio_i1,flio_i2) 1518 i_rc = NF90_PUT_ATT(f_e,i_v,'valid_min',NINT(valid_min,KIND=i_2)) 1519 CASE(flio_i4) 1520 i_rc = NF90_PUT_ATT(f_e,i_v,'valid_min',NINT(valid_min,KIND=i_4)) 1521 CASE(flio_r4) 1522 i_rc = NF90_PUT_ATT(f_e,i_v,'valid_min',REAL(valid_min,KIND=r_4)) 1523 CASE(flio_r8) 1524 i_rc = NF90_PUT_ATT(f_e,i_v,'valid_min',REAL(valid_min,KIND=r_8)) 1525 CASE DEFAULT 1526 CALL ipslerr (2,'fliodefv', & 1527 & 'Variable '//TRIM(v_n),'attribute valid_min', & 1528 & 'not supported for this external type') 1529 END SELECT 1430 1530 ENDIF 1431 1531 IF (PRESENT(valid_max)) THEN 1432 i_rc = NF90_PUT_ATT(f_e,i_v,'valid_max',valid_max) 1532 SELECT CASE (m_k) 1533 CASE(flio_i1,flio_i2) 1534 i_rc = NF90_PUT_ATT(f_e,i_v,'valid_max',NINT(valid_max,KIND=i_2)) 1535 CASE(flio_i4) 1536 i_rc = NF90_PUT_ATT(f_e,i_v,'valid_max',NINT(valid_max,KIND=i_4)) 1537 CASE(flio_r4) 1538 i_rc = NF90_PUT_ATT(f_e,i_v,'valid_max',REAL(valid_max,KIND=r_4)) 1539 CASE(flio_r8) 1540 i_rc = NF90_PUT_ATT(f_e,i_v,'valid_max',REAL(valid_max,KIND=r_8)) 1541 CASE DEFAULT 1542 CALL ipslerr (2,'fliodefv', & 1543 & 'Variable '//TRIM(v_n),'attribute valid_max', & 1544 & 'not supported for this external type') 1545 END SELECT 1546 ENDIF 1547 IF (PRESENT(fillvalue)) THEN 1548 SELECT CASE (m_k) 1549 CASE(flio_i1,flio_i2) 1550 i_rc = NF90_PUT_ATT(f_e,i_v,'_FillValue',NINT(fillvalue,KIND=i_2)) 1551 CASE(flio_i4) 1552 i_rc = NF90_PUT_ATT(f_e,i_v,'_FillValue',NINT(fillvalue,KIND=i_4)) 1553 CASE(flio_r4) 1554 i_rc = NF90_PUT_ATT(f_e,i_v,'_FillValue',REAL(fillvalue,KIND=r_4)) 1555 CASE(flio_r8) 1556 i_rc = NF90_PUT_ATT(f_e,i_v,'_FillValue',REAL(fillvalue,KIND=r_8)) 1557 CASE DEFAULT 1558 CALL ipslerr (2,'fliodefv', & 1559 & 'Variable '//TRIM(v_n),'attribute fillvalue', & 1560 & 'not supported for this external type') 1561 END SELECT 1433 1562 ENDIF 1434 1563 !--- … … 2177 2306 !- 2178 2307 IF (PRESENT(mode)) THEN 2179 IF (TRIM( MODE) == "WRITE") THEN2308 IF (TRIM(mode) == "WRITE") THEN 2180 2309 m_c = NF90_WRITE 2181 2310 ELSE … … 4893 5022 INTEGER :: kv,k,n_r,l_d,n_d,i_rc,dimnb 4894 5023 CHARACTER(LEN=1) :: c_ax 4895 CHARACTER(LEN= 9):: c_sn5024 CHARACTER(LEN=18) :: c_sn 4896 5025 CHARACTER(LEN=15),DIMENSION(10) :: c_r 4897 5026 CHARACTER(LEN=40) :: c_t1,c_t2
Note: See TracChangeset
for help on using the changeset viewer.