Changeset 4106 for palm/trunk/SOURCE/data_output_module.f90
- Timestamp:
- Jul 19, 2019 8:54:42 AM (5 years ago)
- File:
-
- 1 edited
-
palm/trunk/SOURCE/data_output_module.f90 (modified) (41 diffs)
Legend:
- Unmodified
- Added
- Removed
-
palm/trunk/SOURCE/data_output_module.f90
r4070 r4106 20 20 ! Current revisions: 21 21 ! ------------------ 22 ! 23 ! 22 ! 23 ! 24 24 ! Former revisions: 25 25 ! ----------------- … … 43 43 !> 44 44 !> @todo Convert variable if type of given values do not fit specified type. 45 !> @todo Remove unused variables46 !> @todo How to deal with definition calls after dom_start_output is called? Should it be allowed47 !> to define new files after that (which is technically possible)?48 45 !> @todo Remove iwp from index (and similar) variables. 49 46 !--------------------------------------------------------------------------------------------------! … … 52 49 USE kinds 53 50 54 USE data_output_netcdf4_serial_module, & 55 ONLY: netcdf4_serial_init_dimension, & 56 netcdf4_serial_get_error_message, & 57 netcdf4_serial_init_end, & 58 netcdf4_serial_init_module, & 59 netcdf4_serial_init_variable, & 60 netcdf4_serial_finalize, & 61 netcdf4_serial_open_file, & 62 netcdf4_serial_write_attribute, & 63 netcdf4_serial_write_variable 64 65 USE data_output_netcdf4_parallel_module, & 66 ONLY: netcdf4_parallel_init_dimension, & 67 netcdf4_parallel_get_error_message, & 68 netcdf4_parallel_init_end, & 69 netcdf4_parallel_init_module, & 70 netcdf4_parallel_init_variable, & 71 netcdf4_parallel_finalize, & 72 netcdf4_parallel_open_file, & 73 netcdf4_parallel_write_attribute, & 74 netcdf4_parallel_write_variable 51 USE data_output_netcdf4_module, & 52 ONLY: netcdf4_init_dimension, & 53 netcdf4_get_error_message, & 54 netcdf4_init_end, & 55 netcdf4_init_module, & 56 netcdf4_init_variable, & 57 netcdf4_finalize, & 58 netcdf4_open_file, & 59 netcdf4_write_attribute, & 60 netcdf4_write_variable 75 61 76 62 USE data_output_binary_module, & … … 105 91 INTEGER(iwp) :: id = 0 !< id within file 106 92 LOGICAL :: is_global = .FALSE. !< true if global variable 107 LOGICAL :: is_init = .FALSE. !< true if initialized108 93 CHARACTER(LEN=charlen), DIMENSION(:), ALLOCATABLE :: dimension_names !< list of dimension names 109 94 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: dimension_ids !< list of dimension ids … … 118 103 INTEGER(iwp) :: length_mask !< length of masked dimension 119 104 INTEGER(iwp) :: var_id = 0 !< associated variable id within file 120 LOGICAL :: is_init = .FALSE. !< true if initialized121 105 LOGICAL :: is_masked = .FALSE. !< true if masked 122 106 INTEGER(iwp), DIMENSION(2) :: bounds !< lower and upper bound of dimension … … 125 109 INTEGER(KIND=2), DIMENSION(:), ALLOCATABLE :: masked_values_int16 !< masked dimension values if 16bit integer 126 110 INTEGER(KIND=4), DIMENSION(:), ALLOCATABLE :: masked_values_int32 !< masked dimension values if 32bit integer 127 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: masked_values_intwp !< masked dimension values if working-precision int eger111 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: masked_values_intwp !< masked dimension values if working-precision int 128 112 INTEGER(KIND=1), DIMENSION(:), ALLOCATABLE :: values_int8 !< dimension values if 16bit integer 129 113 INTEGER(KIND=2), DIMENSION(:), ALLOCATABLE :: values_int16 !< dimension values if 16bit integer … … 252 236 CALL binary_init_module( debug_output_unit, debug_output, no_var_id ) 253 237 254 CALL netcdf4_serial_init_module( debug_output_unit, debug_output, no_var_id ) 255 256 CALL netcdf4_parallel_init_module( debug_output_unit, debug_output, no_var_id ) 238 CALL netcdf4_init_module( debug_output_unit, debug_output, no_var_id ) 257 239 258 240 END SUBROUTINE dom_init … … 310 292 ! WRITE(*,'(10X,5(I5,1X),A)') files(f)%dimensions(d)%values_int32(0:MIN(4,files(f)%dimensions(d)%length)), '...' 311 293 ! ELSE 312 ! WRITE(*,'(10X,5(F8.2,1X),A)') files(f)%dimensions(d)%values_real64(0:MIN(4,files(f)%dimensions(d)%length)), '...' 294 ! WRITE(*,'(10X,5(F8.2,1X),A)') & 295 ! files(f)%dimensions(d)%values_real64(0:MIN(4,files(f)%dimensions(d)%length)), '...' 313 296 ! ENDIF 314 297 ! IF ( ALLOCATED(files(f)%dimensions(d)%mask) ) THEN … … 716 699 717 700 return_value = 1 718 CALL internal_message( 'error', routine_name // 719 720 701 CALL internal_message( 'error', routine_name // & 702 ': dimension ' // TRIM( name ) // & 703 ': At least one but no more than two bounds must be given' ) 721 704 722 705 ENDIF … … 729 712 IF ( TRIM( filename ) == files(f)%name ) THEN 730 713 731 IF ( .NOT. ALLOCATED( files(f)%dimensions ) ) THEN 714 IF ( files(f)%is_init ) THEN 715 716 return_value = 1 717 CALL internal_message( 'error', & 718 routine_name // ': file "' // TRIM( filename ) // & 719 '" is already initialized. No further dimension definition allowed!' ) 720 EXIT 721 722 ELSEIF ( .NOT. ALLOCATED( files(f)%dimensions ) ) THEN 732 723 733 724 ndim = 1 … … 736 727 ELSE 737 728 738 ndim = SIZE( files(f)%dimensions ) 739 740 !-- Check if dimension already exists in file 741 DO d = 1, ndim 742 IF ( files(f)%dimensions(d)%name == dimension%name ) THEN 743 return_value = 1 744 CALL internal_message( 'error', & 745 routine_name // & 746 ': dimension "' // TRIM( name ) // & 747 '" already exists in file "' // TRIM( filename ) // '"' ) 748 EXIT 729 !-- Check if any variable of the same name as the new dimension is already defined 730 IF ( ALLOCATED( files(f)%variables ) ) THEN 731 DO i = 1, SIZE( files(f)%variables ) 732 IF ( files(f)%variables(i)%name == dimension%name ) THEN 733 return_value = 1 734 CALL internal_message( 'error', routine_name // & 735 ': file "' // TRIM( filename ) // & 736 '" already has a variable of name "' // & 737 TRIM( dimension%name ) // '" defined. ' // & 738 'Defining a dimension of the same ' // & 739 'name is not allowed.' ) 740 EXIT 741 ENDIF 742 ENDDO 743 ENDIF 744 745 IF ( return_value == 0 ) THEN 746 !-- Check if dimension already exists in file 747 ndim = SIZE( files(f)%dimensions ) 748 749 DO d = 1, ndim 750 IF ( files(f)%dimensions(d)%name == dimension%name ) THEN 751 return_value = 1 752 CALL internal_message( 'error', & 753 routine_name // & 754 ': dimension "' // TRIM( name ) // & 755 '" already exists in file "' // TRIM( filename ) // '"' ) 756 EXIT 757 ENDIF 758 ENDDO 759 760 !-- Extend dimension list 761 IF ( return_value == 0 ) THEN 762 ALLOCATE( dims_tmp(ndim) ) 763 dims_tmp = files(f)%dimensions 764 DEALLOCATE( files(f)%dimensions ) 765 ndim = ndim + 1 766 ALLOCATE( files(f)%dimensions(ndim) ) 767 files(f)%dimensions(:ndim-1) = dims_tmp 768 DEALLOCATE( dims_tmp ) 749 769 ENDIF 750 ENDDO751 752 !-- Extend dimension list753 IF ( return_value == 0 ) THEN754 ALLOCATE( dims_tmp(ndim) )755 dims_tmp = files(f)%dimensions756 DEALLOCATE( files(f)%dimensions )757 ndim = ndim + 1758 ALLOCATE( files(f)%dimensions(ndim) )759 files(f)%dimensions(:ndim-1) = dims_tmp760 DEALLOCATE( dims_tmp )761 770 ENDIF 762 771 … … 832 841 IF ( TRIM( filename ) == files(f)%name ) THEN 833 842 834 !-- Check if dimensions assigned to variable are defined within file 835 IF ( ALLOCATED( files(f)%dimensions ) ) THEN 836 837 DO i = 1, SIZE( variable%dimension_names ) 838 found = .FALSE. 839 DO d = 1, SIZE( files(f)%dimensions ) 840 IF ( files(f)%dimensions(d)%name == variable%dimension_names(i) ) THEN 841 found = .TRUE. 843 IF ( files(f)%is_init ) THEN 844 845 return_value = 1 846 CALL internal_message( 'error', routine_name // ': file "' // TRIM( filename ) // & 847 '" is already initialized. No further variable definition allowed!' ) 848 EXIT 849 850 ELSEIF ( ALLOCATED( files(f)%dimensions ) ) THEN 851 852 !-- Check if any dimension of the same name as the new variable is already defined 853 DO d = 1, SIZE( files(f)%dimensions ) 854 IF ( files(f)%dimensions(d)%name == variable%name ) THEN 855 return_value = 1 856 CALL internal_message( 'error', routine_name // & 857 ': file "' // TRIM( filename ) // & 858 '" already has a dimension of name "' // & 859 TRIM( variable%name ) // '" defined. ' // & 860 'Defining a variable of the same name is not allowed.' ) 861 EXIT 862 ENDIF 863 ENDDO 864 865 !-- Check if dimensions assigned to variable are defined within file 866 IF ( return_value == 0 ) THEN 867 DO i = 1, SIZE( variable%dimension_names ) 868 found = .FALSE. 869 DO d = 1, SIZE( files(f)%dimensions ) 870 IF ( files(f)%dimensions(d)%name == variable%dimension_names(i) ) THEN 871 found = .TRUE. 872 EXIT 873 ENDIF 874 ENDDO 875 IF ( .NOT. found ) THEN 876 return_value = 1 877 CALL internal_message( 'error', & 878 routine_name // & 879 ': variable "' // TRIM( name ) // & 880 '" in file "' // TRIM( filename ) // & 881 '": required dimension "' // & 882 TRIM( variable%dimension_names(i) ) // & 883 '" not defined' ) 842 884 EXIT 843 885 ENDIF 844 886 ENDDO 845 IF ( .NOT. found ) THEN 846 return_value = 1 847 CALL internal_message( 'error', & 848 routine_name // & 849 ': variable "' // TRIM( name ) // & 850 '" in file "' // TRIM( filename ) // & 851 '": required dimension "' // & 852 TRIM( variable%dimension_names(i) ) // '" not defined' ) 853 EXIT 854 ENDIF 855 ENDDO 887 ENDIF 856 888 857 889 ELSE … … 1263 1295 1264 1296 IF ( TRIM( filename ) == files(f)%name ) THEN 1297 1298 IF ( files(f)%is_init ) THEN 1299 return_value = 1 1300 CALL internal_message( 'error', routine_name // ': file "' // TRIM( filename ) // & 1301 '" is already initialized. No further attribute definition allowed!' ) 1302 EXIT 1303 ENDIF 1265 1304 1266 1305 !-- Add attribute to file … … 1328 1367 !-- Check if attribute already exists 1329 1368 DO a = 1, natt 1330 IF ( files(f)%dimensions(d)%attributes(a)%name == attribute%name ) THEN 1369 IF ( files(f)%dimensions(d)%attributes(a)%name == attribute%name ) & 1370 THEN 1331 1371 IF ( append ) THEN 1332 1372 !-- Append existing character attribute … … 1385 1425 !-- Check if attribute already exists 1386 1426 DO a = 1, natt 1387 IF ( files(f)%variables(d)%attributes(a)%name == attribute%name ) THEN 1427 IF ( files(f)%variables(d)%attributes(a)%name == attribute%name ) & 1428 THEN 1388 1429 IF ( append ) THEN 1389 1430 !-- Append existing character attribute … … 1497 1538 DO f = 1, nf 1498 1539 1540 !-- Skip initialization if file is already initialized 1541 IF ( files(f)%is_init ) CYCLE 1542 1543 CALL internal_message( 'debug', routine_name // ': initialize file "' // & 1544 TRIM( files(f)%name ) // '"' ) 1545 1499 1546 !-- Open file 1500 1547 CALL open_output_file( files(f)%format, files(f)%name, files(f)%id, & 1501 files(f)%is_init,return_value=return_value )1548 return_value=return_value ) 1502 1549 1503 1550 !-- Initialize file header: … … 1508 1555 !-- End file definition 1509 1556 IF ( return_value == 0 ) & 1510 CALL dom_init_end( files(f)%format, files(f)%id, return_value=return_value ) 1511 1512 !-- Write dimension values into file 1557 CALL dom_init_end( files(f)%format, files(f)%id, files(f)%name, return_value ) 1558 1513 1559 IF ( return_value == 0 ) THEN 1514 1560 1561 !-- Flag file as initialized 1562 files(f)%is_init = .TRUE. 1563 1564 !-- Write dimension values into file 1515 1565 DO d = 1, SIZE( files(f)%dimensions ) 1516 1566 IF ( ALLOCATED( files(f)%dimensions(d)%values_int8 ) ) THEN … … 1628 1678 return_value = 0 1629 1679 1630 !-- Set flag for files to be initialized1680 !-- Flag files which contain output variables as used 1631 1681 file_is_used(:) = .FALSE. 1632 1682 DO f = 1, nf … … 1657 1707 DO f = 1, nf 1658 1708 1709 !-- If a file is already initialized, it was already checked previously 1710 IF ( files(f)%is_init ) CYCLE 1711 1659 1712 !-- Get number of defined dimensions 1660 1713 ndim = SIZE( files(f)%dimensions ) … … 1699 1752 !> Open requested output file. 1700 1753 !--------------------------------------------------------------------------------------------------! 1701 SUBROUTINE open_output_file( file_format, filename, file_id, is_init,return_value )1754 SUBROUTINE open_output_file( file_format, filename, file_id, return_value ) 1702 1755 1703 1756 CHARACTER(LEN=*), INTENT(IN) :: file_format !< file format chosen for file … … 1706 1759 CHARACTER(LEN=*), PARAMETER :: routine_name = 'open_output_file' !< name of routine 1707 1760 1708 INTEGER(iwp), INTENT(OUT) :: file_id !< file ID 1709 INTEGER(iwp), INTENT(OUT) :: return_value !< return value 1710 1711 LOGICAL, INTENT(OUT) :: is_init !< true if file is opened 1712 1761 INTEGER(iwp), INTENT(OUT) :: file_id !< file ID 1762 INTEGER(iwp) :: output_return_value !< return value of a called output routine 1763 INTEGER(iwp), INTENT(OUT) :: return_value !< return value 1764 1765 1766 return_value = 0 1767 output_return_value = 0 1713 1768 1714 1769 SELECT CASE ( TRIM( file_format ) ) 1715 1770 1716 1771 CASE ( 'binary' ) 1717 CALL binary_open_file( filename, file_id,return_value )1772 CALL binary_open_file( 'binary', filename, file_id, output_return_value ) 1718 1773 1719 1774 CASE ( 'netcdf4-serial' ) 1720 CALL netcdf4_ serial_open_file( filename, file_id,return_value )1775 CALL netcdf4_open_file( 'serial', filename, file_id, output_return_value ) 1721 1776 1722 1777 CASE ( 'netcdf4-parallel' ) 1723 CALL netcdf4_ parallel_open_file( filename, file_id,return_value )1778 CALL netcdf4_open_file( 'parallel', filename, file_id, output_return_value ) 1724 1779 1725 1780 CASE DEFAULT 1726 1781 return_value = 1 1727 CALL internal_message( 'error', routine_name // &1728 ': file "' // TRIM( filename ) // &1729 '": file format "' // TRIM( file_format ) // &1730 '" not supported' )1731 1782 1732 1783 END SELECT 1733 1784 1734 is_init = return_value == 0 1785 IF ( output_return_value /= 0 ) THEN 1786 return_value = output_return_value 1787 CALL internal_message( 'error', routine_name // & 1788 ': error while opening file "' // TRIM( filename ) // '"' ) 1789 ELSEIF ( return_value /= 0 ) THEN 1790 CALL internal_message( 'error', routine_name // & 1791 ': file "' // TRIM( filename ) // & 1792 '": file format "' // TRIM( file_format ) // & 1793 '" not supported' ) 1794 ENDIF 1735 1795 1736 1796 END SUBROUTINE open_output_file … … 1757 1817 IF ( ALLOCATED( file%attributes ) ) THEN 1758 1818 DO a = 1, SIZE( file%attributes ) 1759 return_value = write_attribute( file%format, file%id, var_id=no_var_id, &1760 attribute=file%attributes(a) )1819 return_value = write_attribute( file%format, file%id, file%name, var_id=no_var_id, & 1820 attribute=file%attributes(a) ) 1761 1821 IF ( return_value /= 0 ) EXIT 1762 1822 ENDDO … … 1771 1831 1772 1832 !-- Initialize non-masked dimension 1773 CALL init_file_dimension( file%format, 1774 file% id, file%dimensions(d)%id, file%dimensions(d)%var_id,&1775 file%dimensions(d)%name, file%dimensions(d)%data_type, 1776 file%dimensions(d)%length, file%dimensions(d)%is_init,return_value )1833 CALL init_file_dimension( file%format, file%id, file%name, & 1834 file%dimensions(d)%id, file%dimensions(d)%var_id, & 1835 file%dimensions(d)%name, file%dimensions(d)%data_type, & 1836 file%dimensions(d)%length, return_value ) 1777 1837 1778 1838 ELSE 1779 1839 1780 1840 !-- Initialize masked dimension 1781 CALL init_file_dimension( file%format, 1782 file% id, file%dimensions(d)%id, file%dimensions(d)%var_id,&1783 file%dimensions(d)%name, file%dimensions(d)%data_type, 1784 file%dimensions(d)%length_mask, file%dimensions(d)%is_init,return_value )1841 CALL init_file_dimension( file%format, file%id, file%name, & 1842 file%dimensions(d)%id, file%dimensions(d)%var_id, & 1843 file%dimensions(d)%name, file%dimensions(d)%data_type, & 1844 file%dimensions(d)%length_mask, return_value ) 1785 1845 1786 1846 ENDIF … … 1789 1849 !-- Write dimension attributes 1790 1850 DO a = 1, SIZE( file%dimensions(d)%attributes ) 1791 return_value = write_attribute( file%format, file%id, file%dimensions(d)%var_id, & 1851 return_value = write_attribute( file%format, file%id, file%name, & 1852 var_id=file%dimensions(d)%var_id, & 1853 var_name=file%dimensions(d)%name, & 1792 1854 attribute=file%dimensions(d)%attributes(a) ) 1793 1855 IF ( return_value /= 0 ) EXIT … … 1807 1869 DO d = 1, SIZE( file%variables ) 1808 1870 1809 CALL init_file_variable( file%format, file%id, file% variables(d)%id,&1810 file%variables(d)% name, file%variables(d)%data_type,&1811 file%variables(d)%dimension_ids, &1812 file%variables(d)%is_ init, file%variables(d)%is_global, return_value )1871 CALL init_file_variable( file%format, file%id, file%name, & 1872 file%variables(d)%id, file%variables(d)%name, file%variables(d)%data_type, & 1873 file%variables(d)%dimension_ids, & 1874 file%variables(d)%is_global, return_value ) 1813 1875 1814 1876 IF ( return_value == 0 .AND. ALLOCATED( file%variables(d)%attributes ) ) THEN 1815 1877 !-- Write variable attribures 1816 1878 DO a = 1, SIZE( file%variables(d)%attributes ) 1817 return_value = write_attribute( file%format, file%id, file%variables(d)%id, & 1879 return_value = write_attribute( file%format, file%id, file%name, & 1880 var_id=file%variables(d)%id, & 1881 var_name=file%variables(d)%name, & 1818 1882 attribute=file%variables(d)%attributes(a) ) 1819 1883 IF ( return_value /= 0 ) EXIT … … 1835 1899 !> Write attribute to file. 1836 1900 !--------------------------------------------------------------------------------------------------! 1837 FUNCTION write_attribute( file_format, file_id, var_id, attribute ) RESULT( return_value )1901 FUNCTION write_attribute( file_format, file_id, file_name, var_id, var_name, attribute ) RESULT( return_value ) 1838 1902 1839 1903 CHARACTER(LEN=*), INTENT(IN) :: file_format !< file format chosen for file 1904 CHARACTER(LEN=*), INTENT(IN) :: file_name !< file name 1905 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: var_name !< variable name 1840 1906 1841 1907 CHARACTER(LEN=*), PARAMETER :: routine_name = 'write_attribute' !< file format chosen for file 1842 1908 1843 INTEGER(iwp) :: file_id !< file ID 1844 INTEGER(iwp) :: return_value !< return value 1845 INTEGER(iwp) :: var_id !< variable ID 1909 INTEGER(iwp), INTENT(IN) :: file_id !< file ID 1910 INTEGER(iwp) :: return_value !< return value 1911 INTEGER(iwp) :: output_return_value !< return value of a called output routine 1912 INTEGER(iwp), INTENT(IN) :: var_id !< variable ID 1846 1913 1847 1914 TYPE(attribute_type), INTENT(IN) :: attribute !< attribute to be written 1848 1915 1849 1916 1917 return_value = 0 1918 output_return_value = 0 1919 1920 !-- Prepare for possible error message 1921 IF ( PRESENT( var_name ) ) THEN 1922 temp_string = '(file "' // TRIM( file_name ) // & 1923 '", variable "' // TRIM( var_name ) // & 1924 '", attribute "' // TRIM( attribute%name ) // '")' 1925 ELSE 1926 temp_string = '(file "' // TRIM( file_name ) // & 1927 '", attribute "' // TRIM( attribute%name ) // '")' 1928 ENDIF 1929 1930 !-- Write attribute to file 1850 1931 SELECT CASE ( TRIM( file_format ) ) 1851 1932 … … 1857 1938 CALL binary_write_attribute( file_id=file_id, var_id=var_id, & 1858 1939 att_name=attribute%name, att_value_char=attribute%value_char, & 1859 return_value= return_value )1940 return_value=output_return_value ) 1860 1941 1861 1942 CASE( 'int8' ) 1862 1943 CALL binary_write_attribute( file_id=file_id, var_id=var_id, & 1863 1944 att_name=attribute%name, att_value_int8=attribute%value_int8, & 1864 return_value= return_value )1945 return_value=output_return_value ) 1865 1946 1866 1947 CASE( 'int16' ) 1867 1948 CALL binary_write_attribute( file_id=file_id, var_id=var_id, & 1868 1949 att_name=attribute%name, att_value_int16=attribute%value_int16, & 1869 return_value= return_value )1950 return_value=output_return_value ) 1870 1951 1871 1952 CASE( 'int32' ) 1872 1953 CALL binary_write_attribute( file_id=file_id, var_id=var_id, & 1873 1954 att_name=attribute%name, att_value_int32=attribute%value_int32, & 1874 return_value= return_value )1955 return_value=output_return_value ) 1875 1956 1876 1957 CASE( 'real32' ) 1877 1958 CALL binary_write_attribute( file_id=file_id, var_id=var_id, & 1878 1959 att_name=attribute%name, att_value_real32=attribute%value_real32, & 1879 return_value= return_value )1960 return_value=output_return_value ) 1880 1961 1881 1962 CASE( 'real64' ) 1882 1963 CALL binary_write_attribute( file_id=file_id, var_id=var_id, & 1883 1964 att_name=attribute%name, att_value_real64=attribute%value_real64, & 1884 return_value= return_value )1965 return_value=output_return_value ) 1885 1966 1886 1967 CASE DEFAULT 1887 1968 return_value = 1 1888 CALL internal_message( 'error', 1889 routine_name //&1890 ' : attribute "' // TRIM( attribute%name ) //&1891 '": data type "'// TRIM( attribute%data_type ) //&1892 '" not supported for file format "binary".')1969 CALL internal_message( 'error', routine_name // & 1970 ': file format "' // TRIM( file_format ) // & 1971 '" does not support attribute data type "'// & 1972 TRIM( attribute%data_type ) // & 1973 '" ' // TRIM( temp_string ) ) 1893 1974 1894 1975 END SELECT 1895 1976 1896 CASE ( 'netcdf4- serial' )1977 CASE ( 'netcdf4-parallel', 'netcdf4-serial' ) 1897 1978 1898 1979 SELECT CASE ( TRIM( attribute%data_type ) ) 1899 1980 1900 1981 CASE( 'char' ) 1901 CALL netcdf4_ serial_write_attribute( file_id=file_id, var_id=var_id, &1982 CALL netcdf4_write_attribute( file_id=file_id, var_id=var_id, & 1902 1983 att_name=attribute%name, att_value_char=attribute%value_char, & 1903 return_value= return_value )1984 return_value=output_return_value ) 1904 1985 1905 1986 CASE( 'int8' ) 1906 CALL netcdf4_ serial_write_attribute( file_id=file_id, var_id=var_id, &1987 CALL netcdf4_write_attribute( file_id=file_id, var_id=var_id, & 1907 1988 att_name=attribute%name, att_value_int8=attribute%value_int8, & 1908 return_value= return_value )1989 return_value=output_return_value ) 1909 1990 1910 1991 CASE( 'int16' ) 1911 CALL netcdf4_ serial_write_attribute( file_id=file_id, var_id=var_id, &1992 CALL netcdf4_write_attribute( file_id=file_id, var_id=var_id, & 1912 1993 att_name=attribute%name, att_value_int16=attribute%value_int16, & 1913 return_value= return_value )1994 return_value=output_return_value ) 1914 1995 1915 1996 CASE( 'int32' ) 1916 CALL netcdf4_ serial_write_attribute( file_id=file_id, var_id=var_id, &1997 CALL netcdf4_write_attribute( file_id=file_id, var_id=var_id, & 1917 1998 att_name=attribute%name, att_value_int32=attribute%value_int32, & 1918 return_value= return_value )1999 return_value=output_return_value ) 1919 2000 1920 2001 CASE( 'real32' ) 1921 CALL netcdf4_ serial_write_attribute( file_id=file_id, var_id=var_id, &2002 CALL netcdf4_write_attribute( file_id=file_id, var_id=var_id, & 1922 2003 att_name=attribute%name, att_value_real32=attribute%value_real32, & 1923 return_value= return_value )2004 return_value=output_return_value ) 1924 2005 1925 2006 CASE( 'real64' ) 1926 CALL netcdf4_ serial_write_attribute( file_id=file_id, var_id=var_id, &2007 CALL netcdf4_write_attribute( file_id=file_id, var_id=var_id, & 1927 2008 att_name=attribute%name, att_value_real64=attribute%value_real64, & 1928 return_value= return_value )2009 return_value=output_return_value ) 1929 2010 1930 2011 CASE DEFAULT 1931 2012 return_value = 1 1932 CALL internal_message( 'error', & 1933 routine_name // & 1934 ': attribute "' // TRIM( attribute%name ) // & 1935 '": data type "'// TRIM( attribute%data_type ) // & 1936 '" not supported for file format "netcdf4-serial".' ) 1937 1938 END SELECT 1939 1940 CASE ( 'netcdf4-parallel' ) 1941 1942 SELECT CASE ( TRIM( attribute%data_type ) ) 1943 1944 CASE( 'char' ) 1945 CALL netcdf4_parallel_write_attribute( file_id=file_id, var_id=var_id, & 1946 att_name=attribute%name, att_value_char=attribute%value_char, & 1947 return_value=return_value ) 1948 1949 CASE( 'int8' ) 1950 CALL netcdf4_parallel_write_attribute( file_id=file_id, var_id=var_id, & 1951 att_name=attribute%name, att_value_int8=attribute%value_int8, & 1952 return_value=return_value ) 1953 1954 CASE( 'int16' ) 1955 CALL netcdf4_parallel_write_attribute( file_id=file_id, var_id=var_id, & 1956 att_name=attribute%name, att_value_int16=attribute%value_int16, & 1957 return_value=return_value ) 1958 1959 CASE( 'int32' ) 1960 CALL netcdf4_parallel_write_attribute( file_id=file_id, var_id=var_id, & 1961 att_name=attribute%name, att_value_int32=attribute%value_int32, & 1962 return_value=return_value ) 1963 1964 CASE( 'real32' ) 1965 CALL netcdf4_parallel_write_attribute( file_id=file_id, var_id=var_id, & 1966 att_name=attribute%name, att_value_real32=attribute%value_real32, & 1967 return_value=return_value ) 1968 1969 CASE( 'real64' ) 1970 CALL netcdf4_parallel_write_attribute( file_id=file_id, var_id=var_id, & 1971 att_name=attribute%name, att_value_real64=attribute%value_real64, & 1972 return_value=return_value ) 1973 1974 CASE DEFAULT 1975 return_value = 1 1976 CALL internal_message( 'error', & 1977 routine_name // & 1978 ': attribute "' // TRIM( attribute%name ) // & 1979 '": data type "'// TRIM( attribute%data_type ) // & 1980 '" not supported for file format "netcdf4-parallel".' ) 2013 CALL internal_message( 'error', routine_name // & 2014 ': file format "' // TRIM( file_format ) // & 2015 '" does not support attribute data type "'// & 2016 TRIM( attribute%data_type ) // & 2017 '" ' // TRIM( temp_string ) ) 1981 2018 1982 2019 END SELECT … … 1986 2023 CALL internal_message( 'error', & 1987 2024 routine_name // & 1988 ': unsupported file format "' // TRIM( file_format ) // '"' ) 2025 ': unsupported file format "' // TRIM( file_format ) // & 2026 '" ' // TRIM( temp_string ) ) 1989 2027 1990 2028 END SELECT 2029 2030 IF ( output_return_value /= 0 ) THEN 2031 return_value = output_return_value 2032 CALL internal_message( 'error', & 2033 routine_name // & 2034 ': error while writing attribute ' // TRIM( temp_string ) ) 2035 ENDIF 1991 2036 1992 2037 END FUNCTION write_attribute … … 1997 2042 !> Initialize dimension in file. 1998 2043 !--------------------------------------------------------------------------------------------------! 1999 SUBROUTINE init_file_dimension( file_format, file_id, dim_id, var_id,&2000 dim_name, dim_type, dim_length, is_init,return_value )2044 SUBROUTINE init_file_dimension( file_format, file_id, file_name, dim_id, var_id, & 2045 dim_name, dim_type, dim_length, return_value ) 2001 2046 2002 2047 CHARACTER(LEN=*), INTENT(IN) :: dim_name !< name of dimension 2003 2048 CHARACTER(LEN=*), INTENT(IN) :: dim_type !< data type of dimension 2004 2049 CHARACTER(LEN=*), INTENT(IN) :: file_format !< file format chosen for file 2050 CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file 2005 2051 2006 2052 CHARACTER(LEN=*), PARAMETER :: routine_name = 'init_file_dimension' !< file format chosen for file 2007 2053 2008 INTEGER(iwp), INTENT(OUT) :: dim_id !< dimension ID 2009 INTEGER(iwp), INTENT(IN) :: dim_length !< length of dimension 2010 INTEGER(iwp), INTENT(IN) :: file_id !< file ID 2011 INTEGER(iwp), INTENT(OUT) :: return_value !< return value 2012 INTEGER(iwp), INTENT(OUT) :: var_id !< associated variable ID 2013 2014 LOGICAL, INTENT(OUT) :: is_init !< true if dimension is initialized 2015 2054 INTEGER(iwp), INTENT(OUT) :: dim_id !< dimension ID 2055 INTEGER(iwp), INTENT(IN) :: dim_length !< length of dimension 2056 INTEGER(iwp), INTENT(IN) :: file_id !< file ID 2057 INTEGER(iwp) :: output_return_value !< return value of a called output routine 2058 INTEGER(iwp), INTENT(OUT) :: return_value !< return value 2059 INTEGER(iwp), INTENT(OUT) :: var_id !< associated variable ID 2060 2061 2062 return_value = 0 2063 output_return_value = 0 2064 2065 temp_string = '(file "' // TRIM( file_name ) // & 2066 '", dimension "' // TRIM( dim_name ) // '")' 2016 2067 2017 2068 SELECT CASE ( TRIM( file_format ) ) 2018 2069 2019 2070 CASE ( 'binary' ) 2020 CALL binary_init_dimension( file_id, dim_id, var_id, &2021 dim_name, dim_type, dim_length, is_init,return_value )2071 CALL binary_init_dimension( 'binary', file_id, dim_id, var_id, & 2072 dim_name, dim_type, dim_length, return_value=output_return_value ) 2022 2073 2023 2074 CASE ( 'netcdf4-serial' ) 2024 CALL netcdf4_ serial_init_dimension(file_id, dim_id, var_id, &2025 dim_name, dim_type, dim_length, is_init,return_value )2075 CALL netcdf4_init_dimension( 'serial', file_id, dim_id, var_id, & 2076 dim_name, dim_type, dim_length, return_value=output_return_value ) 2026 2077 2027 2078 CASE ( 'netcdf4-parallel' ) 2028 CALL netcdf4_ parallel_init_dimension(file_id, dim_id, var_id, &2029 dim_name, dim_type, dim_length, is_init,return_value )2079 CALL netcdf4_init_dimension( 'parallel', file_id, dim_id, var_id, & 2080 dim_name, dim_type, dim_length, return_value=output_return_value ) 2030 2081 2031 2082 CASE DEFAULT 2032 2083 return_value = 1 2033 WRITE( temp_string, * ) file_id 2034 CALL internal_message( 'error', routine_name // & 2035 ': file id = ' // TRIM( temp_string ) // & 2036 '": file format "' // TRIM( file_format ) // & 2037 '" not supported' ) 2084 CALL internal_message( 'error', routine_name // & 2085 ': file format "' // TRIM( file_format ) // & 2086 '" not supported ' // TRIM( temp_string ) ) 2038 2087 2039 2088 END SELECT 2089 2090 IF ( output_return_value /= 0 ) THEN 2091 return_value = output_return_value 2092 CALL internal_message( 'error', routine_name // & 2093 ': error while defining dimension ' // TRIM( temp_string ) ) 2094 ENDIF 2040 2095 2041 2096 END SUBROUTINE init_file_dimension … … 2097 2152 !> Initialize variable. 2098 2153 !--------------------------------------------------------------------------------------------------! 2099 SUBROUTINE init_file_variable( file_format, file_id, var_id,&2100 var_ name, var_type, var_dim_id, &2101 is_ init, is_global, return_value )2154 SUBROUTINE init_file_variable( file_format, file_id, file_name, & 2155 var_id, var_name, var_type, var_dim_id, & 2156 is_global, return_value ) 2102 2157 2103 2158 CHARACTER(LEN=*), INTENT(IN) :: file_format !< file format chosen for file 2159 CHARACTER(LEN=*), INTENT(IN) :: file_name !< file name 2104 2160 CHARACTER(LEN=*), INTENT(IN) :: var_name !< name of variable 2105 2161 CHARACTER(LEN=*), INTENT(IN) :: var_type !< data type of variable … … 2107 2163 CHARACTER(LEN=*), PARAMETER :: routine_name = 'init_file_variable' !< file format chosen for file 2108 2164 2109 INTEGER(iwp), INTENT(IN) :: file_id !< file ID 2110 INTEGER(iwp), INTENT(OUT) :: return_value !< return value 2111 INTEGER(iwp), INTENT(OUT) :: var_id !< variable ID 2165 INTEGER(iwp), INTENT(IN) :: file_id !< file ID 2166 INTEGER(iwp) :: output_return_value !< return value of a called output routine 2167 INTEGER(iwp), INTENT(OUT) :: return_value !< return value 2168 INTEGER(iwp), INTENT(OUT) :: var_id !< variable ID 2112 2169 2113 2170 INTEGER(iwp), DIMENSION(:), INTENT(IN) :: var_dim_id !< list of dimension IDs used by variable 2114 2171 2115 2172 LOGICAL, INTENT(IN) :: is_global !< true if variable is global 2116 LOGICAL, INTENT(OUT) :: is_init !< true if variable is initialized 2117 2173 2174 2175 return_value = 0 2176 output_return_value = 0 2177 2178 temp_string = '(file "' // TRIM( file_name ) // & 2179 '", variable "' // TRIM( var_name ) // '")' 2118 2180 2119 2181 SELECT CASE ( TRIM( file_format ) ) 2120 2182 2121 2183 CASE ( 'binary' ) 2122 CALL binary_init_variable( file_id, var_id, var_name, var_type, var_dim_id, &2123 is_init, is_global,return_value )2184 CALL binary_init_variable( 'binary', file_id, var_id, var_name, var_type, & 2185 var_dim_id, is_global, return_value=output_return_value ) 2124 2186 2125 2187 CASE ( 'netcdf4-serial' ) 2126 CALL netcdf4_ serial_init_variable( file_id, var_id, var_name, var_type, var_dim_id, &2127 is_init, is_global,return_value )2188 CALL netcdf4_init_variable( 'serial', file_id, var_id, var_name, var_type, & 2189 var_dim_id, is_global, return_value=output_return_value ) 2128 2190 2129 2191 CASE ( 'netcdf4-parallel' ) 2130 CALL netcdf4_ parallel_init_variable( file_id, var_id, var_name, var_type, var_dim_id, &2131 is_init, is_global,return_value )2192 CALL netcdf4_init_variable( 'parallel', file_id, var_id, var_name, var_type, & 2193 var_dim_id, is_global, return_value=output_return_value ) 2132 2194 2133 2195 CASE DEFAULT 2134 2196 return_value = 1 2135 is_init = .FALSE.2136 CALL internal_message( 'error', routine_name// &2137 ' : unsupported file format "' // TRIM( file_format) )2197 CALL internal_message( 'error', routine_name // & 2198 ': file format "' // TRIM( file_format ) // & 2199 '" not supported ' // TRIM( temp_string ) ) 2138 2200 2139 2201 END SELECT 2202 2203 IF ( output_return_value /= 0 ) THEN 2204 return_value = output_return_value 2205 CALL internal_message( 'error', routine_name // & 2206 ': error while defining variable ' // TRIM( temp_string ) ) 2207 ENDIF 2140 2208 2141 2209 END SUBROUTINE init_file_variable … … 2148 2216 !> @todo Do we need an MPI barrier at the end? 2149 2217 !--------------------------------------------------------------------------------------------------! 2150 SUBROUTINE dom_init_end( file_format, file_id, return_value )2218 SUBROUTINE dom_init_end( file_format, file_id, file_name, return_value ) 2151 2219 2152 2220 CHARACTER(LEN=*), INTENT(IN) :: file_format !< file format 2221 CHARACTER(LEN=*), INTENT(IN) :: file_name !< file name 2153 2222 2154 2223 CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_init_end' !< name of routine 2155 2224 2156 INTEGER(iwp), INTENT(IN) :: file_id !< file id 2157 INTEGER(iwp), INTENT(OUT) :: return_value !< return value 2158 2225 INTEGER(iwp), INTENT(IN) :: file_id !< file id 2226 INTEGER(iwp) :: output_return_value !< return value of a called output routine 2227 INTEGER(iwp), INTENT(OUT) :: return_value !< return value 2228 2229 2230 return_value = 0 2231 output_return_value = 0 2232 2233 temp_string = '(file "' // TRIM( file_name ) // '")' 2159 2234 2160 2235 SELECT CASE ( TRIM( file_format ) ) 2161 2236 2162 2237 CASE ( 'binary' ) 2163 CALL binary_init_end( file_id, return_value ) 2164 2165 CASE ( 'netcdf4-serial' ) 2166 CALL netcdf4_serial_init_end( file_id, return_value ) 2167 2168 CASE ( 'netcdf4-parallel' ) 2169 CALL netcdf4_parallel_init_end( file_id, return_value ) 2238 CALL binary_init_end( file_id, output_return_value ) 2239 2240 CASE ( 'netcdf4-parallel', 'netcdf4-serial' ) 2241 CALL netcdf4_init_end( file_id, output_return_value ) 2170 2242 2171 2243 CASE DEFAULT 2172 2244 return_value = 1 2173 WRITE( temp_string, * ) file_id 2174 CALL internal_message( 'error', routine_name // & 2175 ': file id = ' // TRIM( temp_string ) // & 2176 ': file format "' // TRIM( file_format ) // & 2177 '" not supported' ) 2245 CALL internal_message( 'error', routine_name // & 2246 ': file format "' // TRIM( file_format ) // & 2247 '" not supported ' // TRIM( temp_string ) ) 2178 2248 2179 2249 END SELECT 2250 2251 IF ( output_return_value /= 0 ) THEN 2252 return_value = output_return_value 2253 CALL internal_message( 'error', routine_name // & 2254 ': error while leaving file-definition state ' // & 2255 TRIM( temp_string ) ) 2256 ENDIF 2180 2257 2181 2258 ! CALL MPI_Barrier( MPI_COMM_WORLD, return_value ) … … 2211 2288 CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_write_var' !< name of routine 2212 2289 2213 INTEGER(iwp) :: d !< loop index 2214 INTEGER(iwp) :: file_id !< file ID 2215 INTEGER(iwp) :: i !< loop index 2216 INTEGER(iwp) :: j !< loop index 2217 INTEGER(iwp) :: k !< loop index 2218 INTEGER(iwp) :: return_value !< return value 2219 INTEGER(iwp) :: var_id !< variable ID 2290 INTEGER(iwp) :: d !< loop index 2291 INTEGER(iwp) :: file_id !< file ID 2292 INTEGER(iwp) :: i !< loop index 2293 INTEGER(iwp) :: j !< loop index 2294 INTEGER(iwp) :: k !< loop index 2295 INTEGER(iwp) :: output_return_value !< return value of a called output routine 2296 INTEGER(iwp) :: return_value !< return value 2297 INTEGER(iwp) :: var_id !< variable ID 2220 2298 2221 2299 INTEGER(iwp), DIMENSION(:), INTENT(IN) :: bounds_end !< end index (upper bound) of variable at each dimension 2222 2300 INTEGER(iwp), DIMENSION(:), INTENT(IN) :: bounds_start !< start index (lower bound) of variable at each dimension 2223 2301 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: bounds_dim_start !< start index (lower bound) of each dimension of variable 2224 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: bounds_end_new !< start index (upper bound) of m asked variable at each dimension2225 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: bounds_start_new !< start index (lower bound) of m asked variable at each dimension2302 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: bounds_end_new !< start index (upper bound) of msked var at each dim 2303 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: bounds_start_new !< start index (lower bound) of msked var at each dim 2226 2304 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: masked_indices !< dummy list holding all masked indices along a dimension 2227 2305 … … 2330 2408 2331 2409 2410 return_value = 0 2411 output_return_value = 0 2412 2332 2413 CALL internal_message( 'debug', routine_name // ': write ' // TRIM( name ) // & 2333 2414 ' into file ' // TRIM( filename ) ) … … 2343 2424 SIZE( bounds_end ) /= SIZE( dimension_list ) ) THEN 2344 2425 return_value = 1 2345 CALL internal_message( 'error', routine_name // 2346 2347 2348 2426 CALL internal_message( 'error', routine_name // & 2427 ': variable "' // TRIM( name ) // & 2428 '" in file "' // TRIM( filename ) // & 2429 '": given bounds do not match with number of dimensions' ) 2349 2430 ENDIF 2350 2431 … … 2819 2900 CALL binary_write_variable( file_id, var_id, & 2820 2901 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 2821 var_int8_0d=var_int8_0d_pointer, return_value= return_value )2902 var_int8_0d=var_int8_0d_pointer, return_value=output_return_value ) 2822 2903 ELSEIF ( PRESENT( var_int8_1d ) ) THEN 2823 2904 CALL binary_write_variable( file_id, var_id, & 2824 2905 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 2825 var_int8_1d=var_int8_1d_pointer, return_value= return_value )2906 var_int8_1d=var_int8_1d_pointer, return_value=output_return_value ) 2826 2907 ELSEIF ( PRESENT( var_int8_2d ) ) THEN 2827 2908 CALL binary_write_variable( file_id, var_id, & 2828 2909 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 2829 var_int8_2d=var_int8_2d_pointer, return_value= return_value )2910 var_int8_2d=var_int8_2d_pointer, return_value=output_return_value ) 2830 2911 ELSEIF ( PRESENT( var_int8_3d ) ) THEN 2831 2912 CALL binary_write_variable( file_id, var_id, & 2832 2913 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 2833 var_int8_3d=var_int8_3d_pointer, return_value= return_value )2914 var_int8_3d=var_int8_3d_pointer, return_value=output_return_value ) 2834 2915 !-- 16bit integer output 2835 2916 ELSEIF ( PRESENT( var_int16_0d ) ) THEN 2836 2917 CALL binary_write_variable( file_id, var_id, & 2837 2918 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 2838 var_int16_0d=var_int16_0d_pointer, return_value= return_value )2919 var_int16_0d=var_int16_0d_pointer, return_value=output_return_value ) 2839 2920 ELSEIF ( PRESENT( var_int16_1d ) ) THEN 2840 2921 CALL binary_write_variable( file_id, var_id, & 2841 2922 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 2842 var_int16_1d=var_int16_1d_pointer, return_value= return_value )2923 var_int16_1d=var_int16_1d_pointer, return_value=output_return_value ) 2843 2924 ELSEIF ( PRESENT( var_int16_2d ) ) THEN 2844 2925 CALL binary_write_variable( file_id, var_id, & 2845 2926 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 2846 var_int16_2d=var_int16_2d_pointer, return_value= return_value )2927 var_int16_2d=var_int16_2d_pointer, return_value=output_return_value ) 2847 2928 ELSEIF ( PRESENT( var_int16_3d ) ) THEN 2848 2929 CALL binary_write_variable( file_id, var_id, & 2849 2930 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 2850 var_int16_3d=var_int16_3d_pointer, return_value= return_value )2931 var_int16_3d=var_int16_3d_pointer, return_value=output_return_value ) 2851 2932 !-- 32bit integer output 2852 2933 ELSEIF ( PRESENT( var_int32_0d ) ) THEN 2853 2934 CALL binary_write_variable( file_id, var_id, & 2854 2935 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 2855 var_int32_0d=var_int32_0d_pointer, return_value= return_value )2936 var_int32_0d=var_int32_0d_pointer, return_value=output_return_value ) 2856 2937 ELSEIF ( PRESENT( var_int32_1d ) ) THEN 2857 2938 CALL binary_write_variable( file_id, var_id, & 2858 2939 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 2859 var_int32_1d=var_int32_1d_pointer, return_value= return_value )2940 var_int32_1d=var_int32_1d_pointer, return_value=output_return_value ) 2860 2941 ELSEIF ( PRESENT( var_int32_2d ) ) THEN 2861 2942 CALL binary_write_variable( file_id, var_id, & 2862 2943 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 2863 var_int32_2d=var_int32_2d_pointer, return_value= return_value )2944 var_int32_2d=var_int32_2d_pointer, return_value=output_return_value ) 2864 2945 ELSEIF ( PRESENT( var_int32_3d ) ) THEN 2865 2946 CALL binary_write_variable( file_id, var_id, & 2866 2947 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 2867 var_int32_3d=var_int32_3d_pointer, return_value= return_value )2948 var_int32_3d=var_int32_3d_pointer, return_value=output_return_value ) 2868 2949 !-- working-precision integer output 2869 2950 ELSEIF ( PRESENT( var_intwp_0d ) ) THEN 2870 2951 CALL binary_write_variable( file_id, var_id, & 2871 2952 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 2872 var_intwp_0d=var_intwp_0d_pointer, return_value= return_value )2953 var_intwp_0d=var_intwp_0d_pointer, return_value=output_return_value ) 2873 2954 ELSEIF ( PRESENT( var_intwp_1d ) ) THEN 2874 2955 CALL binary_write_variable( file_id, var_id, & 2875 2956 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 2876 var_intwp_1d=var_intwp_1d_pointer, return_value= return_value )2957 var_intwp_1d=var_intwp_1d_pointer, return_value=output_return_value ) 2877 2958 ELSEIF ( PRESENT( var_intwp_2d ) ) THEN 2878 2959 CALL binary_write_variable( file_id, var_id, & 2879 2960 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 2880 var_intwp_2d=var_intwp_2d_pointer, return_value= return_value )2961 var_intwp_2d=var_intwp_2d_pointer, return_value=output_return_value ) 2881 2962 ELSEIF ( PRESENT( var_intwp_3d ) ) THEN 2882 2963 CALL binary_write_variable( file_id, var_id, & 2883 2964 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 2884 var_intwp_3d=var_intwp_3d_pointer, return_value= return_value )2965 var_intwp_3d=var_intwp_3d_pointer, return_value=output_return_value ) 2885 2966 !-- 32bit real output 2886 2967 ELSEIF ( PRESENT( var_real32_0d ) ) THEN 2887 2968 CALL binary_write_variable( file_id, var_id, & 2888 2969 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 2889 var_real32_0d=var_real32_0d_pointer, return_value= return_value )2970 var_real32_0d=var_real32_0d_pointer, return_value=output_return_value ) 2890 2971 ELSEIF ( PRESENT( var_real32_1d ) ) THEN 2891 2972 CALL binary_write_variable( file_id, var_id, & 2892 2973 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 2893 var_real32_1d=var_real32_1d_pointer, return_value= return_value )2974 var_real32_1d=var_real32_1d_pointer, return_value=output_return_value ) 2894 2975 ELSEIF ( PRESENT( var_real32_2d ) ) THEN 2895 2976 CALL binary_write_variable( file_id, var_id, & 2896 2977 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 2897 var_real32_2d=var_real32_2d_pointer, return_value= return_value )2978 var_real32_2d=var_real32_2d_pointer, return_value=output_return_value ) 2898 2979 ELSEIF ( PRESENT( var_real32_3d ) ) THEN 2899 2980 CALL binary_write_variable( file_id, var_id, & 2900 2981 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 2901 var_real32_3d=var_real32_3d_pointer, return_value= return_value )2982 var_real32_3d=var_real32_3d_pointer, return_value=output_return_value ) 2902 2983 !-- 64bit real output 2903 2984 ELSEIF ( PRESENT( var_real64_0d ) ) THEN 2904 2985 CALL binary_write_variable( file_id, var_id, & 2905 2986 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 2906 var_real64_0d=var_real64_0d_pointer, return_value= return_value )2987 var_real64_0d=var_real64_0d_pointer, return_value=output_return_value ) 2907 2988 ELSEIF ( PRESENT( var_real64_1d ) ) THEN 2908 2989 CALL binary_write_variable( file_id, var_id, & 2909 2990 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 2910 var_real64_1d=var_real64_1d_pointer, return_value= return_value )2991 var_real64_1d=var_real64_1d_pointer, return_value=output_return_value ) 2911 2992 ELSEIF ( PRESENT( var_real64_2d ) ) THEN 2912 2993 CALL binary_write_variable( file_id, var_id, & 2913 2994 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 2914 var_real64_2d=var_real64_2d_pointer, return_value= return_value )2995 var_real64_2d=var_real64_2d_pointer, return_value=output_return_value ) 2915 2996 ELSEIF ( PRESENT( var_real64_3d ) ) THEN 2916 2997 CALL binary_write_variable( file_id, var_id, & 2917 2998 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 2918 var_real64_3d=var_real64_3d_pointer, return_value= return_value )2999 var_real64_3d=var_real64_3d_pointer, return_value=output_return_value ) 2919 3000 !-- working-precision real output 2920 3001 ELSEIF ( PRESENT( var_realwp_0d ) ) THEN 2921 3002 CALL binary_write_variable( file_id, var_id, & 2922 3003 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 2923 var_realwp_0d=var_realwp_0d_pointer, return_value= return_value )3004 var_realwp_0d=var_realwp_0d_pointer, return_value=output_return_value ) 2924 3005 ELSEIF ( PRESENT( var_realwp_1d ) ) THEN 2925 3006 CALL binary_write_variable( file_id, var_id, & 2926 3007 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 2927 var_realwp_1d=var_realwp_1d_pointer, return_value= return_value )3008 var_realwp_1d=var_realwp_1d_pointer, return_value=output_return_value ) 2928 3009 ELSEIF ( PRESENT( var_realwp_2d ) ) THEN 2929 3010 CALL binary_write_variable( file_id, var_id, & 2930 3011 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 2931 var_realwp_2d=var_realwp_2d_pointer, return_value= return_value )3012 var_realwp_2d=var_realwp_2d_pointer, return_value=output_return_value ) 2932 3013 ELSEIF ( PRESENT( var_realwp_3d ) ) THEN 2933 3014 CALL binary_write_variable( file_id, var_id, & 2934 3015 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 2935 var_realwp_3d=var_realwp_3d_pointer, return_value= return_value )3016 var_realwp_3d=var_realwp_3d_pointer, return_value=output_return_value ) 2936 3017 ELSE 2937 3018 return_value = 1 2938 CALL internal_message( 'error', routine_name // 2939 2940 2941 2942 3019 CALL internal_message( 'error', routine_name // & 3020 ': variable "' // TRIM( name ) // & 3021 '" in file "' // TRIM( filename ) // & 3022 '": output_type not supported by file format "' // & 3023 TRIM( file_format ) // '"' ) 2943 3024 ENDIF 2944 3025 2945 CASE ( 'netcdf4- serial' )3026 CASE ( 'netcdf4-parallel', 'netcdf4-serial' ) 2946 3027 !-- 8bit integer output 2947 3028 IF ( PRESENT( var_int8_0d ) ) THEN 2948 CALL netcdf4_ serial_write_variable( file_id, var_id, &2949 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 2950 var_int8_0d=var_int8_0d_pointer, return_value= return_value )3029 CALL netcdf4_write_variable( file_id, var_id, & 3030 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3031 var_int8_0d=var_int8_0d_pointer, return_value=output_return_value ) 2951 3032 ELSEIF ( PRESENT( var_int8_1d ) ) THEN 2952 CALL netcdf4_ serial_write_variable( file_id, var_id, &2953 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 2954 var_int8_1d=var_int8_1d_pointer, return_value= return_value )3033 CALL netcdf4_write_variable( file_id, var_id, & 3034 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3035 var_int8_1d=var_int8_1d_pointer, return_value=output_return_value ) 2955 3036 ELSEIF ( PRESENT( var_int8_2d ) ) THEN 2956 CALL netcdf4_ serial_write_variable( file_id, var_id, &2957 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 2958 var_int8_2d=var_int8_2d_pointer, return_value= return_value )3037 CALL netcdf4_write_variable( file_id, var_id, & 3038 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3039 var_int8_2d=var_int8_2d_pointer, return_value=output_return_value ) 2959 3040 ELSEIF ( PRESENT( var_int8_3d ) ) THEN 2960 CALL netcdf4_ serial_write_variable( file_id, var_id, &2961 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 2962 var_int8_3d=var_int8_3d_pointer, return_value= return_value )3041 CALL netcdf4_write_variable( file_id, var_id, & 3042 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3043 var_int8_3d=var_int8_3d_pointer, return_value=output_return_value ) 2963 3044 !-- 16bit integer output 2964 3045 ELSEIF ( PRESENT( var_int16_0d ) ) THEN 2965 CALL netcdf4_ serial_write_variable( file_id, var_id, &2966 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 2967 var_int16_0d=var_int16_0d_pointer, return_value= return_value )3046 CALL netcdf4_write_variable( file_id, var_id, & 3047 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3048 var_int16_0d=var_int16_0d_pointer, return_value=output_return_value ) 2968 3049 ELSEIF ( PRESENT( var_int16_1d ) ) THEN 2969 CALL netcdf4_ serial_write_variable( file_id, var_id, &2970 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 2971 var_int16_1d=var_int16_1d_pointer, return_value= return_value )3050 CALL netcdf4_write_variable( file_id, var_id, & 3051 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3052 var_int16_1d=var_int16_1d_pointer, return_value=output_return_value ) 2972 3053 ELSEIF ( PRESENT( var_int16_2d ) ) THEN 2973 CALL netcdf4_ serial_write_variable( file_id, var_id, &2974 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 2975 var_int16_2d=var_int16_2d_pointer, return_value= return_value )3054 CALL netcdf4_write_variable( file_id, var_id, & 3055 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3056 var_int16_2d=var_int16_2d_pointer, return_value=output_return_value ) 2976 3057 ELSEIF ( PRESENT( var_int16_3d ) ) THEN 2977 CALL netcdf4_ serial_write_variable( file_id, var_id, &2978 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 2979 var_int16_3d=var_int16_3d_pointer, return_value= return_value )3058 CALL netcdf4_write_variable( file_id, var_id, & 3059 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3060 var_int16_3d=var_int16_3d_pointer, return_value=output_return_value ) 2980 3061 !-- 32bit integer output 2981 3062 ELSEIF ( PRESENT( var_int32_0d ) ) THEN 2982 CALL netcdf4_ serial_write_variable( file_id, var_id, &2983 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 2984 var_int32_0d=var_int32_0d_pointer, return_value= return_value )3063 CALL netcdf4_write_variable( file_id, var_id, & 3064 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3065 var_int32_0d=var_int32_0d_pointer, return_value=output_return_value ) 2985 3066 ELSEIF ( PRESENT( var_int32_1d ) ) THEN 2986 CALL netcdf4_ serial_write_variable( file_id, var_id, &2987 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 2988 var_int32_1d=var_int32_1d_pointer, return_value= return_value )3067 CALL netcdf4_write_variable( file_id, var_id, & 3068 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3069 var_int32_1d=var_int32_1d_pointer, return_value=output_return_value ) 2989 3070 ELSEIF ( PRESENT( var_int32_2d ) ) THEN 2990 CALL netcdf4_ serial_write_variable( file_id, var_id, &2991 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 2992 var_int32_2d=var_int32_2d_pointer, return_value= return_value )3071 CALL netcdf4_write_variable( file_id, var_id, & 3072 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3073 var_int32_2d=var_int32_2d_pointer, return_value=output_return_value ) 2993 3074 ELSEIF ( PRESENT( var_int32_3d ) ) THEN 2994 CALL netcdf4_ serial_write_variable( file_id, var_id, &2995 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 2996 var_int32_3d=var_int32_3d_pointer, return_value= return_value )3075 CALL netcdf4_write_variable( file_id, var_id, & 3076 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3077 var_int32_3d=var_int32_3d_pointer, return_value=output_return_value ) 2997 3078 !-- working-precision integer output 2998 3079 ELSEIF ( PRESENT( var_intwp_0d ) ) THEN 2999 CALL netcdf4_ serial_write_variable( file_id, var_id, &3000 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3001 var_intwp_0d=var_intwp_0d_pointer, return_value= return_value )3080 CALL netcdf4_write_variable( file_id, var_id, & 3081 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3082 var_intwp_0d=var_intwp_0d_pointer, return_value=output_return_value ) 3002 3083 ELSEIF ( PRESENT( var_intwp_1d ) ) THEN 3003 CALL netcdf4_ serial_write_variable( file_id, var_id, &3004 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3005 var_intwp_1d=var_intwp_1d_pointer, return_value= return_value )3084 CALL netcdf4_write_variable( file_id, var_id, & 3085 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3086 var_intwp_1d=var_intwp_1d_pointer, return_value=output_return_value ) 3006 3087 ELSEIF ( PRESENT( var_intwp_2d ) ) THEN 3007 CALL netcdf4_ serial_write_variable( file_id, var_id, &3008 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3009 var_intwp_2d=var_intwp_2d_pointer, return_value= return_value )3088 CALL netcdf4_write_variable( file_id, var_id, & 3089 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3090 var_intwp_2d=var_intwp_2d_pointer, return_value=output_return_value ) 3010 3091 ELSEIF ( PRESENT( var_intwp_3d ) ) THEN 3011 CALL netcdf4_ serial_write_variable( file_id, var_id, &3012 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3013 var_intwp_3d=var_intwp_3d_pointer, return_value= return_value )3092 CALL netcdf4_write_variable( file_id, var_id, & 3093 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3094 var_intwp_3d=var_intwp_3d_pointer, return_value=output_return_value ) 3014 3095 !-- 32bit real output 3015 3096 ELSEIF ( PRESENT( var_real32_0d ) ) THEN 3016 CALL netcdf4_ serial_write_variable( file_id, var_id, &3017 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3018 var_real32_0d=var_real32_0d_pointer, return_value= return_value )3097 CALL netcdf4_write_variable( file_id, var_id, & 3098 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3099 var_real32_0d=var_real32_0d_pointer, return_value=output_return_value ) 3019 3100 ELSEIF ( PRESENT( var_real32_1d ) ) THEN 3020 CALL netcdf4_ serial_write_variable( file_id, var_id, &3021 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3022 var_real32_1d=var_real32_1d_pointer, return_value= return_value )3101 CALL netcdf4_write_variable( file_id, var_id, & 3102 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3103 var_real32_1d=var_real32_1d_pointer, return_value=output_return_value ) 3023 3104 ELSEIF ( PRESENT( var_real32_2d ) ) THEN 3024 CALL netcdf4_ serial_write_variable( file_id, var_id, &3025 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3026 var_real32_2d=var_real32_2d_pointer, return_value= return_value )3105 CALL netcdf4_write_variable( file_id, var_id, & 3106 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3107 var_real32_2d=var_real32_2d_pointer, return_value=output_return_value ) 3027 3108 ELSEIF ( PRESENT( var_real32_3d ) ) THEN 3028 CALL netcdf4_ serial_write_variable( file_id, var_id, &3029 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3030 var_real32_3d=var_real32_3d_pointer, return_value= return_value )3109 CALL netcdf4_write_variable( file_id, var_id, & 3110 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3111 var_real32_3d=var_real32_3d_pointer, return_value=output_return_value ) 3031 3112 !-- 64bit real output 3032 3113 ELSEIF ( PRESENT( var_real64_0d ) ) THEN 3033 CALL netcdf4_ serial_write_variable( file_id, var_id, &3034 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3035 var_real64_0d=var_real64_0d_pointer, return_value= return_value )3114 CALL netcdf4_write_variable( file_id, var_id, & 3115 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3116 var_real64_0d=var_real64_0d_pointer, return_value=output_return_value ) 3036 3117 ELSEIF ( PRESENT( var_real64_1d ) ) THEN 3037 CALL netcdf4_ serial_write_variable( file_id, var_id, &3038 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3039 var_real64_1d=var_real64_1d_pointer, return_value= return_value )3118 CALL netcdf4_write_variable( file_id, var_id, & 3119 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3120 var_real64_1d=var_real64_1d_pointer, return_value=output_return_value ) 3040 3121 ELSEIF ( PRESENT( var_real64_2d ) ) THEN 3041 CALL netcdf4_ serial_write_variable( file_id, var_id, &3042 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3043 var_real64_2d=var_real64_2d_pointer, return_value= return_value )3122 CALL netcdf4_write_variable( file_id, var_id, & 3123 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3124 var_real64_2d=var_real64_2d_pointer, return_value=output_return_value ) 3044 3125 ELSEIF ( PRESENT( var_real64_3d ) ) THEN 3045 CALL netcdf4_ serial_write_variable( file_id, var_id, &3046 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3047 var_real64_3d=var_real64_3d_pointer, return_value= return_value )3126 CALL netcdf4_write_variable( file_id, var_id, & 3127 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3128 var_real64_3d=var_real64_3d_pointer, return_value=output_return_value ) 3048 3129 !-- working-precision real output 3049 3130 ELSEIF ( PRESENT( var_realwp_0d ) ) THEN 3050 CALL netcdf4_ serial_write_variable( file_id, var_id, &3051 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3052 var_realwp_0d=var_realwp_0d_pointer, return_value= return_value )3131 CALL netcdf4_write_variable( file_id, var_id, & 3132 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3133 var_realwp_0d=var_realwp_0d_pointer, return_value=output_return_value ) 3053 3134 ELSEIF ( PRESENT( var_realwp_1d ) ) THEN 3054 CALL netcdf4_ serial_write_variable( file_id, var_id, &3055 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3056 var_realwp_1d=var_realwp_1d_pointer, return_value= return_value )3135 CALL netcdf4_write_variable( file_id, var_id, & 3136 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3137 var_realwp_1d=var_realwp_1d_pointer, return_value=output_return_value ) 3057 3138 ELSEIF ( PRESENT( var_realwp_2d ) ) THEN 3058 CALL netcdf4_ serial_write_variable( file_id, var_id, &3059 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3060 var_realwp_2d=var_realwp_2d_pointer, return_value= return_value )3139 CALL netcdf4_write_variable( file_id, var_id, & 3140 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3141 var_realwp_2d=var_realwp_2d_pointer, return_value=output_return_value ) 3061 3142 ELSEIF ( PRESENT( var_realwp_3d ) ) THEN 3062 CALL netcdf4_ serial_write_variable( file_id, var_id, &3063 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3064 var_realwp_3d=var_realwp_3d_pointer, return_value= return_value )3143 CALL netcdf4_write_variable( file_id, var_id, & 3144 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3145 var_realwp_3d=var_realwp_3d_pointer, return_value=output_return_value ) 3065 3146 ELSE 3066 3147 return_value = 1 3067 CALL internal_message( 'error', routine_name // & 3068 ': variable "' // TRIM( name ) // & 3069 '" in file "' // TRIM( filename ) // & 3070 '": output_type not supported by file format "' // & 3071 TRIM( file_format ) // '"' ) 3072 ENDIF 3073 3074 CASE ( 'netcdf4-parallel' ) 3075 !-- 8bit integer output 3076 IF ( PRESENT( var_int8_0d ) ) THEN 3077 CALL netcdf4_parallel_write_variable( file_id, var_id, & 3078 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3079 var_int8_0d=var_int8_0d_pointer, return_value=return_value ) 3080 ELSEIF ( PRESENT( var_int8_1d ) ) THEN 3081 CALL netcdf4_parallel_write_variable( file_id, var_id, & 3082 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3083 var_int8_1d=var_int8_1d_pointer, return_value=return_value ) 3084 ELSEIF ( PRESENT( var_int8_2d ) ) THEN 3085 CALL netcdf4_parallel_write_variable( file_id, var_id, & 3086 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3087 var_int8_2d=var_int8_2d_pointer, return_value=return_value ) 3088 ELSEIF ( PRESENT( var_int8_3d ) ) THEN 3089 CALL netcdf4_parallel_write_variable( file_id, var_id, & 3090 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3091 var_int8_3d=var_int8_3d_pointer, return_value=return_value ) 3092 !-- 16bit integer output 3093 ELSEIF ( PRESENT( var_int16_0d ) ) THEN 3094 CALL netcdf4_parallel_write_variable( file_id, var_id, & 3095 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3096 var_int16_0d=var_int16_0d_pointer, return_value=return_value ) 3097 ELSEIF ( PRESENT( var_int16_1d ) ) THEN 3098 CALL netcdf4_parallel_write_variable( file_id, var_id, & 3099 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3100 var_int16_1d=var_int16_1d_pointer, return_value=return_value ) 3101 ELSEIF ( PRESENT( var_int16_2d ) ) THEN 3102 CALL netcdf4_parallel_write_variable( file_id, var_id, & 3103 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3104 var_int16_2d=var_int16_2d_pointer, return_value=return_value ) 3105 ELSEIF ( PRESENT( var_int16_3d ) ) THEN 3106 CALL netcdf4_parallel_write_variable( file_id, var_id, & 3107 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3108 var_int16_3d=var_int16_3d_pointer, return_value=return_value ) 3109 !-- 32bit integer output 3110 ELSEIF ( PRESENT( var_int32_0d ) ) THEN 3111 CALL netcdf4_parallel_write_variable( file_id, var_id, & 3112 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3113 var_int32_0d=var_int32_0d_pointer, return_value=return_value ) 3114 ELSEIF ( PRESENT( var_int32_1d ) ) THEN 3115 CALL netcdf4_parallel_write_variable( file_id, var_id, & 3116 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3117 var_int32_1d=var_int32_1d_pointer, return_value=return_value ) 3118 ELSEIF ( PRESENT( var_int32_2d ) ) THEN 3119 CALL netcdf4_parallel_write_variable( file_id, var_id, & 3120 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3121 var_int32_2d=var_int32_2d_pointer, return_value=return_value ) 3122 ELSEIF ( PRESENT( var_int32_3d ) ) THEN 3123 CALL netcdf4_parallel_write_variable( file_id, var_id, & 3124 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3125 var_int32_3d=var_int32_3d_pointer, return_value=return_value ) 3126 !-- working-precision integer output 3127 ELSEIF ( PRESENT( var_intwp_0d ) ) THEN 3128 CALL netcdf4_parallel_write_variable( file_id, var_id, & 3129 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3130 var_intwp_0d=var_intwp_0d_pointer, return_value=return_value ) 3131 ELSEIF ( PRESENT( var_intwp_1d ) ) THEN 3132 CALL netcdf4_parallel_write_variable( file_id, var_id, & 3133 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3134 var_intwp_1d=var_intwp_1d_pointer, return_value=return_value ) 3135 ELSEIF ( PRESENT( var_intwp_2d ) ) THEN 3136 CALL netcdf4_parallel_write_variable( file_id, var_id, & 3137 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3138 var_intwp_2d=var_intwp_2d_pointer, return_value=return_value ) 3139 ELSEIF ( PRESENT( var_intwp_3d ) ) THEN 3140 CALL netcdf4_parallel_write_variable( file_id, var_id, & 3141 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3142 var_intwp_3d=var_intwp_3d_pointer, return_value=return_value ) 3143 !-- 32bit real output 3144 ELSEIF ( PRESENT( var_real32_0d ) ) THEN 3145 CALL netcdf4_parallel_write_variable( file_id, var_id, & 3146 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3147 var_real32_0d=var_real32_0d_pointer, return_value=return_value ) 3148 ELSEIF ( PRESENT( var_real32_1d ) ) THEN 3149 CALL netcdf4_parallel_write_variable( file_id, var_id, & 3150 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3151 var_real32_1d=var_real32_1d_pointer, return_value=return_value ) 3152 ELSEIF ( PRESENT( var_real32_2d ) ) THEN 3153 CALL netcdf4_parallel_write_variable( file_id, var_id, & 3154 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3155 var_real32_2d=var_real32_2d_pointer, return_value=return_value ) 3156 ELSEIF ( PRESENT( var_real32_3d ) ) THEN 3157 CALL netcdf4_parallel_write_variable( file_id, var_id, & 3158 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3159 var_real32_3d=var_real32_3d_pointer, return_value=return_value ) 3160 !-- 64bit real output 3161 ELSEIF ( PRESENT( var_real64_0d ) ) THEN 3162 CALL netcdf4_parallel_write_variable( file_id, var_id, & 3163 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3164 var_real64_0d=var_real64_0d_pointer, return_value=return_value ) 3165 ELSEIF ( PRESENT( var_real64_1d ) ) THEN 3166 CALL netcdf4_parallel_write_variable( file_id, var_id, & 3167 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3168 var_real64_1d=var_real64_1d_pointer, return_value=return_value ) 3169 ELSEIF ( PRESENT( var_real64_2d ) ) THEN 3170 CALL netcdf4_parallel_write_variable( file_id, var_id, & 3171 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3172 var_real64_2d=var_real64_2d_pointer, return_value=return_value ) 3173 ELSEIF ( PRESENT( var_real64_3d ) ) THEN 3174 CALL netcdf4_parallel_write_variable( file_id, var_id, & 3175 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3176 var_real64_3d=var_real64_3d_pointer, return_value=return_value ) 3177 !-- working-precision real output 3178 ELSEIF ( PRESENT( var_realwp_0d ) ) THEN 3179 CALL netcdf4_parallel_write_variable( file_id, var_id, & 3180 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3181 var_realwp_0d=var_realwp_0d_pointer, return_value=return_value ) 3182 ELSEIF ( PRESENT( var_realwp_1d ) ) THEN 3183 CALL netcdf4_parallel_write_variable( file_id, var_id, & 3184 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3185 var_realwp_1d=var_realwp_1d_pointer, return_value=return_value ) 3186 ELSEIF ( PRESENT( var_realwp_2d ) ) THEN 3187 CALL netcdf4_parallel_write_variable( file_id, var_id, & 3188 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3189 var_realwp_2d=var_realwp_2d_pointer, return_value=return_value ) 3190 ELSEIF ( PRESENT( var_realwp_3d ) ) THEN 3191 CALL netcdf4_parallel_write_variable( file_id, var_id, & 3192 bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, & 3193 var_realwp_3d=var_realwp_3d_pointer, return_value=return_value ) 3194 ELSE 3195 return_value = 1 3196 CALL internal_message( 'error', routine_name // & 3197 ': variable "' // TRIM( name ) // & 3198 '" in file "' // TRIM( filename ) // & 3199 '": output_type not supported by file format "' // & 3200 TRIM( file_format ) // '"' ) 3148 CALL internal_message( 'error', routine_name // & 3149 ': variable "' // TRIM( name ) // & 3150 '" in file "' // TRIM( filename ) // & 3151 '": output_type not supported by file format "' // & 3152 TRIM( file_format ) // '"' ) 3201 3153 ENDIF 3202 3154 … … 3210 3162 END SELECT 3211 3163 3164 IF ( return_value == 0 .AND. output_return_value /= 0 ) THEN 3165 return_value = 1 3166 CALL internal_message( 'error', routine_name // & 3167 ': error while writing variable "' // TRIM( name ) // & 3168 '" in file "' // TRIM( filename ) // '"' ) 3169 ENDIF 3170 3212 3171 ENDIF 3213 3172 … … 3248 3207 DO f = 1, nf 3249 3208 IF ( TRIM( filename ) == TRIM( files(f)%name ) ) THEN 3209 3210 IF ( .NOT. files(f)%is_init ) THEN 3211 return_value = 1 3212 CALL internal_message( 'error', routine_name // & 3213 ': file "' // TRIM( filename ) // & 3214 '" is not initialized. ' // & 3215 'Writing variable "' // TRIM( var_name ) // & 3216 '" to file is impossible.' ) 3217 EXIT 3218 ENDIF 3219 3250 3220 file_id = files(f)%id 3251 3221 file_format = files(f)%format … … 3421 3391 3422 3392 INTEGER(iwp) :: return_value !< return value 3423 INTEGER(iwp) :: return_value_internal !< return value from called routines 3393 INTEGER(iwp) :: return_value_internal !< error code after closing a single file 3394 INTEGER(iwp) :: output_return_value !< return value from called routines 3424 3395 INTEGER(iwp) :: f !< loop index 3425 3396 … … 3429 3400 DO f = 1, nf 3430 3401 3431 return_value_internal = 0 3432 3433 SELECT CASE ( TRIM( files(f)%format ) ) 3434 3435 CASE ( 'binary' ) 3436 CALL binary_finalize( files(f)%id, return_value_internal ) 3437 3438 CASE ( 'netcdf4-serial' ) 3439 CALL netcdf4_serial_finalize( files(f)%id, return_value_internal ) 3440 3441 CASE ( 'netcdf4-parallel' ) 3442 CALL netcdf4_parallel_finalize( files(f)%id, return_value_internal ) 3443 3444 CASE DEFAULT 3445 return_value_internal = 1 3446 CALL internal_message( 'error', routine_name // & 3447 ': unsupported file format "' // TRIM( files(f)%format ) ) 3448 3449 END SELECT 3450 3451 IF ( return_value_internal /= 0 ) return_value = return_value_internal 3402 IF ( files(f)%is_init ) THEN 3403 3404 output_return_value = 0 3405 return_value_internal = 0 3406 3407 SELECT CASE ( TRIM( files(f)%format ) ) 3408 3409 CASE ( 'binary' ) 3410 CALL binary_finalize( files(f)%id, output_return_value ) 3411 3412 CASE ( 'netcdf4-parallel', 'netcdf4-serial' ) 3413 CALL netcdf4_finalize( files(f)%id, output_return_value ) 3414 3415 CASE DEFAULT 3416 return_value_internal = 1 3417 3418 END SELECT 3419 3420 IF ( output_return_value /= 0 ) THEN 3421 return_value = output_return_value 3422 CALL internal_message( 'error', routine_name // & 3423 ': error while finalizing file "' // & 3424 TRIM( files(f)%name ) // '"' ) 3425 ELSEIF ( return_value_internal /= 0 ) THEN 3426 return_value = return_value_internal 3427 CALL internal_message( 'error', routine_name // & 3428 ': unsupported file format "' // & 3429 TRIM( files(f)%format ) // '"' ) 3430 ENDIF 3431 3432 ENDIF 3452 3433 3453 3434 ENDDO … … 3488 3469 3489 3470 CHARACTER(LEN=800), INTENT(OUT) :: error_message !< return error message to main program 3490 CHARACTER(LEN=800) :: module_error_message !< error message created by other module 3491 3492 3493 CALL binary_get_error_message( module_error_message ) 3494 internal_error_message = TRIM( internal_error_message ) // module_error_message 3495 3496 CALL netcdf4_serial_get_error_message( module_error_message ) 3497 internal_error_message = TRIM( internal_error_message ) // module_error_message 3498 3499 CALL netcdf4_parallel_get_error_message( module_error_message ) 3500 internal_error_message = TRIM( internal_error_message ) // module_error_message 3471 CHARACTER(LEN=800) :: output_error_message !< error message created by other module 3472 3473 3474 CALL binary_get_error_message( output_error_message ) 3475 internal_error_message = TRIM( internal_error_message ) // output_error_message 3476 3477 CALL netcdf4_get_error_message( output_error_message ) 3478 internal_error_message = TRIM( internal_error_message ) // output_error_message 3501 3479 3502 3480 error_message = internal_error_message
Note: See TracChangeset
for help on using the changeset viewer.
