Changeset 4577 for palm/trunk/SOURCE/data_output_module.f90
- Timestamp:
- Jun 25, 2020 9:53:58 AM (4 years ago)
- File:
-
- 1 edited
-
palm/trunk/SOURCE/data_output_module.f90 (modified) (159 diffs)
Legend:
- Unmodified
- Added
- Removed
-
palm/trunk/SOURCE/data_output_module.f90
r4500 r4577 3 3 ! This file is part of the PALM model system. 4 4 ! 5 ! PALM is free software: you can redistribute it and/or modify it under the 6 ! terms of the GNU General Public License as published by the Free Software 7 ! Foundation, either version 3 of the License, or (at your option) any later 8 ! version. 9 ! 10 ! PALM is distributed in the hope that it will be useful, but WITHOUT ANY 11 ! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR 12 ! A PARTICULAR PURPOSE. See the GNU General Public License for more details. 13 ! 14 ! You should have received a copy of the GNU General Public License along with 15 ! PALM. If not, see <http://www.gnu.org/licenses/>. 5 ! PALM is free software: you can redistribute it and/or modify it under the terms of the GNU General 6 ! Public License as published by the Free Software Foundation, either version 3 of the License, or 7 ! (at your option) any later version. 8 ! 9 ! PALM is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the 10 ! implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 11 ! Public License for more details. 12 ! 13 ! You should have received a copy of the GNU General Public License along with PALM. If not, see 14 ! <http://www.gnu.org/licenses/>. 16 15 ! 17 16 ! Copyright 2019-2020 Leibniz Universitaet Hannover … … 25 24 ! ----------------- 26 25 ! $Id$ 26 ! file re-formatted to follow the PALM coding standard 27 ! 28 ! 4500 2020-04-17 10:12:45Z suehring 27 29 ! Avoid uninitialized variables 28 ! 30 ! 29 31 ! 4481 2020-03-31 18:55:54Z maronga 30 32 ! Enable character-array output … … 72 74 USE kinds 73 75 74 USE data_output_netcdf4_module, &75 ONLY: netcdf4_ init_dimension,&76 netcdf4_get_error_message, &77 netcdf4_ stop_file_header_definition,&78 netcdf4_init_module, &79 netcdf4_init_variable, &80 netcdf4_ finalize,&81 netcdf4_ open_file,&82 netcdf4_write_attribute, &76 USE data_output_netcdf4_module, & 77 ONLY: netcdf4_finalize, & 78 netcdf4_get_error_message, & 79 netcdf4_init_dimension, & 80 netcdf4_init_module, & 81 netcdf4_init_variable, & 82 netcdf4_open_file, & 83 netcdf4_stop_file_header_definition, & 84 netcdf4_write_attribute, & 83 85 netcdf4_write_variable 84 86 85 USE data_output_binary_module, &86 ONLY: binary_finalize, &87 binary_get_error_message, &88 binary_init_dimension, &89 binary_ stop_file_header_definition,&90 binary_init_ module,&91 binary_ init_variable,&92 binary_ open_file,&93 binary_write_attribute, &87 USE data_output_binary_module, & 88 ONLY: binary_finalize, & 89 binary_get_error_message, & 90 binary_init_dimension, & 91 binary_init_module, & 92 binary_init_variable, & 93 binary_open_file, & 94 binary_stop_file_header_definition, & 95 binary_write_attribute, & 94 96 binary_write_variable 95 97 … … 113 115 CHARACTER(LEN=charlen) :: data_type = '' !< data type 114 116 CHARACTER(LEN=charlen) :: name !< variable name 117 CHARACTER(LEN=charlen), DIMENSION(:), ALLOCATABLE :: dimension_names !< list of 118 !< dimension names used by variable 115 119 INTEGER :: id = no_id !< id within file 116 LOGICAL :: is_global = .FALSE. !< true if global variable 117 CHARACTER(LEN=charlen), DIMENSION(:), ALLOCATABLE :: dimension_names !< list of dimension names used by variable 118 INTEGER, DIMENSION(:), ALLOCATABLE :: dimension_ids !< list of dimension ids used by variable 119 TYPE(attribute_type), DIMENSION(:), ALLOCATABLE :: attributes !< list of attributes 120 LOGICAL :: is_global = .FALSE. !< true if global 121 !< variable 122 INTEGER, DIMENSION(:), ALLOCATABLE :: dimension_ids !< list of 123 !< dimension ids used by variable 124 TYPE(attribute_type), DIMENSION(:), ALLOCATABLE :: attributes !< list of 125 !< attributes 120 126 END TYPE variable_type 121 127 … … 123 129 CHARACTER(LEN=charlen) :: data_type = '' !< data type 124 130 CHARACTER(LEN=charlen) :: name !< dimension name 125 INTEGER :: id = no_id !< dimension id within file 131 INTEGER :: id = no_id !< dimension id within 132 !< file 126 133 INTEGER :: length !< length of dimension 127 INTEGER :: length_mask !< length of masked dimension 128 INTEGER :: variable_id = no_id !< associated variable id within file 134 INTEGER :: length_mask !< length of masked 135 !< dimension 136 INTEGER :: variable_id = no_id !< associated variable 137 !< id within file 129 138 LOGICAL :: is_masked = .FALSE. !< true if masked 130 INTEGER, DIMENSION(2) :: bounds !< lower and upper bound of dimension 131 INTEGER, DIMENSION(:), ALLOCATABLE :: masked_indices !< list of masked indices of dimension 132 INTEGER(KIND=1), DIMENSION(:), ALLOCATABLE :: masked_values_int8 !< masked dimension values if 16bit integer 133 INTEGER(KIND=2), DIMENSION(:), ALLOCATABLE :: masked_values_int16 !< masked dimension values if 16bit integer 134 INTEGER(KIND=4), DIMENSION(:), ALLOCATABLE :: masked_values_int32 !< masked dimension values if 32bit integer 135 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: masked_values_intwp !< masked dimension values if working-precision int 136 INTEGER(KIND=1), DIMENSION(:), ALLOCATABLE :: values_int8 !< dimension values if 16bit integer 137 INTEGER(KIND=2), DIMENSION(:), ALLOCATABLE :: values_int16 !< dimension values if 16bit integer 138 INTEGER(KIND=4), DIMENSION(:), ALLOCATABLE :: values_int32 !< dimension values if 32bit integer 139 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: values_intwp !< dimension values if working-precision integer 139 INTEGER, DIMENSION(2) :: bounds !< lower and upper bound 140 !< of dimension 141 INTEGER, DIMENSION(:), ALLOCATABLE :: masked_indices !< list of masked 142 !< indices of dimension 143 INTEGER(KIND=1), DIMENSION(:), ALLOCATABLE :: masked_values_int8 !< masked dimension 144 !< values if 16bit integer 145 INTEGER(KIND=2), DIMENSION(:), ALLOCATABLE :: masked_values_int16 !< masked dimension 146 !< values if 16bit integer 147 INTEGER(KIND=4), DIMENSION(:), ALLOCATABLE :: masked_values_int32 !< masked dimension 148 !< values if 32bit integer 149 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: masked_values_intwp !< masked dimension 150 !< values if working-precision int 151 INTEGER(KIND=1), DIMENSION(:), ALLOCATABLE :: values_int8 !< dimension values if 152 !< 16bit integer 153 INTEGER(KIND=2), DIMENSION(:), ALLOCATABLE :: values_int16 !< dimension values if 154 !< 16bit integer 155 INTEGER(KIND=4), DIMENSION(:), ALLOCATABLE :: values_int32 !< dimension values if 156 !< 32bit integer 157 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: values_intwp !< dimension values if 158 !< working-precision integer 140 159 LOGICAL, DIMENSION(:), ALLOCATABLE :: mask !< mask 141 REAL(KIND=4), DIMENSION(:), ALLOCATABLE :: masked_values_real32 !< masked dimension values if 32bit real 142 REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: masked_values_real64 !< masked dimension values if 64bit real 143 REAL(wp), DIMENSION(:), ALLOCATABLE :: masked_values_realwp !< masked dimension values if working-precision real 144 REAL(KIND=4), DIMENSION(:), ALLOCATABLE :: values_real32 !< dimension values if 32bit real 145 REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: values_real64 !< dimension values if 64bit real 146 REAL(wp), DIMENSION(:), ALLOCATABLE :: values_realwp !< dimension values if working-precision real 160 REAL(KIND=4), DIMENSION(:), ALLOCATABLE :: masked_values_real32 !< masked dimension 161 !< values if 32bit real 162 REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: masked_values_real64 !< masked dimension 163 !< values if 64bit real 164 REAL(wp), DIMENSION(:), ALLOCATABLE :: masked_values_realwp !< masked dimension 165 !< values if working-precision real 166 REAL(KIND=4), DIMENSION(:), ALLOCATABLE :: values_real32 !< dimension values if 167 !< 32bit real 168 REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: values_real64 !< dimension values if 169 !< 64bit real 170 REAL(wp), DIMENSION(:), ALLOCATABLE :: values_realwp !< dimension values if 171 !< working-precision real 147 172 TYPE(attribute_type), DIMENSION(:), ALLOCATABLE :: attributes !< list of attributes 148 173 END TYPE dimension_type … … 159 184 160 185 186 CHARACTER(LEN=800) :: internal_error_message = '' !< string containing the last error message 161 187 CHARACTER(LEN=charlen) :: output_file_suffix = '' !< file suffix added to each file name 162 CHARACTER(LEN=800) :: internal_error_message = '' !< string containing the last error message163 188 CHARACTER(LEN=800) :: temp_string !< dummy string 164 189 … … 296 321 FUNCTION dom_def_file( file_name, file_format ) RESULT( return_value ) 297 322 323 CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_file' !< name of this routine 324 298 325 CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file to be created 299 326 CHARACTER(LEN=*), INTENT(IN) :: file_format !< format of file to be created 300 301 CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_file' !< name of this routine302 327 303 328 INTEGER :: f !< loop index … … 385 410 mask ) RESULT( return_value ) 386 411 412 CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_dim' !< name of this routine 413 387 414 CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file 388 415 CHARACTER(LEN=*), INTENT(IN) :: dimension_name !< name of dimension 389 416 CHARACTER(LEN=*), INTENT(IN) :: output_type !< data type of dimension variable in output file 390 391 CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_dim' !< name of this routine392 417 393 418 INTEGER :: d !< loop index … … 416 441 return_value = 0 417 442 418 CALL internal_message( 'debug', routine_name // &419 ': define dimension ' // &420 '(dimension "' // TRIM( dimension_name ) // &443 CALL internal_message( 'debug', routine_name // & 444 ': define dimension ' // & 445 '(dimension "' // TRIM( dimension_name ) // & 421 446 '", file "' // TRIM( file_name ) // '")' ) 422 447 … … 427 452 IF ( SIZE( bounds ) == 1 ) THEN 428 453 ! 429 !-- Dimension has only lower bound, which means it changes its size 430 !-- during simulation. 454 !-- Dimension has only lower bound, which means it changes its size during simulation. 431 455 !-- Set length to -1 as indicator. 432 456 dimension%bounds(:) = bounds(1) … … 435 459 IF ( PRESENT( mask ) ) THEN 436 460 return_value = 1 437 CALL internal_message( 'error', routine_name // &438 ': unlimited dimensions cannot be masked ' // &439 '(dimension "' // TRIM( dimension_name ) // &461 CALL internal_message( 'error', routine_name // & 462 ': unlimited dimensions cannot be masked ' // & 463 '(dimension "' // TRIM( dimension_name ) // & 440 464 '", file "' // TRIM( file_name ) // '")!' ) 441 465 ENDIF … … 512 536 ELSE 513 537 return_value = 1 514 CALL internal_message( 'error', routine_name // &515 ': no values given ' // &516 '(dimension "' // TRIM( dimension_name ) // &538 CALL internal_message( 'error', routine_name // & 539 ': no values given ' // & 540 '(dimension "' // TRIM( dimension_name ) // & 517 541 '", file "' // TRIM( file_name ) // '")!' ) 518 542 ENDIF … … 520 544 IF ( return_value == 2 ) THEN 521 545 return_value = 1 522 CALL internal_message( 'error', routine_name // &523 ': number of values and given bounds do not match ' // &524 '(dimension "' // TRIM( dimension_name ) // &546 CALL internal_message( 'error', routine_name // & 547 ': number of values and given bounds do not match ' // & 548 '(dimension "' // TRIM( dimension_name ) // & 525 549 '", file "' // TRIM( file_name ) // '")!' ) 526 550 ENDIF … … 533 557 IF ( ALL( mask ) ) THEN 534 558 535 CALL internal_message( 'debug', routine_name // &536 ': mask contains only TRUE values. Ignoring mask ' // &537 '(dimension "' // TRIM( dimension_name ) // &559 CALL internal_message( 'debug', routine_name // & 560 ': mask contains only TRUE values. Ignoring mask ' // & 561 '(dimension "' // TRIM( dimension_name ) // & 538 562 '", file "' // TRIM( file_name ) // '")!' ) 539 563 … … 577 601 ALLOCATE( dimension%masked_values_int32(0:dimension%length_mask-1) ) 578 602 j = 0 579 DO i = dimension%bounds(1), dimension%bounds(2)603 DO i = dimension%bounds(1), dimension%bounds(2) 580 604 IF ( dimension%mask(i) ) THEN 581 605 dimension%masked_values_int32(j) = dimension%values_int32(i) … … 639 663 ELSE 640 664 return_value = 1 641 CALL internal_message( 'error', routine_name // &642 ': size of mask and given bounds do not match ' // &643 '(dimension "' // TRIM( dimension_name ) // &665 CALL internal_message( 'error', routine_name // & 666 ': size of mask and given bounds do not match ' // & 667 '(dimension "' // TRIM( dimension_name ) // & 644 668 '", file "' // TRIM( file_name ) // '")!' ) 645 669 ENDIF … … 650 674 651 675 return_value = 1 652 CALL internal_message( 'error', routine_name // &653 ': at least one but no more than two bounds must be given ' // &654 '(dimension "' // TRIM( dimension_name ) // &676 CALL internal_message( 'error', routine_name // & 677 ': at least one but no more than two bounds must be given ' // & 678 '(dimension "' // TRIM( dimension_name ) // & 655 679 '", file "' // TRIM( file_name ) // '")!' ) 656 680 … … 667 691 668 692 return_value = 1 669 CALL internal_message( 'error', routine_name // &670 ': file already initialized. ' // &671 'No further dimension definition allowed ' // &672 '(dimension "' // TRIM( dimension_name ) // &693 CALL internal_message( 'error', routine_name // & 694 ': file already initialized. ' // & 695 'No further dimension definition allowed ' // & 696 '(dimension "' // TRIM( dimension_name ) // & 673 697 '", file "' // TRIM( file_name ) // '")!' ) 674 698 EXIT … … 686 710 IF ( files(f)%variables(i)%name == dimension%name ) THEN 687 711 return_value = 1 688 CALL internal_message( 'error', routine_name // &689 ': file already has a variable of this name defined. ' // &690 'Defining a dimension of the same name is not allowed ' // &691 '(dimension "' // TRIM( dimension_name ) // &692 '", file "' // TRIM( file_name ) // '")!' )712 CALL internal_message( 'error', routine_name // & 713 ': file already has a variable of this name defined. ' // & 714 'Defining a dimension of the same name is not allowed ' // & 715 '(dimension "' // TRIM( dimension_name ) // & 716 '", file "' // TRIM( file_name ) // '")!' ) 693 717 EXIT 694 718 ENDIF … … 704 728 IF ( files(f)%dimensions(d)%name == dimension%name ) THEN 705 729 return_value = 1 706 CALL internal_message( 'error', routine_name // &707 ': dimension already exists in file ' //&708 '(dimension "' // TRIM( dimension_name ) //&709 '", file "' // TRIM( file_name ) // '")!' )730 CALL internal_message( 'error', routine_name // & 731 ': dimension already exists in file ' // & 732 '(dimension "' // TRIM( dimension_name ) // & 733 '", file "' // TRIM( file_name ) // '")!' ) 710 734 EXIT 711 735 ENDIF … … 736 760 IF ( f > nfiles ) THEN 737 761 return_value = 1 738 CALL internal_message( 'error', routine_name // &739 ': file not found (dimension "' // TRIM( dimension_name ) // &762 CALL internal_message( 'error', routine_name // & 763 ': file not found (dimension "' // TRIM( dimension_name ) // & 740 764 '", file "' // TRIM( file_name ) // '")!' ) 741 765 ENDIF … … 750 774 !> Add variable to database. 751 775 !> If a variable is identical for each MPI rank, the optional argument 'is_global' should be set to 752 !> TRUE. This flags the variable to be a global variable and is later only written once by the776 !> .TRUE. This flags the variable to be a global variable and is later only written once by the 753 777 !> master output rank. 754 778 !> Example call: … … 770 794 !> ALLOCATE( u(<z>,<y>,<x>) ) 771 795 !--------------------------------------------------------------------------------------------------! 772 FUNCTION dom_def_var( file_name, variable_name, dimension_names, output_type, is_global ) &796 FUNCTION dom_def_var( file_name, variable_name, dimension_names, output_type, is_global ) & 773 797 RESULT( return_value ) 774 798 799 CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_var' !< name of this routine 800 775 801 CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file 802 CHARACTER(LEN=*), INTENT(IN) :: output_type !< data type of variable 776 803 CHARACTER(LEN=*), INTENT(IN) :: variable_name !< name of variable 777 CHARACTER(LEN=*), INTENT(IN) :: output_type !< data type of variable778 779 CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_var' !< name of this routine780 804 781 805 CHARACTER(LEN=*), DIMENSION(:), INTENT(IN) :: dimension_names !< list of dimension names … … 797 821 found = .FALSE. 798 822 799 CALL internal_message( 'debug', routine_name // &800 ': define variable (variable "' // TRIM( variable_name ) // &823 CALL internal_message( 'debug', routine_name // & 824 ': define variable (variable "' // TRIM( variable_name ) // & 801 825 '", file "' // TRIM( file_name ) // '")' ) 802 826 … … 824 848 825 849 return_value = 1 826 CALL internal_message( 'error', routine_name // &827 ': file already initialized. No further variable definition allowed ' // &828 '(variable "' // TRIM( variable_name ) // &829 '", file "' // TRIM( file_name ) // '")!' )850 CALL internal_message( 'error', routine_name // & 851 ': file already initialized. No further variable definition allowed ' // & 852 '(variable "' // TRIM( variable_name ) // & 853 '", file "' // TRIM( file_name ) // '")!' ) 830 854 EXIT 831 855 … … 836 860 IF ( files(f)%dimensions(d)%name == variable%name ) THEN 837 861 return_value = 1 838 CALL internal_message( 'error', routine_name // &839 ': file already has a dimension of this name defined. ' // &840 'Defining a variable of the same name is not allowed ' // &841 '(variable "' // TRIM( variable_name ) // &842 '", file "' // TRIM( file_name ) // '")!' )862 CALL internal_message( 'error', routine_name // & 863 ': file already has a dimension of this name defined. ' // & 864 'Defining a variable of the same name is not allowed ' // & 865 '(variable "' // TRIM( variable_name ) // & 866 '", file "' // TRIM( file_name ) // '")!' ) 843 867 EXIT 844 868 ENDIF … … 857 881 IF ( .NOT. found ) THEN 858 882 return_value = 1 859 CALL internal_message( 'error', routine_name // &860 ': required dimension "'//TRIM( variable%dimension_names(i) ) // &861 '" for variable is not defined ' //&862 '(variable "' // TRIM( variable_name ) //&863 '", file "' // TRIM( file_name ) // '")!' )883 CALL internal_message( 'error', routine_name // & 884 ': required dimension "'// TRIM( variable%dimension_names(i) ) // & 885 '" for variable is not defined ' // & 886 '(variable "' // TRIM( variable_name ) // & 887 '", file "' // TRIM( file_name ) // '")!' ) 864 888 EXIT 865 889 ENDIF … … 870 894 871 895 return_value = 1 872 CALL internal_message( 'error', routine_name // &873 ': no dimensions defined in file. Cannot define variable '//&874 '(variable "' // TRIM( variable_name ) //&875 '", file "' // TRIM( file_name ) // '")!' )896 CALL internal_message( 'error', routine_name // & 897 ': no dimensions defined in file. Cannot define variable '// & 898 '(variable "' // TRIM( variable_name ) // & 899 '", file "' // TRIM( file_name ) // '")!' ) 876 900 877 901 ENDIF … … 891 915 IF ( files(f)%variables(i)%name == variable%name ) THEN 892 916 return_value = 1 893 CALL internal_message( 'error', routine_name // &894 ': variable already exists '//&895 '(variable "' // TRIM( variable_name ) //&896 '", file "' // TRIM( file_name ) // '")!' )917 CALL internal_message( 'error', routine_name // & 918 ': variable already exists '// & 919 '(variable "' // TRIM( variable_name ) // & 920 '", file "' // TRIM( file_name ) // '")!' ) 897 921 EXIT 898 922 ENDIF … … 926 950 IF ( f > nfiles ) THEN 927 951 return_value = 1 928 CALL internal_message( 'error', routine_name // &929 ': file not found (variable "' // TRIM( variable_name ) // &952 CALL internal_message( 'error', routine_name // & 953 ': file not found (variable "' // TRIM( variable_name ) // & 930 954 '", file "' // TRIM( file_name ) // '")!' ) 931 955 ENDIF … … 961 985 RESULT( return_value ) 962 986 987 CHARACTER(LEN=*), INTENT(IN) :: attribute_name !< name of attribute 963 988 CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file 964 CHARACTER(LEN=*), INTENT(IN) :: attribute_name !< name of attribute965 989 CHARACTER(LEN=*), INTENT(IN) :: value !< attribute value 966 990 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: variable_name !< name of variable … … 995 1019 ENDIF 996 1020 997 return_value = save_attribute_in_database( file_name=TRIM( file_name ), &998 variable_name=TRIM( variable_name_internal ),&999 attribute=attribute, append=append_internal )1021 return_value = save_attribute_in_database( file_name=TRIM( file_name ), & 1022 variable_name=TRIM( variable_name_internal ), & 1023 attribute=attribute, append=append_internal ) 1000 1024 1001 1025 END FUNCTION dom_def_att_char … … 1020 1044 !> value=1_1 ) 1021 1045 !--------------------------------------------------------------------------------------------------! 1022 FUNCTION dom_def_att_int8( file_name, variable_name, attribute_name, value, append ) &1046 FUNCTION dom_def_att_int8( file_name, variable_name, attribute_name, value, append ) & 1023 1047 RESULT( return_value ) 1024 1048 1049 CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_att_int8' !< name of routine 1050 1051 CHARACTER(LEN=*), INTENT(IN) :: attribute_name !< name of attribute 1025 1052 CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file 1026 CHARACTER(LEN=*), INTENT(IN) :: attribute_name !< name of attribute1027 1053 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: variable_name !< name of variable 1028 1054 CHARACTER(LEN=charlen) :: variable_name_internal !< internal copy of variable_name 1029 1030 CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_att_int8' !< name of routine1031 1055 1032 1056 INTEGER(KIND=1), INTENT(IN) :: value !< attribute value … … 1051 1075 IF ( append ) THEN 1052 1076 return_value = 1 1053 CALL internal_message( 'error', routine_name // &1054 ': numeric attribute cannot be appended ' // &1055 '(attribute "' // TRIM( attribute_name ) // &1056 '", variable "' // TRIM( variable_name_internal ) // &1077 CALL internal_message( 'error', routine_name // & 1078 ': numeric attribute cannot be appended ' // & 1079 '(attribute "' // TRIM( attribute_name ) // & 1080 '", variable "' // TRIM( variable_name_internal ) // & 1057 1081 '", file "' // TRIM( file_name ) // '")!' ) 1058 1082 ENDIF … … 1066 1090 attribute%value_int8 = value 1067 1091 1068 return_value = save_attribute_in_database( file_name=TRIM( file_name ), &1069 variable_name=TRIM( variable_name_internal ),&1070 attribute=attribute, append=append_internal )1092 return_value = save_attribute_in_database( file_name=TRIM( file_name ), & 1093 variable_name=TRIM( variable_name_internal ), & 1094 attribute=attribute, append=append_internal ) 1071 1095 ENDIF 1072 1096 … … 1092 1116 !> value=1_2 ) 1093 1117 !--------------------------------------------------------------------------------------------------! 1094 FUNCTION dom_def_att_int16( file_name, variable_name, attribute_name, value, append ) &1118 FUNCTION dom_def_att_int16( file_name, variable_name, attribute_name, value, append ) & 1095 1119 RESULT( return_value ) 1096 1120 1121 CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_att_int16' !< name of routine 1122 1123 CHARACTER(LEN=*), INTENT(IN) :: attribute_name !< name of attribute 1097 1124 CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file 1098 CHARACTER(LEN=*), INTENT(IN) :: attribute_name !< name of attribute1099 1125 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: variable_name !< name of variable 1100 1126 CHARACTER(LEN=charlen) :: variable_name_internal !< internal copy of variable_name 1101 1102 CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_att_int16' !< name of routine1103 1127 1104 1128 INTEGER(KIND=2), INTENT(IN) :: value !< attribute value … … 1123 1147 IF ( append ) THEN 1124 1148 return_value = 1 1125 CALL internal_message( 'error', routine_name // &1126 ': numeric attribute cannot be appended ' // &1127 '(attribute "' // TRIM( attribute_name ) // &1128 '", variable "' // TRIM( variable_name_internal ) // &1149 CALL internal_message( 'error', routine_name // & 1150 ': numeric attribute cannot be appended ' // & 1151 '(attribute "' // TRIM( attribute_name ) // & 1152 '", variable "' // TRIM( variable_name_internal ) // & 1129 1153 '", file "' // TRIM( file_name ) // '")!' ) 1130 1154 ENDIF … … 1138 1162 attribute%value_int16 = value 1139 1163 1140 return_value = save_attribute_in_database( file_name=TRIM( file_name ), &1141 variable_name=TRIM( variable_name_internal ),&1142 attribute=attribute, append=append_internal )1164 return_value = save_attribute_in_database( file_name=TRIM( file_name ), & 1165 variable_name=TRIM( variable_name_internal ), & 1166 attribute=attribute, append=append_internal ) 1143 1167 ENDIF 1144 1168 … … 1164 1188 !> value=1_4 ) 1165 1189 !--------------------------------------------------------------------------------------------------! 1166 FUNCTION dom_def_att_int32( file_name, variable_name, attribute_name, value, append ) &1190 FUNCTION dom_def_att_int32( file_name, variable_name, attribute_name, value, append ) & 1167 1191 RESULT( return_value ) 1168 1192 1193 CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_att_int32' !< name of routine 1194 1195 1196 CHARACTER(LEN=*), INTENT(IN) :: attribute_name !< name of attribute 1169 1197 CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file 1170 CHARACTER(LEN=*), INTENT(IN) :: attribute_name !< name of attribute1171 1198 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: variable_name !< name of variable 1172 1199 CHARACTER(LEN=charlen) :: variable_name_internal !< internal copy of variable_name 1173 1174 CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_att_int32' !< name of routine1175 1200 1176 1201 INTEGER(KIND=4), INTENT(IN) :: value !< attribute value … … 1195 1220 IF ( append ) THEN 1196 1221 return_value = 1 1197 CALL internal_message( 'error', routine_name // &1198 ': numeric attribute cannot be appended ' // &1199 '(attribute "' // TRIM( attribute_name ) // &1200 '", variable "' // TRIM( variable_name_internal ) // &1222 CALL internal_message( 'error', routine_name // & 1223 ': numeric attribute cannot be appended ' // & 1224 '(attribute "' // TRIM( attribute_name ) // & 1225 '", variable "' // TRIM( variable_name_internal ) // & 1201 1226 '", file "' // TRIM( file_name ) // '")!' ) 1202 1227 ENDIF … … 1210 1235 attribute%value_int32 = value 1211 1236 1212 return_value = save_attribute_in_database( file_name=TRIM( file_name ), &1213 variable_name=TRIM( variable_name_internal ),&1214 attribute=attribute, append=append_internal )1237 return_value = save_attribute_in_database( file_name=TRIM( file_name ), & 1238 variable_name=TRIM( variable_name_internal ), & 1239 attribute=attribute, append=append_internal ) 1215 1240 ENDIF 1216 1241 … … 1236 1261 !> value=1.0_4 ) 1237 1262 !--------------------------------------------------------------------------------------------------! 1238 FUNCTION dom_def_att_real32( file_name, variable_name, attribute_name, value, append ) &1263 FUNCTION dom_def_att_real32( file_name, variable_name, attribute_name, value, append ) & 1239 1264 RESULT( return_value ) 1240 1265 1266 CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_att_real32' !< name of routine 1267 1268 CHARACTER(LEN=*), INTENT(IN) :: attribute_name !< name of attribute 1241 1269 CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file 1242 CHARACTER(LEN=*), INTENT(IN) :: attribute_name !< name of attribute1243 1270 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: variable_name !< name of variable 1244 1271 CHARACTER(LEN=charlen) :: variable_name_internal !< internal copy of variable_name 1245 1246 CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_att_real32' !< name of routine1247 1272 1248 1273 INTEGER :: return_value !< return value … … 1267 1292 IF ( append ) THEN 1268 1293 return_value = 1 1269 CALL internal_message( 'error', routine_name // &1270 ': numeric attribute cannot be appended ' // &1271 '(attribute "' // TRIM( attribute_name ) // &1272 '", variable "' // TRIM( variable_name_internal ) // &1294 CALL internal_message( 'error', routine_name // & 1295 ': numeric attribute cannot be appended ' // & 1296 '(attribute "' // TRIM( attribute_name ) // & 1297 '", variable "' // TRIM( variable_name_internal ) // & 1273 1298 '", file "' // TRIM( file_name ) // '")!' ) 1274 1299 ENDIF … … 1282 1307 attribute%value_real32 = value 1283 1308 1284 return_value = save_attribute_in_database( file_name=TRIM( file_name ), &1285 variable_name=TRIM( variable_name_internal ),&1286 attribute=attribute, append=append_internal )1309 return_value = save_attribute_in_database( file_name=TRIM( file_name ), & 1310 variable_name=TRIM( variable_name_internal ), & 1311 attribute=attribute, append=append_internal ) 1287 1312 ENDIF 1288 1313 … … 1308 1333 !> value=1.0_8 ) 1309 1334 !--------------------------------------------------------------------------------------------------! 1310 FUNCTION dom_def_att_real64( file_name, variable_name, attribute_name, value, append ) &1335 FUNCTION dom_def_att_real64( file_name, variable_name, attribute_name, value, append ) & 1311 1336 RESULT( return_value ) 1312 1337 1338 CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_att_real64' !< name of routine 1339 1340 CHARACTER(LEN=*), INTENT(IN) :: attribute_name !< name of attribute 1313 1341 CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file 1314 CHARACTER(LEN=*), INTENT(IN) :: attribute_name !< name of attribute1315 1342 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: variable_name !< name of variable 1316 1343 CHARACTER(LEN=charlen) :: variable_name_internal !< internal copy of variable_name 1317 1318 CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_att_real64' !< name of routine1319 1344 1320 1345 INTEGER :: return_value !< return value … … 1339 1364 IF ( append ) THEN 1340 1365 return_value = 1 1341 CALL internal_message( 'error', routine_name // &1342 ': numeric attribute cannot be appended ' // &1343 '(attribute "' // TRIM( attribute_name ) // &1344 '", variable "' // TRIM( variable_name_internal ) // &1366 CALL internal_message( 'error', routine_name // & 1367 ': numeric attribute cannot be appended ' // & 1368 '(attribute "' // TRIM( attribute_name ) // & 1369 '", variable "' // TRIM( variable_name_internal ) // & 1345 1370 '", file "' // TRIM( file_name ) // '")!' ) 1346 1371 ENDIF … … 1354 1379 attribute%value_real64 = value 1355 1380 1356 return_value = save_attribute_in_database( file_name=TRIM( file_name ), &1357 variable_name=TRIM( variable_name_internal ),&1358 attribute=attribute, append=append_internal )1381 return_value = save_attribute_in_database( file_name=TRIM( file_name ), & 1382 variable_name=TRIM( variable_name_internal ), & 1383 attribute=attribute, append=append_internal ) 1359 1384 ENDIF 1360 1385 … … 1408 1433 IF ( files(f)%is_init ) CYCLE 1409 1434 1410 CALL internal_message( 'debug', routine_name // ': initialize file "' // &1435 CALL internal_message( 'debug', routine_name // ': initialize file "' // & 1411 1436 TRIM( files(f)%name ) // '"' ) 1412 1437 ! 1413 1438 !-- Open file 1414 CALL open_output_file( files(f)%format, files(f)%name, files(f)%id, &1439 CALL open_output_file( files(f)%format, files(f)%name, files(f)%id, & 1415 1440 return_value=return_value ) 1416 1441 ! 1417 1442 !-- Initialize file header: 1418 1443 !-- define dimensions and variables and write attributes 1419 IF ( return_value == 0 ) & 1420 CALL init_file_header( files(f), return_value=return_value ) 1444 IF ( return_value == 0 ) CALL init_file_header( files(f), return_value=return_value ) 1421 1445 ! 1422 1446 !-- End file definition 1423 IF ( return_value == 0 ) &1424 CALL stop_file_header_definition( files(f)%format, files(f)%id, &1425 files(f)%name,return_value )1447 IF ( return_value == 0 ) & 1448 CALL stop_file_header_definition( files(f)%format, files(f)%id, files(f)%name, & 1449 return_value ) 1426 1450 1427 1451 IF ( return_value == 0 ) THEN … … 1433 1457 DO d = 1, SIZE( files(f)%dimensions ) 1434 1458 IF ( ALLOCATED( files(f)%dimensions(d)%values_int8 ) ) THEN 1435 ALLOCATE( values_int8(files(f)%dimensions(d)%bounds(1): &1459 ALLOCATE( values_int8(files(f)%dimensions(d)%bounds(1): & 1436 1460 files(f)%dimensions(d)%bounds(2)) ) 1437 1461 values_int8 = files(f)%dimensions(d)%values_int8 1438 1462 values_int8_pointer => values_int8 1439 return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, &1440 bounds_start=(/ files(f)%dimensions(d)%bounds(1) /), &1441 bounds_end =(/ files(f)%dimensions(d)%bounds(2) /), &1463 return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, & 1464 bounds_start=(/ files(f)%dimensions(d)%bounds(1) /), & 1465 bounds_end =(/ files(f)%dimensions(d)%bounds(2) /), & 1442 1466 values_int8_1d=values_int8_pointer ) 1443 1467 DEALLOCATE( values_int8 ) 1444 1468 ELSEIF ( ALLOCATED( files(f)%dimensions(d)%values_int16 ) ) THEN 1445 ALLOCATE( values_int16(files(f)%dimensions(d)%bounds(1): &1469 ALLOCATE( values_int16(files(f)%dimensions(d)%bounds(1): & 1446 1470 files(f)%dimensions(d)%bounds(2)) ) 1447 1471 values_int16 = files(f)%dimensions(d)%values_int16 1448 1472 values_int16_pointer => values_int16 1449 return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, &1450 bounds_start=(/ files(f)%dimensions(d)%bounds(1) /), &1451 bounds_end =(/ files(f)%dimensions(d)%bounds(2) /), &1473 return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, & 1474 bounds_start=(/ files(f)%dimensions(d)%bounds(1) /), & 1475 bounds_end =(/ files(f)%dimensions(d)%bounds(2) /), & 1452 1476 values_int16_1d=values_int16_pointer ) 1453 1477 DEALLOCATE( values_int16 ) 1454 1478 ELSEIF ( ALLOCATED( files(f)%dimensions(d)%values_int32 ) ) THEN 1455 ALLOCATE( values_int32(files(f)%dimensions(d)%bounds(1): &1479 ALLOCATE( values_int32(files(f)%dimensions(d)%bounds(1): & 1456 1480 files(f)%dimensions(d)%bounds(2)) ) 1457 1481 values_int32 = files(f)%dimensions(d)%values_int32 1458 1482 values_int32_pointer => values_int32 1459 return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, &1460 bounds_start=(/ files(f)%dimensions(d)%bounds(1) /), &1461 bounds_end =(/ files(f)%dimensions(d)%bounds(2) /), &1483 return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, & 1484 bounds_start=(/ files(f)%dimensions(d)%bounds(1) /), & 1485 bounds_end =(/ files(f)%dimensions(d)%bounds(2) /), & 1462 1486 values_int32_1d=values_int32_pointer ) 1463 1487 DEALLOCATE( values_int32 ) 1464 1488 ELSEIF ( ALLOCATED( files(f)%dimensions(d)%values_intwp ) ) THEN 1465 ALLOCATE( values_intwp(files(f)%dimensions(d)%bounds(1): &1489 ALLOCATE( values_intwp(files(f)%dimensions(d)%bounds(1): & 1466 1490 files(f)%dimensions(d)%bounds(2)) ) 1467 1491 values_intwp = files(f)%dimensions(d)%values_intwp 1468 1492 values_intwp_pointer => values_intwp 1469 return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, &1470 bounds_start=(/ files(f)%dimensions(d)%bounds(1) /), &1471 bounds_end =(/ files(f)%dimensions(d)%bounds(2) /), &1493 return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, & 1494 bounds_start=(/ files(f)%dimensions(d)%bounds(1) /), & 1495 bounds_end =(/ files(f)%dimensions(d)%bounds(2) /), & 1472 1496 values_intwp_1d=values_intwp_pointer ) 1473 1497 DEALLOCATE( values_intwp ) 1474 1498 ELSEIF ( ALLOCATED( files(f)%dimensions(d)%values_real32 ) ) THEN 1475 ALLOCATE( values_real32(files(f)%dimensions(d)%bounds(1): &1499 ALLOCATE( values_real32(files(f)%dimensions(d)%bounds(1): & 1476 1500 files(f)%dimensions(d)%bounds(2)) ) 1477 1501 values_real32 = files(f)%dimensions(d)%values_real32 1478 1502 values_real32_pointer => values_real32 1479 return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, &1480 bounds_start=(/ files(f)%dimensions(d)%bounds(1) /), &1481 bounds_end =(/ files(f)%dimensions(d)%bounds(2) /), &1503 return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, & 1504 bounds_start=(/ files(f)%dimensions(d)%bounds(1) /), & 1505 bounds_end =(/ files(f)%dimensions(d)%bounds(2) /), & 1482 1506 values_real32_1d=values_real32_pointer ) 1483 1507 DEALLOCATE( values_real32 ) 1484 1508 ELSEIF ( ALLOCATED( files(f)%dimensions(d)%values_real64 ) ) THEN 1485 ALLOCATE( values_real64(files(f)%dimensions(d)%bounds(1): &1509 ALLOCATE( values_real64(files(f)%dimensions(d)%bounds(1): & 1486 1510 files(f)%dimensions(d)%bounds(2)) ) 1487 1511 values_real64 = files(f)%dimensions(d)%values_real64 1488 1512 values_real64_pointer => values_real64 1489 return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, &1490 bounds_start=(/ files(f)%dimensions(d)%bounds(1) /), &1491 bounds_end =(/ files(f)%dimensions(d)%bounds(2) /), &1513 return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, & 1514 bounds_start=(/ files(f)%dimensions(d)%bounds(1) /), & 1515 bounds_end =(/ files(f)%dimensions(d)%bounds(2) /), & 1492 1516 values_real64_1d=values_real64_pointer ) 1493 1517 DEALLOCATE( values_real64 ) 1494 1518 ELSEIF ( ALLOCATED( files(f)%dimensions(d)%values_realwp ) ) THEN 1495 ALLOCATE( values_realwp(files(f)%dimensions(d)%bounds(1): &1519 ALLOCATE( values_realwp(files(f)%dimensions(d)%bounds(1): & 1496 1520 files(f)%dimensions(d)%bounds(2)) ) 1497 1521 values_realwp = files(f)%dimensions(d)%values_realwp 1498 1522 values_realwp_pointer => values_realwp 1499 return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, &1500 bounds_start=(/ files(f)%dimensions(d)%bounds(1) /), &1501 bounds_end =(/ files(f)%dimensions(d)%bounds(2) /), &1523 return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, & 1524 bounds_start=(/ files(f)%dimensions(d)%bounds(1) /), & 1525 bounds_end =(/ files(f)%dimensions(d)%bounds(2) /), & 1502 1526 values_realwp_1d=values_realwp_pointer ) 1503 1527 DEALLOCATE( values_realwp ) … … 1538 1562 !> chosen, the values are written to file as given in the 'dom_write_var' call. 1539 1563 !--------------------------------------------------------------------------------------------------! 1540 FUNCTION dom_write_var( file_name, variable_name, bounds_start, bounds_end, &1541 values_char_0d, values_char_1d, values_char_2d, values_char_3d, &1542 values_int8_0d, values_int8_1d, values_int8_2d, values_int8_3d, &1543 values_int16_0d, values_int16_1d, values_int16_2d, values_int16_3d, &1544 values_int32_0d, values_int32_1d, values_int32_2d, values_int32_3d, &1545 values_intwp_0d, values_intwp_1d, values_intwp_2d, values_intwp_3d, &1546 values_real32_0d, values_real32_1d, values_real32_2d, values_real32_3d, &1547 values_real64_0d, values_real64_1d, values_real64_2d, values_real64_3d, &1548 values_realwp_0d, values_realwp_1d, values_realwp_2d, values_realwp_3d &1564 FUNCTION dom_write_var( file_name, variable_name, bounds_start, bounds_end, & 1565 values_char_0d, values_char_1d, values_char_2d, values_char_3d, & 1566 values_int8_0d, values_int8_1d, values_int8_2d, values_int8_3d, & 1567 values_int16_0d, values_int16_1d, values_int16_2d, values_int16_3d, & 1568 values_int32_0d, values_int32_1d, values_int32_2d, values_int32_3d, & 1569 values_intwp_0d, values_intwp_1d, values_intwp_2d, values_intwp_3d, & 1570 values_real32_0d, values_real32_1d, values_real32_2d, values_real32_3d, & 1571 values_real64_0d, values_real64_1d, values_real64_2d, values_real64_3d, & 1572 values_realwp_0d, values_realwp_1d, values_realwp_2d, values_realwp_3d & 1549 1573 ) RESULT( return_value ) 1574 1575 CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_write_var' !< name of routine 1550 1576 1551 1577 CHARACTER(LEN=charlen) :: file_format !< file format chosen for file 1552 1578 CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file 1553 1579 CHARACTER(LEN=*), INTENT(IN) :: variable_name !< name of variable 1554 1555 CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_write_var' !< name of routine1556 1580 1557 1581 CHARACTER(LEN=1), POINTER, INTENT(IN), OPTIONAL :: values_char_0d !< output variable … … 1579 1603 INTEGER, DIMENSION(:), INTENT(IN) :: bounds_end !< end index per dimension of variable 1580 1604 INTEGER, DIMENSION(:), INTENT(IN) :: bounds_start !< start index per dimension of variable 1605 1581 1606 INTEGER, DIMENSION(:), ALLOCATABLE :: bounds_origin !< first index of each dimension 1582 1607 INTEGER, DIMENSION(:), ALLOCATABLE :: bounds_start_internal !< start index per dim. for output after masking … … 1604 1629 INTEGER(iwp), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: values_intwp_3d !< output variable 1605 1630 1606 INTEGER(KIND=1), TARGET, ALLOCATABLE, DIMENSION(:) :: values_int8_1d_resorted !< resorted output variable1607 INTEGER(KIND=2), TARGET, ALLOCATABLE, DIMENSION(:) :: values_int16_1d_resorted !< resorted output variable1608 INTEGER(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:) :: values_int32_1d_resorted !< resorted output variable1609 INTEGER(iwp), TARGET, ALLOCATABLE, DIMENSION(:) :: values_intwp_1d_resorted !< resorted output variable1610 INTEGER(KIND=1), TARGET, ALLOCATABLE, DIMENSION(:,:) :: values_int8_2d_resorted !< resorted output variable1611 INTEGER(KIND=2), TARGET, ALLOCATABLE, DIMENSION(:,:) :: values_int16_2d_resorted !< resorted output variable1612 INTEGER(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:,:) :: values_int32_2d_resorted !< resorted output variable1613 INTEGER(iwp), TARGET, ALLOCATABLE, DIMENSION(:,:) :: values_intwp_2d_resorted !< resorted output variable1614 INTEGER(KIND=1), TARGET, ALLOCATABLE, DIMENSION(:,:,:) :: values_int8_3d_resorted !< resorted output variable1615 INTEGER(KIND=2), TARGET, ALLOCATABLE, DIMENSION(:,:,:) :: values_int16_3d_resorted !< resorted output variable1616 INTEGER(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:,:,:) :: values_int32_3d_resorted !< resorted output variable1617 INTEGER(iwp), TARGET, ALLOCATABLE, DIMENSION(:,:,:) :: values_intwp_3d_resorted !< resorted output variable1618 1619 1631 INTEGER(KIND=1), POINTER :: values_int8_0d_pointer !< pointer to resortet array 1620 1632 INTEGER(KIND=2), POINTER :: values_int16_0d_pointer !< pointer to resortet array … … 1634 1646 INTEGER(iwp), POINTER, CONTIGUOUS, DIMENSION(:,:,:) :: values_intwp_3d_pointer !< pointer to resortet array 1635 1647 1648 INTEGER(KIND=1), TARGET, ALLOCATABLE, DIMENSION(:) :: values_int8_1d_resorted !< resorted output variable 1649 INTEGER(KIND=2), TARGET, ALLOCATABLE, DIMENSION(:) :: values_int16_1d_resorted !< resorted output variable 1650 INTEGER(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:) :: values_int32_1d_resorted !< resorted output variable 1651 INTEGER(iwp), TARGET, ALLOCATABLE, DIMENSION(:) :: values_intwp_1d_resorted !< resorted output variable 1652 INTEGER(KIND=1), TARGET, ALLOCATABLE, DIMENSION(:,:) :: values_int8_2d_resorted !< resorted output variable 1653 INTEGER(KIND=2), TARGET, ALLOCATABLE, DIMENSION(:,:) :: values_int16_2d_resorted !< resorted output variable 1654 INTEGER(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:,:) :: values_int32_2d_resorted !< resorted output variable 1655 INTEGER(iwp), TARGET, ALLOCATABLE, DIMENSION(:,:) :: values_intwp_2d_resorted !< resorted output variable 1656 INTEGER(KIND=1), TARGET, ALLOCATABLE, DIMENSION(:,:,:) :: values_int8_3d_resorted !< resorted output variable 1657 INTEGER(KIND=2), TARGET, ALLOCATABLE, DIMENSION(:,:,:) :: values_int16_3d_resorted !< resorted output variable 1658 INTEGER(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:,:,:) :: values_int32_3d_resorted !< resorted output variable 1659 INTEGER(iwp), TARGET, ALLOCATABLE, DIMENSION(:,:,:) :: values_intwp_3d_resorted !< resorted output variable 1660 1636 1661 REAL(KIND=4), POINTER, INTENT(IN), OPTIONAL :: values_real32_0d !< output variable 1637 1662 REAL(KIND=8), POINTER, INTENT(IN), OPTIONAL :: values_real64_0d !< output variable … … 1647 1672 REAL(wp), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: values_realwp_3d !< output variable 1648 1673 1649 REAL(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:) :: values_real32_1d_resorted !< resorted output variable1650 REAL(KIND=8), TARGET, ALLOCATABLE, DIMENSION(:) :: values_real64_1d_resorted !< resorted output variable1651 REAL(wp), TARGET, ALLOCATABLE, DIMENSION(:) :: values_realwp_1d_resorted !< resorted output variable1652 REAL(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:,:) :: values_real32_2d_resorted !< resorted output variable1653 REAL(KIND=8), TARGET, ALLOCATABLE, DIMENSION(:,:) :: values_real64_2d_resorted !< resorted output variable1654 REAL(wp), TARGET, ALLOCATABLE, DIMENSION(:,:) :: values_realwp_2d_resorted !< resorted output variable1655 REAL(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:,:,:) :: values_real32_3d_resorted !< resorted output variable1656 REAL(KIND=8), TARGET, ALLOCATABLE, DIMENSION(:,:,:) :: values_real64_3d_resorted !< resorted output variable1657 REAL(wp), TARGET, ALLOCATABLE, DIMENSION(:,:,:) :: values_realwp_3d_resorted !< resorted output variable1658 1659 1674 REAL(KIND=4), POINTER :: values_real32_0d_pointer !< pointer to resortet array 1660 1675 REAL(KIND=8), POINTER :: values_real64_0d_pointer !< pointer to resortet array … … 1670 1685 REAL(wp), POINTER, CONTIGUOUS, DIMENSION(:,:,:) :: values_realwp_3d_pointer !< pointer to resortet array 1671 1686 1687 REAL(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:) :: values_real32_1d_resorted !< resorted output variable 1688 REAL(KIND=8), TARGET, ALLOCATABLE, DIMENSION(:) :: values_real64_1d_resorted !< resorted output variable 1689 REAL(wp), TARGET, ALLOCATABLE, DIMENSION(:) :: values_realwp_1d_resorted !< resorted output variable 1690 REAL(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:,:) :: values_real32_2d_resorted !< resorted output variable 1691 REAL(KIND=8), TARGET, ALLOCATABLE, DIMENSION(:,:) :: values_real64_2d_resorted !< resorted output variable 1692 REAL(wp), TARGET, ALLOCATABLE, DIMENSION(:,:) :: values_realwp_2d_resorted !< resorted output variable 1693 REAL(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:,:,:) :: values_real32_3d_resorted !< resorted output variable 1694 REAL(KIND=8), TARGET, ALLOCATABLE, DIMENSION(:,:,:) :: values_real64_3d_resorted !< resorted output variable 1695 REAL(wp), TARGET, ALLOCATABLE, DIMENSION(:,:,:) :: values_realwp_3d_resorted !< resorted output variable 1696 1672 1697 TYPE(dimension_type), DIMENSION(:), ALLOCATABLE :: dimension_list !< list of used dimensions of variable 1673 1698 … … 1676 1701 output_return_value = 0 1677 1702 1678 CALL internal_message( 'debug', routine_name // ': write ' // TRIM( variable_name ) // &1703 CALL internal_message( 'debug', routine_name // ': write ' // TRIM( variable_name ) // & 1679 1704 ' into file ' // TRIM( file_name ) ) 1680 1705 ! 1681 1706 !-- Search for variable within file 1682 CALL find_var_in_file( file_name, variable_name, file_format, file_id, variable_id, &1707 CALL find_var_in_file( file_name, variable_name, file_format, file_id, variable_id, & 1683 1708 is_global, dimension_list, return_value=return_value ) 1684 1709 … … 1686 1711 ! 1687 1712 !-- Check if the correct amount of variable bounds were given 1688 IF ( SIZE( bounds_start ) /= SIZE( dimension_list ) .OR. &1689 SIZE( bounds_end ) /= SIZE( dimension_list ) ) THEN1713 IF ( SIZE( bounds_start ) /= SIZE( dimension_list ) .OR. & 1714 SIZE( bounds_end ) /= SIZE( dimension_list ) ) THEN 1690 1715 return_value = 1 1691 CALL internal_message( 'error', routine_name // &1692 ': number bounds do not match with ' // &1693 'number of dimensions of variable ' // &1694 '(variable "' // TRIM( variable_name ) // &1716 CALL internal_message( 'error', routine_name // & 1717 ': number bounds do not match with ' // & 1718 'number of dimensions of variable ' // & 1719 '(variable "' // TRIM( variable_name ) // & 1695 1720 '", file "' // TRIM( file_name ) // '")!' ) 1696 1721 ENDIF … … 1706 1731 1707 1732 WRITE( temp_string, * ) bounds_start 1708 CALL internal_message( 'debug', routine_name // &1709 ': file "' // TRIM( file_name ) // &1710 '", variable "' // TRIM( variable_name ) // &1733 CALL internal_message( 'debug', routine_name // & 1734 ': file "' // TRIM( file_name ) // & 1735 '", variable "' // TRIM( variable_name ) // & 1711 1736 '", bounds_start =' // TRIM( temp_string ) ) 1712 1737 WRITE( temp_string, * ) bounds_end 1713 CALL internal_message( 'debug', routine_name // &1714 ': file "' // TRIM( file_name ) // &1715 '", variable "' // TRIM( variable_name ) // &1738 CALL internal_message( 'debug', routine_name // & 1739 ': file "' // TRIM( file_name ) // & 1740 '", variable "' // TRIM( variable_name ) // & 1716 1741 '", bounds_end =' // TRIM( temp_string ) ) 1717 1742 ! 1718 1743 !-- Get bounds for masking 1719 CALL get_masked_indices_and_masked_dimension_bounds( dimension_list, & 1720 bounds_start, bounds_end, bounds_start_internal, value_counts, bounds_origin, & 1721 masked_indices ) 1744 CALL get_masked_indices_and_masked_dimension_bounds( dimension_list, bounds_start, & 1745 bounds_end, bounds_start_internal, value_counts, bounds_origin, masked_indices ) 1722 1746 1723 1747 do_output = .NOT. ANY( value_counts == 0 ) 1724 1748 1725 1749 WRITE( temp_string, * ) bounds_start_internal 1726 CALL internal_message( 'debug', routine_name // &1727 ': file "' // TRIM( file_name ) // &1728 '", variable "' // TRIM( variable_name ) // &1750 CALL internal_message( 'debug', routine_name // & 1751 ': file "' // TRIM( file_name ) // & 1752 '", variable "' // TRIM( variable_name ) // & 1729 1753 '", bounds_start_internal =' // TRIM( temp_string ) ) 1730 1754 WRITE( temp_string, * ) value_counts 1731 CALL internal_message( 'debug', routine_name // &1732 ': file "' // TRIM( file_name ) // &1733 '", variable "' // TRIM( variable_name ) // &1755 CALL internal_message( 'debug', routine_name // & 1756 ': file "' // TRIM( file_name ) // & 1757 '", variable "' // TRIM( variable_name ) // & 1734 1758 '", value_counts =' // TRIM( temp_string ) ) 1735 1759 ! … … 1754 1778 ELSEIF ( PRESENT( values_char_2d ) ) THEN 1755 1779 IF ( do_output ) THEN 1756 ALLOCATE( values_char_2d_resorted(0:value_counts(1)-1, & 1757 0:value_counts(2)-1) ) 1780 ALLOCATE( values_char_2d_resorted(0:value_counts(1)-1,0:value_counts(2)-1) ) 1758 1781 !$OMP PARALLEL PRIVATE (i,j) 1759 1782 !$OMP DO 1760 1783 DO i = 0, value_counts(1) - 1 1761 1784 DO j = 0, value_counts(2) - 1 1762 values_char_2d_resorted(i,j) = values_char_2d(masked_indices(2,j), &1763 masked_indices(1,i) 1785 values_char_2d_resorted(i,j) = values_char_2d(masked_indices(2,j), & 1786 masked_indices(1,i)) 1764 1787 ENDDO 1765 1788 ENDDO … … 1772 1795 ELSEIF ( PRESENT( values_char_3d ) ) THEN 1773 1796 IF ( do_output ) THEN 1774 ALLOCATE( values_char_3d_resorted(0:value_counts(1)-1, &1775 0:value_counts(2)-1, &1797 ALLOCATE( values_char_3d_resorted(0:value_counts(1)-1, & 1798 0:value_counts(2)-1, & 1776 1799 0:value_counts(3)-1) ) 1777 1800 !$OMP PARALLEL PRIVATE (i,j,k) … … 1780 1803 DO j = 0, value_counts(2) - 1 1781 1804 DO k = 0, value_counts(3) - 1 1782 values_char_3d_resorted(i,j,k) = values_char_3d(masked_indices(3,k), &1783 masked_indices(2,j), &1784 masked_indices(1,i) 1805 values_char_3d_resorted(i,j,k) = values_char_3d(masked_indices(3,k), & 1806 masked_indices(2,j), & 1807 masked_indices(1,i)) 1785 1808 ENDDO 1786 1809 ENDDO … … 1812 1835 ELSEIF ( PRESENT( values_int8_2d ) ) THEN 1813 1836 IF ( do_output ) THEN 1814 ALLOCATE( values_int8_2d_resorted(0:value_counts(1)-1, & 1815 0:value_counts(2)-1) ) 1837 ALLOCATE( values_int8_2d_resorted(0:value_counts(1)-1,0:value_counts(2)-1) ) 1816 1838 !$OMP PARALLEL PRIVATE (i,j) 1817 1839 !$OMP DO 1818 1840 DO i = 0, value_counts(1) - 1 1819 1841 DO j = 0, value_counts(2) - 1 1820 values_int8_2d_resorted(i,j) = values_int8_2d(masked_indices(2,j), &1821 masked_indices(1,i) 1842 values_int8_2d_resorted(i,j) = values_int8_2d(masked_indices(2,j), & 1843 masked_indices(1,i)) 1822 1844 ENDDO 1823 1845 ENDDO … … 1830 1852 ELSEIF ( PRESENT( values_int8_3d ) ) THEN 1831 1853 IF ( do_output ) THEN 1832 ALLOCATE( values_int8_3d_resorted(0:value_counts(1)-1, &1833 0:value_counts(2)-1, &1854 ALLOCATE( values_int8_3d_resorted(0:value_counts(1)-1, & 1855 0:value_counts(2)-1, & 1834 1856 0:value_counts(3)-1) ) 1835 1857 !$OMP PARALLEL PRIVATE (i,j,k) … … 1838 1860 DO j = 0, value_counts(2) - 1 1839 1861 DO k = 0, value_counts(3) - 1 1840 values_int8_3d_resorted(i,j,k) = values_int8_3d(masked_indices(3,k), &1841 masked_indices(2,j), &1862 values_int8_3d_resorted(i,j,k) = values_int8_3d(masked_indices(3,k), & 1863 masked_indices(2,j), & 1842 1864 masked_indices(1,i) ) 1843 1865 ENDDO … … 1870 1892 ELSEIF ( PRESENT( values_int16_2d ) ) THEN 1871 1893 IF ( do_output ) THEN 1872 ALLOCATE( values_int16_2d_resorted(0:value_counts(1)-1, & 1873 0:value_counts(2)-1) ) 1894 ALLOCATE( values_int16_2d_resorted(0:value_counts(1)-1,0:value_counts(2)-1) ) 1874 1895 !$OMP PARALLEL PRIVATE (i,j) 1875 1896 !$OMP DO 1876 1897 DO i = 0, value_counts(1) - 1 1877 1898 DO j = 0, value_counts(2) - 1 1878 values_int16_2d_resorted(i,j) = values_int16_2d(masked_indices(2,j), &1899 values_int16_2d_resorted(i,j) = values_int16_2d(masked_indices(2,j), & 1879 1900 masked_indices(1,i)) 1880 1901 ENDDO … … 1888 1909 ELSEIF ( PRESENT( values_int16_3d ) ) THEN 1889 1910 IF ( do_output ) THEN 1890 ALLOCATE( values_int16_3d_resorted(0:value_counts(1)-1, &1891 0:value_counts(2)-1, &1911 ALLOCATE( values_int16_3d_resorted(0:value_counts(1)-1, & 1912 0:value_counts(2)-1, & 1892 1913 0:value_counts(3)-1) ) 1893 1914 !$OMP PARALLEL PRIVATE (i,j,k) … … 1896 1917 DO j = 0, value_counts(2) - 1 1897 1918 DO k = 0, value_counts(3) - 1 1898 values_int16_3d_resorted(i,j,k) = values_int16_3d(masked_indices(3,k), &1899 masked_indices(2,j), &1900 masked_indices(1,i) 1919 values_int16_3d_resorted(i,j,k) = values_int16_3d(masked_indices(3,k), & 1920 masked_indices(2,j), & 1921 masked_indices(1,i)) 1901 1922 ENDDO 1902 1923 ENDDO … … 1928 1949 ELSEIF ( PRESENT( values_int32_2d ) ) THEN 1929 1950 IF ( do_output ) THEN 1930 ALLOCATE( values_int32_2d_resorted(0:value_counts(1)-1, & 1931 0:value_counts(2)-1) ) 1951 ALLOCATE( values_int32_2d_resorted(0:value_counts(1)-1,0:value_counts(2)-1) ) 1932 1952 !$OMP PARALLEL PRIVATE (i,j) 1933 1953 !$OMP DO 1934 1954 DO i = 0, value_counts(1) - 1 1935 1955 DO j = 0, value_counts(2) - 1 1936 values_int32_2d_resorted(i,j) = values_int32_2d(masked_indices(2,j), &1937 masked_indices(1,i) 1956 values_int32_2d_resorted(i,j) = values_int32_2d(masked_indices(2,j), & 1957 masked_indices(1,i)) 1938 1958 ENDDO 1939 1959 ENDDO … … 1946 1966 ELSEIF ( PRESENT( values_int32_3d ) ) THEN 1947 1967 IF ( do_output ) THEN 1948 ALLOCATE( values_int32_3d_resorted(0:value_counts(1)-1, &1949 0:value_counts(2)-1, &1968 ALLOCATE( values_int32_3d_resorted(0:value_counts(1)-1, & 1969 0:value_counts(2)-1, & 1950 1970 0:value_counts(3)-1) ) 1951 1971 !$OMP PARALLEL PRIVATE (i,j,k) … … 1954 1974 DO j = 0, value_counts(2) - 1 1955 1975 DO k = 0, value_counts(3) - 1 1956 values_int32_3d_resorted(i,j,k) = values_int32_3d(masked_indices(3,k), &1957 masked_indices(2,j), &1958 masked_indices(1,i) 1976 values_int32_3d_resorted(i,j,k) = values_int32_3d(masked_indices(3,k), & 1977 masked_indices(2,j), & 1978 masked_indices(1,i)) 1959 1979 ENDDO 1960 1980 ENDDO … … 1967 1987 values_int32_3d_pointer => values_int32_3d_resorted 1968 1988 ! 1969 !-- working-precision integer output1989 !-- Working-precision integer output 1970 1990 ELSEIF ( PRESENT( values_intwp_0d ) ) THEN 1971 1991 values_intwp_0d_pointer => values_intwp_0d … … 1986 2006 ELSEIF ( PRESENT( values_intwp_2d ) ) THEN 1987 2007 IF ( do_output ) THEN 1988 ALLOCATE( values_intwp_2d_resorted(0:value_counts(1)-1, & 1989 0:value_counts(2)-1) ) 2008 ALLOCATE( values_intwp_2d_resorted(0:value_counts(1)-1,0:value_counts(2)-1) ) 1990 2009 !$OMP PARALLEL PRIVATE (i,j) 1991 2010 !$OMP DO 1992 2011 DO i = 0, value_counts(1) - 1 1993 2012 DO j = 0, value_counts(2) - 1 1994 values_intwp_2d_resorted(i,j) = values_intwp_2d(masked_indices(2,j), &1995 masked_indices(1,i) 2013 values_intwp_2d_resorted(i,j) = values_intwp_2d(masked_indices(2,j), & 2014 masked_indices(1,i)) 1996 2015 ENDDO 1997 2016 ENDDO … … 2004 2023 ELSEIF ( PRESENT( values_intwp_3d ) ) THEN 2005 2024 IF ( do_output ) THEN 2006 ALLOCATE( values_intwp_3d_resorted(0:value_counts(1)-1, &2007 0:value_counts(2)-1, &2025 ALLOCATE( values_intwp_3d_resorted(0:value_counts(1)-1, & 2026 0:value_counts(2)-1, & 2008 2027 0:value_counts(3)-1) ) 2009 2028 !$OMP PARALLEL PRIVATE (i,j,k) … … 2012 2031 DO j = 0, value_counts(2) - 1 2013 2032 DO k = 0, value_counts(3) - 1 2014 values_intwp_3d_resorted(i,j,k) = values_intwp_3d(masked_indices(3,k), &2015 masked_indices(2,j), &2016 masked_indices(1,i) 2033 values_intwp_3d_resorted(i,j,k) = values_intwp_3d(masked_indices(3,k), & 2034 masked_indices(2,j), & 2035 masked_indices(1,i)) 2017 2036 ENDDO 2018 2037 ENDDO … … 2044 2063 ELSEIF ( PRESENT( values_real32_2d ) ) THEN 2045 2064 IF ( do_output ) THEN 2046 ALLOCATE( values_real32_2d_resorted(0:value_counts(1)-1, & 2047 0:value_counts(2)-1) ) 2065 ALLOCATE( values_real32_2d_resorted(0:value_counts(1)-1,0:value_counts(2)-1) ) 2048 2066 !$OMP PARALLEL PRIVATE (i,j) 2049 2067 !$OMP DO 2050 2068 DO i = 0, value_counts(1) - 1 2051 2069 DO j = 0, value_counts(2) - 1 2052 values_real32_2d_resorted(i,j) = values_real32_2d(masked_indices(2,j), &2053 masked_indices(1,i) 2070 values_real32_2d_resorted(i,j) = values_real32_2d(masked_indices(2,j), & 2071 masked_indices(1,i)) 2054 2072 ENDDO 2055 2073 ENDDO … … 2062 2080 ELSEIF ( PRESENT( values_real32_3d ) ) THEN 2063 2081 IF ( do_output ) THEN 2064 ALLOCATE( values_real32_3d_resorted(0:value_counts(1)-1, &2065 0:value_counts(2)-1, &2082 ALLOCATE( values_real32_3d_resorted(0:value_counts(1)-1, & 2083 0:value_counts(2)-1, & 2066 2084 0:value_counts(3)-1) ) 2067 2085 !$OMP PARALLEL PRIVATE (i,j,k) … … 2070 2088 DO j = 0, value_counts(2) - 1 2071 2089 DO k = 0, value_counts(3) - 1 2072 values_real32_3d_resorted(i,j,k) = values_real32_3d(masked_indices(3,k), &2073 masked_indices(2,j), &2074 masked_indices(1,i) 2090 values_real32_3d_resorted(i,j,k) = values_real32_3d(masked_indices(3,k), & 2091 masked_indices(2,j), & 2092 masked_indices(1,i)) 2075 2093 ENDDO 2076 2094 ENDDO … … 2102 2120 ELSEIF ( PRESENT( values_real64_2d ) ) THEN 2103 2121 IF ( do_output ) THEN 2104 ALLOCATE( values_real64_2d_resorted(0:value_counts(1)-1, & 2105 0:value_counts(2)-1) ) 2122 ALLOCATE( values_real64_2d_resorted(0:value_counts(1)-1,0:value_counts(2)-1) ) 2106 2123 !$OMP PARALLEL PRIVATE (i,j) 2107 2124 !$OMP DO 2108 2125 DO i = 0, value_counts(1) - 1 2109 2126 DO j = 0, value_counts(2) - 1 2110 values_real64_2d_resorted(i,j) = values_real64_2d(masked_indices(2,j), &2111 masked_indices(1,i) 2127 values_real64_2d_resorted(i,j) = values_real64_2d(masked_indices(2,j), & 2128 masked_indices(1,i)) 2112 2129 ENDDO 2113 2130 ENDDO … … 2120 2137 ELSEIF ( PRESENT( values_real64_3d ) ) THEN 2121 2138 IF ( do_output ) THEN 2122 ALLOCATE( values_real64_3d_resorted(0:value_counts(1)-1, &2123 0:value_counts(2)-1, &2139 ALLOCATE( values_real64_3d_resorted(0:value_counts(1)-1, & 2140 0:value_counts(2)-1, & 2124 2141 0:value_counts(3)-1) ) 2125 2142 !$OMP PARALLEL PRIVATE (i,j,k) … … 2128 2145 DO j = 0, value_counts(2) - 1 2129 2146 DO k = 0, value_counts(3) - 1 2130 values_real64_3d_resorted(i,j,k) = values_real64_3d(masked_indices(3,k), &2131 masked_indices(2,j), &2132 masked_indices(1,i) 2147 values_real64_3d_resorted(i,j,k) = values_real64_3d(masked_indices(3,k), & 2148 masked_indices(2,j), & 2149 masked_indices(1,i)) 2133 2150 ENDDO 2134 2151 ENDDO … … 2141 2158 values_real64_3d_pointer => values_real64_3d_resorted 2142 2159 ! 2143 !-- working-precision real output2160 !-- Working-precision real output 2144 2161 ELSEIF ( PRESENT( values_realwp_0d ) ) THEN 2145 2162 values_realwp_0d_pointer => values_realwp_0d … … 2160 2177 ELSEIF ( PRESENT( values_realwp_2d ) ) THEN 2161 2178 IF ( do_output ) THEN 2162 ALLOCATE( values_realwp_2d_resorted(0:value_counts(1)-1, & 2163 0:value_counts(2)-1) ) 2179 ALLOCATE( values_realwp_2d_resorted(0:value_counts(1)-1,0:value_counts(2)-1) ) 2164 2180 !$OMP PARALLEL PRIVATE (i,j) 2165 2181 !$OMP DO 2166 2182 DO i = 0, value_counts(1) - 1 2167 2183 DO j = 0, value_counts(2) - 1 2168 values_realwp_2d_resorted(i,j) = values_realwp_2d(masked_indices(2,j), &2169 masked_indices(1,i) 2184 values_realwp_2d_resorted(i,j) = values_realwp_2d(masked_indices(2,j), & 2185 masked_indices(1,i)) 2170 2186 ENDDO 2171 2187 ENDDO … … 2178 2194 ELSEIF ( PRESENT( values_realwp_3d ) ) THEN 2179 2195 IF ( do_output ) THEN 2180 ALLOCATE( values_realwp_3d_resorted(0:value_counts(1)-1, &2181 0:value_counts(2)-1, &2196 ALLOCATE( values_realwp_3d_resorted(0:value_counts(1)-1, & 2197 0:value_counts(2)-1, & 2182 2198 0:value_counts(3)-1) ) 2183 2199 !$OMP PARALLEL PRIVATE (i,j,k) … … 2186 2202 DO j = 0, value_counts(2) - 1 2187 2203 DO k = 0, value_counts(3) - 1 2188 values_realwp_3d_resorted(i,j,k) = values_realwp_3d(masked_indices(3,k), &2189 masked_indices(2,j), &2190 masked_indices(1,i) 2204 values_realwp_3d_resorted(i,j,k) = values_realwp_3d(masked_indices(3,k), & 2205 masked_indices(2,j), & 2206 masked_indices(1,i)) 2191 2207 ENDDO 2192 2208 ENDDO … … 2201 2217 ELSE 2202 2218 return_value = 1 2203 CALL internal_message( 'error', routine_name // &2204 ': no output values given ' // &2205 '(variable "' // TRIM( variable_name ) // &2219 CALL internal_message( 'error', routine_name // & 2220 ': no output values given ' // & 2221 '(variable "' // TRIM( variable_name ) // & 2206 2222 '", file "' // TRIM( file_name ) // '")!' ) 2207 2223 ENDIF … … 2218 2234 CASE ( 'binary' ) 2219 2235 ! 2220 !-- character output2236 !-- Character output 2221 2237 IF ( PRESENT( values_char_0d ) ) THEN 2222 CALL binary_write_variable( file_id, variable_id, &2223 bounds_start_internal, value_counts, bounds_origin, is_global, &2238 CALL binary_write_variable( file_id, variable_id, & 2239 bounds_start_internal, value_counts, bounds_origin, is_global, & 2224 2240 values_char_0d=values_char_0d_pointer, return_value=output_return_value ) 2225 2241 ELSEIF ( PRESENT( values_char_1d ) ) THEN 2226 CALL binary_write_variable( file_id, variable_id, &2227 bounds_start_internal, value_counts, bounds_origin, is_global, &2242 CALL binary_write_variable( file_id, variable_id, & 2243 bounds_start_internal, value_counts, bounds_origin, is_global, & 2228 2244 values_char_1d=values_char_1d_pointer, return_value=output_return_value ) 2229 2245 ELSEIF ( PRESENT( values_char_2d ) ) THEN 2230 CALL binary_write_variable( file_id, variable_id, &2231 bounds_start_internal, value_counts, bounds_origin, is_global, &2246 CALL binary_write_variable( file_id, variable_id, & 2247 bounds_start_internal, value_counts, bounds_origin, is_global, & 2232 2248 values_char_2d=values_char_2d_pointer, return_value=output_return_value ) 2233 2249 ELSEIF ( PRESENT( values_char_3d ) ) THEN 2234 CALL binary_write_variable( file_id, variable_id, &2235 bounds_start_internal, value_counts, bounds_origin, is_global, &2250 CALL binary_write_variable( file_id, variable_id, & 2251 bounds_start_internal, value_counts, bounds_origin, is_global, & 2236 2252 values_char_3d=values_char_3d_pointer, return_value=output_return_value ) 2237 2253 ! 2238 2254 !-- 8bit integer output 2239 2255 ELSEIF ( PRESENT( values_int8_0d ) ) THEN 2240 CALL binary_write_variable( file_id, variable_id, &2241 bounds_start_internal, value_counts, bounds_origin, is_global, &2256 CALL binary_write_variable( file_id, variable_id, & 2257 bounds_start_internal, value_counts, bounds_origin, is_global, & 2242 2258 values_int8_0d=values_int8_0d_pointer, return_value=output_return_value ) 2243 2259 ELSEIF ( PRESENT( values_int8_1d ) ) THEN 2244 CALL binary_write_variable( file_id, variable_id, &2245 bounds_start_internal, value_counts, bounds_origin, is_global, &2260 CALL binary_write_variable( file_id, variable_id, & 2261 bounds_start_internal, value_counts, bounds_origin, is_global, & 2246 2262 values_int8_1d=values_int8_1d_pointer, return_value=output_return_value ) 2247 2263 ELSEIF ( PRESENT( values_int8_2d ) ) THEN 2248 CALL binary_write_variable( file_id, variable_id, &2249 bounds_start_internal, value_counts, bounds_origin, is_global, &2264 CALL binary_write_variable( file_id, variable_id, & 2265 bounds_start_internal, value_counts, bounds_origin, is_global, & 2250 2266 values_int8_2d=values_int8_2d_pointer, return_value=output_return_value ) 2251 2267 ELSEIF ( PRESENT( values_int8_3d ) ) THEN 2252 CALL binary_write_variable( file_id, variable_id, &2253 bounds_start_internal, value_counts, bounds_origin, is_global, &2268 CALL binary_write_variable( file_id, variable_id, & 2269 bounds_start_internal, value_counts, bounds_origin, is_global, & 2254 2270 values_int8_3d=values_int8_3d_pointer, return_value=output_return_value ) 2255 2271 ! 2256 2272 !-- 16bit integer output 2257 2273 ELSEIF ( PRESENT( values_int16_0d ) ) THEN 2258 CALL binary_write_variable( file_id, variable_id, &2259 bounds_start_internal, value_counts, bounds_origin, is_global, &2274 CALL binary_write_variable( file_id, variable_id, & 2275 bounds_start_internal, value_counts, bounds_origin, is_global, & 2260 2276 values_int16_0d=values_int16_0d_pointer, return_value=output_return_value ) 2261 2277 ELSEIF ( PRESENT( values_int16_1d ) ) THEN 2262 CALL binary_write_variable( file_id, variable_id, &2263 bounds_start_internal, value_counts, bounds_origin, is_global, &2278 CALL binary_write_variable( file_id, variable_id, & 2279 bounds_start_internal, value_counts, bounds_origin, is_global, & 2264 2280 values_int16_1d=values_int16_1d_pointer, return_value=output_return_value ) 2265 2281 ELSEIF ( PRESENT( values_int16_2d ) ) THEN 2266 CALL binary_write_variable( file_id, variable_id, &2267 bounds_start_internal, value_counts, bounds_origin, is_global, &2282 CALL binary_write_variable( file_id, variable_id, & 2283 bounds_start_internal, value_counts, bounds_origin, is_global, & 2268 2284 values_int16_2d=values_int16_2d_pointer, return_value=output_return_value ) 2269 2285 ELSEIF ( PRESENT( values_int16_3d ) ) THEN 2270 CALL binary_write_variable( file_id, variable_id, &2271 bounds_start_internal, value_counts, bounds_origin, is_global, &2286 CALL binary_write_variable( file_id, variable_id, & 2287 bounds_start_internal, value_counts, bounds_origin, is_global, & 2272 2288 values_int16_3d=values_int16_3d_pointer, return_value=output_return_value ) 2273 2289 ! 2274 2290 !-- 32bit integer output 2275 2291 ELSEIF ( PRESENT( values_int32_0d ) ) THEN 2276 CALL binary_write_variable( file_id, variable_id, &2277 bounds_start_internal, value_counts, bounds_origin, is_global, &2292 CALL binary_write_variable( file_id, variable_id, & 2293 bounds_start_internal, value_counts, bounds_origin, is_global, & 2278 2294 values_int32_0d=values_int32_0d_pointer, return_value=output_return_value ) 2279 2295 ELSEIF ( PRESENT( values_int32_1d ) ) THEN 2280 CALL binary_write_variable( file_id, variable_id, &2281 bounds_start_internal, value_counts, bounds_origin, is_global, &2296 CALL binary_write_variable( file_id, variable_id, & 2297 bounds_start_internal, value_counts, bounds_origin, is_global, & 2282 2298 values_int32_1d=values_int32_1d_pointer, return_value=output_return_value ) 2283 2299 ELSEIF ( PRESENT( values_int32_2d ) ) THEN 2284 CALL binary_write_variable( file_id, variable_id, &2285 bounds_start_internal, value_counts, bounds_origin, is_global, &2300 CALL binary_write_variable( file_id, variable_id, & 2301 bounds_start_internal, value_counts, bounds_origin, is_global, & 2286 2302 values_int32_2d=values_int32_2d_pointer, return_value=output_return_value ) 2287 2303 ELSEIF ( PRESENT( values_int32_3d ) ) THEN 2288 CALL binary_write_variable( file_id, variable_id, &2289 bounds_start_internal, value_counts, bounds_origin, is_global, &2304 CALL binary_write_variable( file_id, variable_id, & 2305 bounds_start_internal, value_counts, bounds_origin, is_global, & 2290 2306 values_int32_3d=values_int32_3d_pointer, return_value=output_return_value ) 2291 2307 ! 2292 !-- working-precision integer output2308 !-- Working-precision integer output 2293 2309 ELSEIF ( PRESENT( values_intwp_0d ) ) THEN 2294 CALL binary_write_variable( file_id, variable_id, &2295 bounds_start_internal, value_counts, bounds_origin, is_global, &2310 CALL binary_write_variable( file_id, variable_id, & 2311 bounds_start_internal, value_counts, bounds_origin, is_global, & 2296 2312 values_intwp_0d=values_intwp_0d_pointer, return_value=output_return_value ) 2297 2313 ELSEIF ( PRESENT( values_intwp_1d ) ) THEN 2298 CALL binary_write_variable( file_id, variable_id, &2299 bounds_start_internal, value_counts, bounds_origin, is_global, &2314 CALL binary_write_variable( file_id, variable_id, & 2315 bounds_start_internal, value_counts, bounds_origin, is_global, & 2300 2316 values_intwp_1d=values_intwp_1d_pointer, return_value=output_return_value ) 2301 2317 ELSEIF ( PRESENT( values_intwp_2d ) ) THEN 2302 CALL binary_write_variable( file_id, variable_id, &2303 bounds_start_internal, value_counts, bounds_origin, is_global, &2318 CALL binary_write_variable( file_id, variable_id, & 2319 bounds_start_internal, value_counts, bounds_origin, is_global, & 2304 2320 values_intwp_2d=values_intwp_2d_pointer, return_value=output_return_value ) 2305 2321 ELSEIF ( PRESENT( values_intwp_3d ) ) THEN 2306 CALL binary_write_variable( file_id, variable_id, &2307 bounds_start_internal, value_counts, bounds_origin, is_global, &2322 CALL binary_write_variable( file_id, variable_id, & 2323 bounds_start_internal, value_counts, bounds_origin, is_global, & 2308 2324 values_intwp_3d=values_intwp_3d_pointer, return_value=output_return_value ) 2309 2325 ! 2310 2326 !-- 32bit real output 2311 2327 ELSEIF ( PRESENT( values_real32_0d ) ) THEN 2312 CALL binary_write_variable( file_id, variable_id, &2313 bounds_start_internal, value_counts, bounds_origin, is_global, &2328 CALL binary_write_variable( file_id, variable_id, & 2329 bounds_start_internal, value_counts, bounds_origin, is_global, & 2314 2330 values_real32_0d=values_real32_0d_pointer, return_value=output_return_value ) 2315 2331 ELSEIF ( PRESENT( values_real32_1d ) ) THEN 2316 CALL binary_write_variable( file_id, variable_id, &2317 bounds_start_internal, value_counts, bounds_origin, is_global, &2332 CALL binary_write_variable( file_id, variable_id, & 2333 bounds_start_internal, value_counts, bounds_origin, is_global, & 2318 2334 values_real32_1d=values_real32_1d_pointer, return_value=output_return_value ) 2319 2335 ELSEIF ( PRESENT( values_real32_2d ) ) THEN 2320 CALL binary_write_variable( file_id, variable_id, &2321 bounds_start_internal, value_counts, bounds_origin, is_global, &2336 CALL binary_write_variable( file_id, variable_id, & 2337 bounds_start_internal, value_counts, bounds_origin, is_global, & 2322 2338 values_real32_2d=values_real32_2d_pointer, return_value=output_return_value ) 2323 2339 ELSEIF ( PRESENT( values_real32_3d ) ) THEN 2324 CALL binary_write_variable( file_id, variable_id, &2325 bounds_start_internal, value_counts, bounds_origin, is_global, &2340 CALL binary_write_variable( file_id, variable_id, & 2341 bounds_start_internal, value_counts, bounds_origin, is_global, & 2326 2342 values_real32_3d=values_real32_3d_pointer, return_value=output_return_value ) 2327 2343 ! 2328 2344 !-- 64bit real output 2329 2345 ELSEIF ( PRESENT( values_real64_0d ) ) THEN 2330 CALL binary_write_variable( file_id, variable_id, &2331 bounds_start_internal, value_counts, bounds_origin, is_global, &2346 CALL binary_write_variable( file_id, variable_id, & 2347 bounds_start_internal, value_counts, bounds_origin, is_global, & 2332 2348 values_real64_0d=values_real64_0d_pointer, return_value=output_return_value ) 2333 2349 ELSEIF ( PRESENT( values_real64_1d ) ) THEN 2334 CALL binary_write_variable( file_id, variable_id, &2335 bounds_start_internal, value_counts, bounds_origin, is_global, &2350 CALL binary_write_variable( file_id, variable_id, & 2351 bounds_start_internal, value_counts, bounds_origin, is_global, & 2336 2352 values_real64_1d=values_real64_1d_pointer, return_value=output_return_value ) 2337 2353 ELSEIF ( PRESENT( values_real64_2d ) ) THEN 2338 CALL binary_write_variable( file_id, variable_id, &2339 bounds_start_internal, value_counts, bounds_origin, is_global, &2354 CALL binary_write_variable( file_id, variable_id, & 2355 bounds_start_internal, value_counts, bounds_origin, is_global, & 2340 2356 values_real64_2d=values_real64_2d_pointer, return_value=output_return_value ) 2341 2357 ELSEIF ( PRESENT( values_real64_3d ) ) THEN 2342 CALL binary_write_variable( file_id, variable_id, &2343 bounds_start_internal, value_counts, bounds_origin, is_global, &2358 CALL binary_write_variable( file_id, variable_id, & 2359 bounds_start_internal, value_counts, bounds_origin, is_global, & 2344 2360 values_real64_3d=values_real64_3d_pointer, return_value=output_return_value ) 2345 2361 ! 2346 2362 !-- working-precision real output 2347 2363 ELSEIF ( PRESENT( values_realwp_0d ) ) THEN 2348 CALL binary_write_variable( file_id, variable_id, &2349 bounds_start_internal, value_counts, bounds_origin, is_global, &2364 CALL binary_write_variable( file_id, variable_id, & 2365 bounds_start_internal, value_counts, bounds_origin, is_global, & 2350 2366 values_realwp_0d=values_realwp_0d_pointer, return_value=output_return_value ) 2351 2367 ELSEIF ( PRESENT( values_realwp_1d ) ) THEN 2352 CALL binary_write_variable( file_id, variable_id, &2353 bounds_start_internal, value_counts, bounds_origin, is_global, &2368 CALL binary_write_variable( file_id, variable_id, & 2369 bounds_start_internal, value_counts, bounds_origin, is_global, & 2354 2370 values_realwp_1d=values_realwp_1d_pointer, return_value=output_return_value ) 2355 2371 ELSEIF ( PRESENT( values_realwp_2d ) ) THEN 2356 CALL binary_write_variable( file_id, variable_id, &2357 bounds_start_internal, value_counts, bounds_origin, is_global, &2372 CALL binary_write_variable( file_id, variable_id, & 2373 bounds_start_internal, value_counts, bounds_origin, is_global, & 2358 2374 values_realwp_2d=values_realwp_2d_pointer, return_value=output_return_value ) 2359 2375 ELSEIF ( PRESENT( values_realwp_3d ) ) THEN 2360 CALL binary_write_variable( file_id, variable_id, &2361 bounds_start_internal, value_counts, bounds_origin, is_global, &2376 CALL binary_write_variable( file_id, variable_id, & 2377 bounds_start_internal, value_counts, bounds_origin, is_global, & 2362 2378 values_realwp_3d=values_realwp_3d_pointer, return_value=output_return_value ) 2363 2379 ELSE 2364 2380 return_value = 1 2365 CALL internal_message( 'error', routine_name // &2366 ': output_type not supported by file format "' // &2367 TRIM( file_format ) // '" ' // &2368 '(variable "' // TRIM( variable_name ) // &2381 CALL internal_message( 'error', routine_name // & 2382 ': output_type not supported by file format "' // & 2383 TRIM( file_format ) // '" ' // & 2384 '(variable "' // TRIM( variable_name ) // & 2369 2385 '", file "' // TRIM( file_name ) // '")!' ) 2370 2386 ENDIF … … 2372 2388 CASE ( 'netcdf4-parallel', 'netcdf4-serial' ) 2373 2389 ! 2374 !-- character output2390 !-- Character output 2375 2391 IF ( PRESENT( values_char_0d ) ) THEN 2376 CALL netcdf4_write_variable( file_id, variable_id, &2377 bounds_start_internal, value_counts, bounds_origin, is_global, &2392 CALL netcdf4_write_variable( file_id, variable_id, & 2393 bounds_start_internal, value_counts, bounds_origin, is_global, & 2378 2394 values_char_0d=values_char_0d_pointer, return_value=output_return_value ) 2379 2395 ELSEIF ( PRESENT( values_char_1d ) ) THEN 2380 CALL netcdf4_write_variable( file_id, variable_id, &2381 bounds_start_internal, value_counts, bounds_origin, is_global, &2396 CALL netcdf4_write_variable( file_id, variable_id, & 2397 bounds_start_internal, value_counts, bounds_origin, is_global, & 2382 2398 values_char_1d=values_char_1d_pointer, return_value=output_return_value ) 2383 2399 ELSEIF ( PRESENT( values_char_2d ) ) THEN 2384 CALL netcdf4_write_variable( file_id, variable_id, &2385 bounds_start_internal, value_counts, bounds_origin, is_global, &2400 CALL netcdf4_write_variable( file_id, variable_id, & 2401 bounds_start_internal, value_counts, bounds_origin, is_global, & 2386 2402 values_char_2d=values_char_2d_pointer, return_value=output_return_value ) 2387 2403 ELSEIF ( PRESENT( values_char_3d ) ) THEN 2388 CALL netcdf4_write_variable( file_id, variable_id, &2389 bounds_start_internal, value_counts, bounds_origin, is_global, &2404 CALL netcdf4_write_variable( file_id, variable_id, & 2405 bounds_start_internal, value_counts, bounds_origin, is_global, & 2390 2406 values_char_3d=values_char_3d_pointer, return_value=output_return_value ) 2391 2407 ! 2392 2408 !-- 8bit integer output 2393 2409 ELSEIF ( PRESENT( values_int8_0d ) ) THEN 2394 CALL netcdf4_write_variable( file_id, variable_id, &2395 bounds_start_internal, value_counts, bounds_origin, is_global, &2410 CALL netcdf4_write_variable( file_id, variable_id, & 2411 bounds_start_internal, value_counts, bounds_origin, is_global, & 2396 2412 values_int8_0d=values_int8_0d_pointer, return_value=output_return_value ) 2397 2413 ELSEIF ( PRESENT( values_int8_1d ) ) THEN 2398 CALL netcdf4_write_variable( file_id, variable_id, &2399 bounds_start_internal, value_counts, bounds_origin, is_global, &2414 CALL netcdf4_write_variable( file_id, variable_id, & 2415 bounds_start_internal, value_counts, bounds_origin, is_global, & 2400 2416 values_int8_1d=values_int8_1d_pointer, return_value=output_return_value ) 2401 2417 ELSEIF ( PRESENT( values_int8_2d ) ) THEN 2402 CALL netcdf4_write_variable( file_id, variable_id, &2403 bounds_start_internal, value_counts, bounds_origin, is_global, &2418 CALL netcdf4_write_variable( file_id, variable_id, & 2419 bounds_start_internal, value_counts, bounds_origin, is_global, & 2404 2420 values_int8_2d=values_int8_2d_pointer, return_value=output_return_value ) 2405 2421 ELSEIF ( PRESENT( values_int8_3d ) ) THEN 2406 CALL netcdf4_write_variable( file_id, variable_id, &2407 bounds_start_internal, value_counts, bounds_origin, is_global, &2422 CALL netcdf4_write_variable( file_id, variable_id, & 2423 bounds_start_internal, value_counts, bounds_origin, is_global, & 2408 2424 values_int8_3d=values_int8_3d_pointer, return_value=output_return_value ) 2409 2425 ! 2410 2426 !-- 16bit integer output 2411 2427 ELSEIF ( PRESENT( values_int16_0d ) ) THEN 2412 CALL netcdf4_write_variable( file_id, variable_id, &2413 bounds_start_internal, value_counts, bounds_origin, is_global, &2428 CALL netcdf4_write_variable( file_id, variable_id, & 2429 bounds_start_internal, value_counts, bounds_origin, is_global, & 2414 2430 values_int16_0d=values_int16_0d_pointer, return_value=output_return_value ) 2415 2431 ELSEIF ( PRESENT( values_int16_1d ) ) THEN 2416 CALL netcdf4_write_variable( file_id, variable_id, &2417 bounds_start_internal, value_counts, bounds_origin, is_global, &2432 CALL netcdf4_write_variable( file_id, variable_id, & 2433 bounds_start_internal, value_counts, bounds_origin, is_global, & 2418 2434 values_int16_1d=values_int16_1d_pointer, return_value=output_return_value ) 2419 2435 ELSEIF ( PRESENT( values_int16_2d ) ) THEN 2420 CALL netcdf4_write_variable( file_id, variable_id, &2421 bounds_start_internal, value_counts, bounds_origin, is_global, &2436 CALL netcdf4_write_variable( file_id, variable_id, & 2437 bounds_start_internal, value_counts, bounds_origin, is_global, & 2422 2438 values_int16_2d=values_int16_2d_pointer, return_value=output_return_value ) 2423 2439 ELSEIF ( PRESENT( values_int16_3d ) ) THEN 2424 CALL netcdf4_write_variable( file_id, variable_id, &2425 bounds_start_internal, value_counts, bounds_origin, is_global, &2440 CALL netcdf4_write_variable( file_id, variable_id, & 2441 bounds_start_internal, value_counts, bounds_origin, is_global, & 2426 2442 values_int16_3d=values_int16_3d_pointer, return_value=output_return_value ) 2427 2443 ! 2428 2444 !-- 32bit integer output 2429 2445 ELSEIF ( PRESENT( values_int32_0d ) ) THEN 2430 CALL netcdf4_write_variable( file_id, variable_id, &2431 bounds_start_internal, value_counts, bounds_origin, is_global, &2446 CALL netcdf4_write_variable( file_id, variable_id, & 2447 bounds_start_internal, value_counts, bounds_origin, is_global, & 2432 2448 values_int32_0d=values_int32_0d_pointer, return_value=output_return_value ) 2433 2449 ELSEIF ( PRESENT( values_int32_1d ) ) THEN 2434 CALL netcdf4_write_variable( file_id, variable_id, &2435 bounds_start_internal, value_counts, bounds_origin, is_global, &2450 CALL netcdf4_write_variable( file_id, variable_id, & 2451 bounds_start_internal, value_counts, bounds_origin, is_global, & 2436 2452 values_int32_1d=values_int32_1d_pointer, return_value=output_return_value ) 2437 2453 ELSEIF ( PRESENT( values_int32_2d ) ) THEN 2438 CALL netcdf4_write_variable( file_id, variable_id, &2439 bounds_start_internal, value_counts, bounds_origin, is_global, &2454 CALL netcdf4_write_variable( file_id, variable_id, & 2455 bounds_start_internal, value_counts, bounds_origin, is_global, & 2440 2456 values_int32_2d=values_int32_2d_pointer, return_value=output_return_value ) 2441 2457 ELSEIF ( PRESENT( values_int32_3d ) ) THEN 2442 CALL netcdf4_write_variable( file_id, variable_id, &2443 bounds_start_internal, value_counts, bounds_origin, is_global, &2458 CALL netcdf4_write_variable( file_id, variable_id, & 2459 bounds_start_internal, value_counts, bounds_origin, is_global, & 2444 2460 values_int32_3d=values_int32_3d_pointer, return_value=output_return_value ) 2445 2461 ! 2446 !-- working-precision integer output2462 !-- Working-precision integer output 2447 2463 ELSEIF ( PRESENT( values_intwp_0d ) ) THEN 2448 CALL netcdf4_write_variable( file_id, variable_id, &2449 bounds_start_internal, value_counts, bounds_origin, is_global, &2464 CALL netcdf4_write_variable( file_id, variable_id, & 2465 bounds_start_internal, value_counts, bounds_origin, is_global, & 2450 2466 values_intwp_0d=values_intwp_0d_pointer, return_value=output_return_value ) 2451 2467 ELSEIF ( PRESENT( values_intwp_1d ) ) THEN 2452 CALL netcdf4_write_variable( file_id, variable_id, &2453 bounds_start_internal, value_counts, bounds_origin, is_global, &2468 CALL netcdf4_write_variable( file_id, variable_id, & 2469 bounds_start_internal, value_counts, bounds_origin, is_global, & 2454 2470 values_intwp_1d=values_intwp_1d_pointer, return_value=output_return_value ) 2455 2471 ELSEIF ( PRESENT( values_intwp_2d ) ) THEN 2456 CALL netcdf4_write_variable( file_id, variable_id, &2457 bounds_start_internal, value_counts, bounds_origin, is_global, &2472 CALL netcdf4_write_variable( file_id, variable_id, & 2473 bounds_start_internal, value_counts, bounds_origin, is_global, & 2458 2474 values_intwp_2d=values_intwp_2d_pointer, return_value=output_return_value ) 2459 2475 ELSEIF ( PRESENT( values_intwp_3d ) ) THEN 2460 CALL netcdf4_write_variable( file_id, variable_id, &2461 bounds_start_internal, value_counts, bounds_origin, is_global, &2476 CALL netcdf4_write_variable( file_id, variable_id, & 2477 bounds_start_internal, value_counts, bounds_origin, is_global, & 2462 2478 values_intwp_3d=values_intwp_3d_pointer, return_value=output_return_value ) 2463 2479 ! 2464 2480 !-- 32bit real output 2465 2481 ELSEIF ( PRESENT( values_real32_0d ) ) THEN 2466 CALL netcdf4_write_variable( file_id, variable_id, &2467 bounds_start_internal, value_counts, bounds_origin, is_global, &2482 CALL netcdf4_write_variable( file_id, variable_id, & 2483 bounds_start_internal, value_counts, bounds_origin, is_global, & 2468 2484 values_real32_0d=values_real32_0d_pointer, return_value=output_return_value ) 2469 2485 ELSEIF ( PRESENT( values_real32_1d ) ) THEN 2470 CALL netcdf4_write_variable( file_id, variable_id, &2471 bounds_start_internal, value_counts, bounds_origin, is_global, &2486 CALL netcdf4_write_variable( file_id, variable_id, & 2487 bounds_start_internal, value_counts, bounds_origin, is_global, & 2472 2488 values_real32_1d=values_real32_1d_pointer, return_value=output_return_value ) 2473 2489 ELSEIF ( PRESENT( values_real32_2d ) ) THEN 2474 CALL netcdf4_write_variable( file_id, variable_id, &2475 bounds_start_internal, value_counts, bounds_origin, is_global, &2490 CALL netcdf4_write_variable( file_id, variable_id, & 2491 bounds_start_internal, value_counts, bounds_origin, is_global, & 2476 2492 values_real32_2d=values_real32_2d_pointer, return_value=output_return_value ) 2477 2493 ELSEIF ( PRESENT( values_real32_3d ) ) THEN 2478 CALL netcdf4_write_variable( file_id, variable_id, &2479 bounds_start_internal, value_counts, bounds_origin, is_global, &2494 CALL netcdf4_write_variable( file_id, variable_id, & 2495 bounds_start_internal, value_counts, bounds_origin, is_global, & 2480 2496 values_real32_3d=values_real32_3d_pointer, return_value=output_return_value ) 2481 2497 ! 2482 2498 !-- 64bit real output 2483 2499 ELSEIF ( PRESENT( values_real64_0d ) ) THEN 2484 CALL netcdf4_write_variable( file_id, variable_id, &2485 bounds_start_internal, value_counts, bounds_origin, is_global, &2500 CALL netcdf4_write_variable( file_id, variable_id, & 2501 bounds_start_internal, value_counts, bounds_origin, is_global, & 2486 2502 values_real64_0d=values_real64_0d_pointer, return_value=output_return_value ) 2487 2503 ELSEIF ( PRESENT( values_real64_1d ) ) THEN 2488 CALL netcdf4_write_variable( file_id, variable_id, &2489 bounds_start_internal, value_counts, bounds_origin, is_global, &2504 CALL netcdf4_write_variable( file_id, variable_id, & 2505 bounds_start_internal, value_counts, bounds_origin, is_global, & 2490 2506 values_real64_1d=values_real64_1d_pointer, return_value=output_return_value ) 2491 2507 ELSEIF ( PRESENT( values_real64_2d ) ) THEN 2492 CALL netcdf4_write_variable( file_id, variable_id, &2493 bounds_start_internal, value_counts, bounds_origin, is_global, &2508 CALL netcdf4_write_variable( file_id, variable_id, & 2509 bounds_start_internal, value_counts, bounds_origin, is_global, & 2494 2510 values_real64_2d=values_real64_2d_pointer, return_value=output_return_value ) 2495 2511 ELSEIF ( PRESENT( values_real64_3d ) ) THEN 2496 CALL netcdf4_write_variable( file_id, variable_id, &2497 bounds_start_internal, value_counts, bounds_origin, is_global, &2512 CALL netcdf4_write_variable( file_id, variable_id, & 2513 bounds_start_internal, value_counts, bounds_origin, is_global, & 2498 2514 values_real64_3d=values_real64_3d_pointer, return_value=output_return_value ) 2499 2515 ! 2500 2516 !-- working-precision real output 2501 2517 ELSEIF ( PRESENT( values_realwp_0d ) ) THEN 2502 CALL netcdf4_write_variable( file_id, variable_id, &2503 bounds_start_internal, value_counts, bounds_origin, is_global, &2518 CALL netcdf4_write_variable( file_id, variable_id, & 2519 bounds_start_internal, value_counts, bounds_origin, is_global, & 2504 2520 values_realwp_0d=values_realwp_0d_pointer, return_value=output_return_value ) 2505 2521 ELSEIF ( PRESENT( values_realwp_1d ) ) THEN 2506 CALL netcdf4_write_variable( file_id, variable_id, &2507 bounds_start_internal, value_counts, bounds_origin, is_global, &2522 CALL netcdf4_write_variable( file_id, variable_id, & 2523 bounds_start_internal, value_counts, bounds_origin, is_global, & 2508 2524 values_realwp_1d=values_realwp_1d_pointer, return_value=output_return_value ) 2509 2525 ELSEIF ( PRESENT( values_realwp_2d ) ) THEN 2510 CALL netcdf4_write_variable( file_id, variable_id, &2511 bounds_start_internal, value_counts, bounds_origin, is_global, &2526 CALL netcdf4_write_variable( file_id, variable_id, & 2527 bounds_start_internal, value_counts, bounds_origin, is_global, & 2512 2528 values_realwp_2d=values_realwp_2d_pointer, return_value=output_return_value ) 2513 2529 ELSEIF ( PRESENT( values_realwp_3d ) ) THEN 2514 CALL netcdf4_write_variable( file_id, variable_id, &2515 bounds_start_internal, value_counts, bounds_origin, is_global, &2530 CALL netcdf4_write_variable( file_id, variable_id, & 2531 bounds_start_internal, value_counts, bounds_origin, is_global, & 2516 2532 values_realwp_3d=values_realwp_3d_pointer, return_value=output_return_value ) 2517 2533 ELSE 2518 2534 return_value = 1 2519 CALL internal_message( 'error', routine_name // &2520 ': output_type not supported by file format "' // &2521 TRIM( file_format ) // '" ' // &2522 '(variable "' // TRIM( variable_name ) // &2535 CALL internal_message( 'error', routine_name // & 2536 ': output_type not supported by file format "' // & 2537 TRIM( file_format ) // '" ' // & 2538 '(variable "' // TRIM( variable_name ) // & 2523 2539 '", file "' // TRIM( file_name ) // '")!' ) 2524 2540 ENDIF … … 2526 2542 CASE DEFAULT 2527 2543 return_value = 1 2528 CALL internal_message( 'error', routine_name // &2529 ': file format "' // TRIM( file_format ) // &2530 '" not supported ' // &2531 '(variable "' // TRIM( variable_name ) // &2544 CALL internal_message( 'error', routine_name // & 2545 ': file format "' // TRIM( file_format ) // & 2546 '" not supported ' // & 2547 '(variable "' // TRIM( variable_name ) // & 2532 2548 '", file "' // TRIM( file_name ) // '")!' ) 2533 2549 … … 2536 2552 IF ( return_value == 0 .AND. output_return_value /= 0 ) THEN 2537 2553 return_value = 1 2538 CALL internal_message( 'error', routine_name // &2539 ': error while writing variable ' // &2540 '(variable "' // TRIM( variable_name ) // &2554 CALL internal_message( 'error', routine_name // & 2555 ': error while writing variable ' // & 2556 '(variable "' // TRIM( variable_name ) // & 2541 2557 '", file "' // TRIM( file_name ) // '")!' ) 2542 2558 ENDIF … … 2589 2605 IF ( output_return_value /= 0 ) THEN 2590 2606 return_value = output_return_value 2591 CALL internal_message( 'error', routine_name // &2592 ': error while finalizing file "' // &2607 CALL internal_message( 'error', routine_name // & 2608 ': error while finalizing file "' // & 2593 2609 TRIM( files(f)%name ) // '"' ) 2594 2610 ELSEIF ( return_value_internal /= 0 ) THEN 2595 2611 return_value = return_value_internal 2596 CALL internal_message( 'error', routine_name // &2597 ': unsupported file format "' // &2598 TRIM( files(f)%format ) // '" for file "' // &2612 CALL internal_message( 'error', routine_name // & 2613 ': unsupported file format "' // & 2614 TRIM( files(f)%format ) // '" for file "' // & 2599 2615 TRIM( files(f)%name ) // '"' ) 2600 2616 ENDIF … … 2636 2652 RESULT( return_value ) 2637 2653 2654 CHARACTER(LEN=*), PARAMETER :: routine_name = 'save_attribute_in_database' !< name of routine 2655 2638 2656 CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file 2639 2657 CHARACTER(LEN=*), INTENT(IN) :: variable_name !< name of variable 2640 2641 CHARACTER(LEN=*), PARAMETER :: routine_name = 'save_attribute_in_database' !< name of routine2642 2658 2643 2659 INTEGER :: a !< loop index … … 2658 2674 found = .FALSE. 2659 2675 2660 CALL internal_message( 'debug', routine_name // &2661 ': define attribute "' // TRIM( attribute%name ) // &2662 '" of variable "' // TRIM( variable_name ) // &2676 CALL internal_message( 'debug', routine_name // & 2677 ': define attribute "' // TRIM( attribute%name ) // & 2678 '" of variable "' // TRIM( variable_name ) // & 2663 2679 '" in file "' // TRIM( file_name ) // '"' ) 2664 2680 … … 2669 2685 IF ( files(f)%is_init ) THEN 2670 2686 return_value = 1 2671 CALL internal_message( 'error', routine_name // ': file "' // TRIM( file_name ) // &2687 CALL internal_message( 'error', routine_name // ': file "' // TRIM( file_name ) // & 2672 2688 '" is already initialized. No further attribute definition allowed!' ) 2673 2689 EXIT … … 2690 2706 ! 2691 2707 !-- Append existing string attribute 2692 files(f)%attributes(a)%value_char = &2693 TRIM( files(f)%attributes(a)%value_char ) // &2694 TRIM( attribute%value_char )2708 files(f)%attributes(a)%value_char = & 2709 TRIM( files(f)%attributes(a)%value_char ) // & 2710 TRIM( attribute%value_char ) 2695 2711 ELSE 2696 2712 files(f)%attributes(a) = attribute … … 2745 2761 ! 2746 2762 !-- Append existing character attribute 2747 files(f)%dimensions(d)%attributes(a)%value_char = &2748 TRIM( files(f)%dimensions(d)%attributes(a)%value_char ) // &2763 files(f)%dimensions(d)%attributes(a)%value_char = & 2764 TRIM( files(f)%dimensions(d)%attributes(a)%value_char ) // & 2749 2765 TRIM( attribute%value_char ) 2750 2766 ELSE … … 2801 2817 !-- Check if attribute already exists 2802 2818 DO a = 1, natts 2803 IF ( files(f)%variables(d)%attributes(a)%name == attribute%name ) & 2804 THEN 2819 IF ( files(f)%variables(d)%attributes(a)%name == attribute%name ) THEN 2805 2820 IF ( append ) THEN 2806 2821 ! 2807 2822 !-- Append existing character attribute 2808 files(f)%variables(d)%attributes(a)%value_char = &2809 TRIM( files(f)%variables(d)%attributes(a)%value_char ) // &2823 files(f)%variables(d)%attributes(a)%value_char = & 2824 TRIM( files(f)%variables(d)%attributes(a)%value_char ) // & 2810 2825 TRIM( attribute%value_char ) 2811 2826 ELSE … … 2848 2863 IF ( .NOT. found ) THEN 2849 2864 return_value = 1 2850 CALL internal_message( 'error', &2851 routine_name // &2852 ': requested dimension/variable "' // TRIM( variable_name ) // &2853 '" for attribute "' // TRIM( attribute%name ) // &2854 '" does not exist in file "' // TRIM( file_name ) // '"' )2865 CALL internal_message( 'error', & 2866 routine_name // & 2867 ': requested dimension/variable "' // TRIM( variable_name ) // & 2868 '" for attribute "' // TRIM( attribute%name ) // & 2869 '" does not exist in file "' // TRIM( file_name ) // '"' ) 2855 2870 ENDIF 2856 2871 … … 2865 2880 IF ( .NOT. found .AND. return_value == 0 ) THEN 2866 2881 return_value = 1 2867 CALL internal_message( 'error', &2868 routine_name // &2869 ': requested file "' // TRIM( file_name ) // &2870 '" for attribute "' // TRIM( attribute%name ) // &2882 CALL internal_message( 'error', & 2883 routine_name // & 2884 ': requested file "' // TRIM( file_name ) // & 2885 '" for attribute "' // TRIM( attribute%name ) // & 2871 2886 '" does not exist' ) 2872 2887 ENDIF … … 2943 2958 DO d = 1, ndims 2944 2959 DO i = 1, nvars 2945 dimension_is_used(d) = &2946 ANY( files(f)%dimensions(d)%name == files(f)%variables(i)%dimension_names )2960 dimension_is_used(d) = & 2961 ANY( files(f)%dimensions(d)%name == files(f)%variables(i)%dimension_names ) 2947 2962 IF ( dimension_is_used(d) ) EXIT 2948 2963 ENDDO … … 2979 2994 SUBROUTINE open_output_file( file_format, file_name, file_id, return_value ) 2980 2995 2996 CHARACTER(LEN=*), PARAMETER :: routine_name = 'open_output_file' !< name of routine 2997 2981 2998 CHARACTER(LEN=*), INTENT(IN) :: file_format !< file format chosen for file 2982 2999 CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file to be checked 2983 2984 CHARACTER(LEN=*), PARAMETER :: routine_name = 'open_output_file' !< name of routine2985 3000 2986 3001 INTEGER, INTENT(OUT) :: file_id !< file ID … … 3010 3025 IF ( output_return_value /= 0 ) THEN 3011 3026 return_value = output_return_value 3012 CALL internal_message( 'error', routine_name // &3027 CALL internal_message( 'error', routine_name // & 3013 3028 ': error while opening file "' // TRIM( file_name ) // '"' ) 3014 3029 ELSEIF ( return_value /= 0 ) THEN 3015 CALL internal_message( 'error', routine_name // &3016 ': file "' // TRIM( file_name ) // &3017 '": file format "' // TRIM( file_format ) // &3030 CALL internal_message( 'error', routine_name // & 3031 ': file "' // TRIM( file_name ) // & 3032 '": file format "' // TRIM( file_format ) // & 3018 3033 '" not supported' ) 3019 3034 ENDIF … … 3042 3057 IF ( ALLOCATED( file%attributes ) ) THEN 3043 3058 DO a = 1, SIZE( file%attributes ) 3044 return_value = write_attribute( file%format, file%id, file%name, &3045 variable_id=no_id, variable_name='', &3059 return_value = write_attribute( file%format, file%id, file%name, & 3060 variable_id=no_id, variable_name='', & 3046 3061 attribute=file%attributes(a) ) 3047 3062 IF ( return_value /= 0 ) EXIT … … 3057 3072 ! 3058 3073 !-- Initialize non-masked dimension 3059 CALL init_file_dimension( file%format, file%id, file%name, &3060 file%dimensions(d)%id, file%dimensions(d)%name,&3061 file%dimensions(d)%data_type, file%dimensions(d)%length,&3062 file%dimensions(d)%variable_id, return_value )3074 CALL init_file_dimension( file%format, file%id, file%name, & 3075 file%dimensions(d)%id, file%dimensions(d)%name, & 3076 file%dimensions(d)%data_type, file%dimensions(d)%length, & 3077 file%dimensions(d)%variable_id, return_value ) 3063 3078 3064 3079 ELSE 3065 3080 ! 3066 3081 !-- Initialize masked dimension 3067 CALL init_file_dimension( file%format, file%id, file%name, &3068 file%dimensions(d)%id, file%dimensions(d)%name,&3069 file%dimensions(d)%data_type, file%dimensions(d)%length_mask,&3070 file%dimensions(d)%variable_id, return_value )3082 CALL init_file_dimension( file%format, file%id, file%name, & 3083 file%dimensions(d)%id, file%dimensions(d)%name, & 3084 file%dimensions(d)%data_type, file%dimensions(d)%length_mask,& 3085 file%dimensions(d)%variable_id, return_value ) 3071 3086 3072 3087 ENDIF … … 3076 3091 !-- Write dimension attributes 3077 3092 DO a = 1, SIZE( file%dimensions(d)%attributes ) 3078 return_value = write_attribute( file%format, file%id, file%name, &3079 variable_id=file%dimensions(d)%variable_id,&3080 variable_name=file%dimensions(d)%name,&3081 attribute=file%dimensions(d)%attributes(a) )3093 return_value = write_attribute( file%format, file%id, file%name, & 3094 variable_id=file%dimensions(d)%variable_id, & 3095 variable_name=file%dimensions(d)%name, & 3096 attribute=file%dimensions(d)%attributes(a) ) 3082 3097 IF ( return_value /= 0 ) EXIT 3083 3098 ENDDO … … 3089 3104 ! 3090 3105 !-- Save dimension IDs for variables wihtin database 3091 IF ( return_value == 0 ) &3106 IF ( return_value == 0 ) & 3092 3107 CALL collect_dimesion_ids_for_variables( file%name, file%variables, file%dimensions, & 3093 3108 return_value ) … … 3097 3112 DO d = 1, SIZE( file%variables ) 3098 3113 3099 CALL init_file_variable( file%format, file%id, file%name, &3100 file%variables(d)%id, file%variables(d)%name, file%variables(d)%data_type, &3101 file%variables(d)%dimension_ids, &3114 CALL init_file_variable( file%format, file%id, file%name, & 3115 file%variables(d)%id, file%variables(d)%name, file%variables(d)%data_type, & 3116 file%variables(d)%dimension_ids, & 3102 3117 file%variables(d)%is_global, return_value ) 3103 3118 … … 3106 3121 !-- Write variable attributes 3107 3122 DO a = 1, SIZE( file%variables(d)%attributes ) 3108 return_value = write_attribute( file%format, file%id, file%name, &3109 variable_id=file%variables(d)%id,&3110 variable_name=file%variables(d)%name,&3111 attribute=file%variables(d)%attributes(a) )3123 return_value = write_attribute( file%format, file%id, file%name, & 3124 variable_id=file%variables(d)%id, & 3125 variable_name=file%variables(d)%name, & 3126 attribute=file%variables(d)%attributes(a) ) 3112 3127 IF ( return_value /= 0 ) EXIT 3113 3128 ENDDO … … 3128 3143 !> Initialize dimension in file. 3129 3144 !--------------------------------------------------------------------------------------------------! 3130 SUBROUTINE init_file_dimension( file_format, file_id, file_name, & 3131 dimension_id, dimension_name, dimension_type, dimension_length, & 3132 variable_id, return_value ) 3145 SUBROUTINE init_file_dimension( file_format, file_id, file_name, & 3146 dimension_id, dimension_name, dimension_type, dimension_length, & 3147 variable_id, return_value ) 3148 3149 CHARACTER(LEN=*), PARAMETER :: routine_name = 'init_file_dimension' !< file format chosen for file 3133 3150 3134 3151 CHARACTER(LEN=*), INTENT(IN) :: dimension_name !< name of dimension … … 3136 3153 CHARACTER(LEN=*), INTENT(IN) :: file_format !< file format chosen for file 3137 3154 CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file 3138 3139 CHARACTER(LEN=*), PARAMETER :: routine_name = 'init_file_dimension' !< file format chosen for file3140 3155 3141 3156 INTEGER, INTENT(OUT) :: dimension_id !< dimension ID … … 3150 3165 output_return_value = 0 3151 3166 3152 temp_string = '(file "' // TRIM( file_name ) // &3167 temp_string = '(file "' // TRIM( file_name ) // & 3153 3168 '", dimension "' // TRIM( dimension_name ) // '")' 3154 3169 … … 3156 3171 3157 3172 CASE ( 'binary' ) 3158 CALL binary_init_dimension( 'binary', file_id, dimension_id, variable_id, &3159 dimension_name, dimension_type, dimension_length,&3160 return_value=output_return_value )3173 CALL binary_init_dimension( 'binary', file_id, dimension_id, variable_id, & 3174 dimension_name, dimension_type, dimension_length, & 3175 return_value=output_return_value ) 3161 3176 3162 3177 CASE ( 'netcdf4-serial' ) 3163 CALL netcdf4_init_dimension( 'serial', file_id, dimension_id, variable_id, &3164 dimension_name, dimension_type, dimension_length,&3165 return_value=output_return_value )3178 CALL netcdf4_init_dimension( 'serial', file_id, dimension_id, variable_id, & 3179 dimension_name, dimension_type, dimension_length, & 3180 return_value=output_return_value ) 3166 3181 3167 3182 CASE ( 'netcdf4-parallel' ) 3168 CALL netcdf4_init_dimension( 'parallel', file_id, dimension_id, variable_id, &3169 dimension_name, dimension_type, dimension_length,&3170 return_value=output_return_value )3183 CALL netcdf4_init_dimension( 'parallel', file_id, dimension_id, variable_id, & 3184 dimension_name, dimension_type, dimension_length, & 3185 return_value=output_return_value ) 3171 3186 3172 3187 CASE DEFAULT 3173 3188 return_value = 1 3174 CALL internal_message( 'error', routine_name // &3175 ': file format "' // TRIM( file_format ) // &3189 CALL internal_message( 'error', routine_name // & 3190 ': file format "' // TRIM( file_format ) // & 3176 3191 '" not supported ' // TRIM( temp_string ) ) 3177 3192 … … 3180 3195 IF ( output_return_value /= 0 ) THEN 3181 3196 return_value = output_return_value 3182 CALL internal_message( 'error', routine_name // &3197 CALL internal_message( 'error', routine_name // & 3183 3198 ': error while defining dimension ' // TRIM( temp_string ) ) 3184 3199 ENDIF … … 3191 3206 !> Initialize variable. 3192 3207 !--------------------------------------------------------------------------------------------------! 3193 SUBROUTINE init_file_variable( file_format, file_id, file_name, &3194 variable_id, variable_name, variable_type, dimension_ids, &3208 SUBROUTINE init_file_variable( file_format, file_id, file_name, & 3209 variable_id, variable_name, variable_type, dimension_ids, & 3195 3210 is_global, return_value ) 3211 3212 CHARACTER(LEN=*), PARAMETER :: routine_name = 'init_file_variable' !< file format chosen for file 3196 3213 3197 3214 CHARACTER(LEN=*), INTENT(IN) :: file_format !< file format chosen for file … … 3200 3217 CHARACTER(LEN=*), INTENT(IN) :: variable_type !< data type of variable 3201 3218 3202 CHARACTER(LEN=*), PARAMETER :: routine_name = 'init_file_variable' !< file format chosen for file3203 3204 3219 INTEGER, INTENT(IN) :: file_id !< file ID 3205 3220 INTEGER :: output_return_value !< return value of a called output routine … … 3221 3236 3222 3237 CASE ( 'binary' ) 3223 CALL binary_init_variable( 'binary', file_id, variable_id, variable_name, &3238 CALL binary_init_variable( 'binary', file_id, variable_id, variable_name, & 3224 3239 variable_type, dimension_ids, is_global, return_value=output_return_value ) 3225 3240 3226 3241 CASE ( 'netcdf4-serial' ) 3227 CALL netcdf4_init_variable( 'serial', file_id, variable_id, variable_name, &3242 CALL netcdf4_init_variable( 'serial', file_id, variable_id, variable_name, & 3228 3243 variable_type, dimension_ids, is_global, return_value=output_return_value ) 3229 3244 3230 3245 CASE ( 'netcdf4-parallel' ) 3231 CALL netcdf4_init_variable( 'parallel', file_id, variable_id, variable_name, &3246 CALL netcdf4_init_variable( 'parallel', file_id, variable_id, variable_name, & 3232 3247 variable_type, dimension_ids, is_global, return_value=output_return_value ) 3233 3248 3234 3249 CASE DEFAULT 3235 3250 return_value = 1 3236 CALL internal_message( 'error', routine_name // &3237 ': file format "' // TRIM( file_format ) // &3251 CALL internal_message( 'error', routine_name // & 3252 ': file format "' // TRIM( file_format ) // & 3238 3253 '" not supported ' // TRIM( temp_string ) ) 3239 3254 … … 3253 3268 !> Write attribute to file. 3254 3269 !--------------------------------------------------------------------------------------------------! 3255 FUNCTION write_attribute( file_format, file_id, file_name, & 3256 variable_id, variable_name, attribute ) RESULT( return_value ) 3270 FUNCTION write_attribute( file_format, file_id, file_name, variable_id, variable_name, attribute )& 3271 RESULT( return_value ) 3272 3273 CHARACTER(LEN=*), PARAMETER :: routine_name = 'write_attribute' !< file format chosen for file 3257 3274 3258 3275 CHARACTER(LEN=*), INTENT(IN) :: file_format !< file format chosen for file … … 3260 3277 CHARACTER(LEN=*), INTENT(IN) :: variable_name !< variable name 3261 3278 3262 CHARACTER(LEN=*), PARAMETER :: routine_name = 'write_attribute' !< file format chosen for file3263 3264 3279 INTEGER, INTENT(IN) :: file_id !< file ID 3280 INTEGER :: output_return_value !< return value of a called output routine 3265 3281 INTEGER :: return_value !< return value 3266 INTEGER :: output_return_value !< return value of a called output routine3267 3282 INTEGER, INTENT(IN) :: variable_id !< variable ID 3268 3283 … … 3274 3289 ! 3275 3290 !-- Prepare for possible error message 3276 temp_string = '(file "' // TRIM( file_name ) // &3277 '", variable "' // TRIM( variable_name ) // &3291 temp_string = '(file "' // TRIM( file_name ) // & 3292 '", variable "' // TRIM( variable_name ) // & 3278 3293 '", attribute "' // TRIM( attribute%name ) // '")' 3279 3294 ! … … 3286 3301 3287 3302 CASE( 'char' ) 3288 CALL binary_write_attribute( file_id=file_id, variable_id=variable_id, &3289 attribute_name=attribute%name, value_char=attribute%value_char, &3303 CALL binary_write_attribute( file_id=file_id, variable_id=variable_id, & 3304 attribute_name=attribute%name, value_char=attribute%value_char, & 3290 3305 return_value=output_return_value ) 3291 3306 3292 3307 CASE( 'int8' ) 3293 CALL binary_write_attribute( file_id=file_id, variable_id=variable_id, &3294 attribute_name=attribute%name, value_int8=attribute%value_int8, &3308 CALL binary_write_attribute( file_id=file_id, variable_id=variable_id, & 3309 attribute_name=attribute%name, value_int8=attribute%value_int8, & 3295 3310 return_value=output_return_value ) 3296 3311 3297 3312 CASE( 'int16' ) 3298 CALL binary_write_attribute( file_id=file_id, variable_id=variable_id, &3299 attribute_name=attribute%name, value_int16=attribute%value_int16, &3313 CALL binary_write_attribute( file_id=file_id, variable_id=variable_id, & 3314 attribute_name=attribute%name, value_int16=attribute%value_int16, & 3300 3315 return_value=output_return_value ) 3301 3316 3302 3317 CASE( 'int32' ) 3303 CALL binary_write_attribute( file_id=file_id, variable_id=variable_id, &3304 attribute_name=attribute%name, value_int32=attribute%value_int32, &3318 CALL binary_write_attribute( file_id=file_id, variable_id=variable_id, & 3319 attribute_name=attribute%name, value_int32=attribute%value_int32, & 3305 3320 return_value=output_return_value ) 3306 3321 3307 3322 CASE( 'real32' ) 3308 CALL binary_write_attribute( file_id=file_id, variable_id=variable_id, &3309 attribute_name=attribute%name, value_real32=attribute%value_real32, &3323 CALL binary_write_attribute( file_id=file_id, variable_id=variable_id, & 3324 attribute_name=attribute%name, value_real32=attribute%value_real32, & 3310 3325 return_value=output_return_value ) 3311 3326 3312 3327 CASE( 'real64' ) 3313 CALL binary_write_attribute( file_id=file_id, variable_id=variable_id, &3314 attribute_name=attribute%name, value_real64=attribute%value_real64, &3328 CALL binary_write_attribute( file_id=file_id, variable_id=variable_id, & 3329 attribute_name=attribute%name, value_real64=attribute%value_real64, & 3315 3330 return_value=output_return_value ) 3316 3331 3317 3332 CASE DEFAULT 3318 3333 return_value = 1 3319 CALL internal_message( 'error', routine_name // &3320 ': file format "' // TRIM( file_format ) // &3321 '" does not support attribute data type "'// &3322 TRIM( attribute%data_type ) // &3334 CALL internal_message( 'error', routine_name // & 3335 ': file format "' // TRIM( file_format ) // & 3336 '" does not support attribute data type "'// & 3337 TRIM( attribute%data_type ) // & 3323 3338 '" ' // TRIM( temp_string ) ) 3324 3339 … … 3330 3345 3331 3346 CASE( 'char' ) 3332 CALL netcdf4_write_attribute( file_id=file_id, variable_id=variable_id, &3333 attribute_name=attribute%name, value_char=attribute%value_char, &3347 CALL netcdf4_write_attribute( file_id=file_id, variable_id=variable_id, & 3348 attribute_name=attribute%name, value_char=attribute%value_char, & 3334 3349 return_value=output_return_value ) 3335 3350 3336 3351 CASE( 'int8' ) 3337 CALL netcdf4_write_attribute( file_id=file_id, variable_id=variable_id, &3338 attribute_name=attribute%name, value_int8=attribute%value_int8, &3352 CALL netcdf4_write_attribute( file_id=file_id, variable_id=variable_id, & 3353 attribute_name=attribute%name, value_int8=attribute%value_int8, & 3339 3354 return_value=output_return_value ) 3340 3355 3341 3356 CASE( 'int16' ) 3342 CALL netcdf4_write_attribute( file_id=file_id, variable_id=variable_id, &3343 attribute_name=attribute%name, value_int16=attribute%value_int16, &3357 CALL netcdf4_write_attribute( file_id=file_id, variable_id=variable_id, & 3358 attribute_name=attribute%name, value_int16=attribute%value_int16, & 3344 3359 return_value=output_return_value ) 3345 3360 3346 3361 CASE( 'int32' ) 3347 CALL netcdf4_write_attribute( file_id=file_id, variable_id=variable_id, &3348 attribute_name=attribute%name, value_int32=attribute%value_int32, &3362 CALL netcdf4_write_attribute( file_id=file_id, variable_id=variable_id, & 3363 attribute_name=attribute%name, value_int32=attribute%value_int32, & 3349 3364 return_value=output_return_value ) 3350 3365 3351 3366 CASE( 'real32' ) 3352 CALL netcdf4_write_attribute( file_id=file_id, variable_id=variable_id, &3353 attribute_name=attribute%name, value_real32=attribute%value_real32, &3367 CALL netcdf4_write_attribute( file_id=file_id, variable_id=variable_id, & 3368 attribute_name=attribute%name, value_real32=attribute%value_real32, & 3354 3369 return_value=output_return_value ) 3355 3370 3356 3371 CASE( 'real64' ) 3357 CALL netcdf4_write_attribute( file_id=file_id, variable_id=variable_id, &3358 attribute_name=attribute%name, value_real64=attribute%value_real64, &3372 CALL netcdf4_write_attribute( file_id=file_id, variable_id=variable_id, & 3373 attribute_name=attribute%name, value_real64=attribute%value_real64, & 3359 3374 return_value=output_return_value ) 3360 3375 3361 3376 CASE DEFAULT 3362 3377 return_value = 1 3363 CALL internal_message( 'error', routine_name // &3364 ': file format "' // TRIM( file_format ) // &3365 '" does not support attribute data type "'// &3366 TRIM( attribute%data_type ) // &3378 CALL internal_message( 'error', routine_name // & 3379 ': file format "' // TRIM( file_format ) // & 3380 '" does not support attribute data type "'// & 3381 TRIM( attribute%data_type ) // & 3367 3382 '" ' // TRIM( temp_string ) ) 3368 3383 … … 3371 3386 CASE DEFAULT 3372 3387 return_value = 1 3373 CALL internal_message( 'error', routine_name // &3374 ': unsupported file format "' // TRIM( file_format ) // &3388 CALL internal_message( 'error', routine_name // & 3389 ': unsupported file format "' // TRIM( file_format ) // & 3375 3390 '" ' // TRIM( temp_string ) ) 3376 3391 … … 3379 3394 IF ( output_return_value /= 0 ) THEN 3380 3395 return_value = output_return_value 3381 CALL internal_message( 'error', routine_name // &3396 CALL internal_message( 'error', routine_name // & 3382 3397 ': error while writing attribute ' // TRIM( temp_string ) ) 3383 3398 ENDIF … … 3392 3407 SUBROUTINE collect_dimesion_ids_for_variables( file_name, variables, dimensions, return_value ) 3393 3408 3409 CHARACTER(LEN=*), PARAMETER :: routine_name = 'collect_dimesion_ids_for_variables' !< file format chosen for file 3410 3394 3411 CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file 3395 3396 CHARACTER(LEN=*), PARAMETER :: routine_name = 'collect_dimesion_ids_for_variables' !< file format chosen for file3397 3412 3398 3413 INTEGER :: d !< loop index … … 3403 3418 INTEGER, INTENT(OUT) :: return_value !< return value 3404 3419 3405 LOGICAL :: found = .F alse. !< true if dimension required by variable was found in dimension list3420 LOGICAL :: found = .FALSE. !< true if dimension required by variable was found in dimension list 3406 3421 3407 3422 TYPE(dimension_type), DIMENSION(:), INTENT(IN) :: dimensions !< list of dimensions in file … … 3426 3441 IF ( .NOT. found ) THEN 3427 3442 return_value = 1 3428 CALL internal_message( 'error', routine_name // &3429 ': required dimension "' // TRIM( variables(i)%dimension_names(j) ) // &3430 '" is undefined (variable "' // TRIM( variables(i)%name ) // &3443 CALL internal_message( 'error', routine_name // & 3444 ': required dimension "' // TRIM( variables(i)%dimension_names(j) ) // & 3445 '" is undefined (variable "' // TRIM( variables(i)%name ) // & 3431 3446 '", file "' // TRIM( file_name ) // '")!' ) 3432 3447 EXIT … … 3447 3462 SUBROUTINE stop_file_header_definition( file_format, file_id, file_name, return_value ) 3448 3463 3464 CHARACTER(LEN=*), PARAMETER :: routine_name = 'stop_file_header_definition' !< name of routine 3465 3449 3466 CHARACTER(LEN=*), INTENT(IN) :: file_format !< file format 3450 3467 CHARACTER(LEN=*), INTENT(IN) :: file_name !< file name 3451 3452 CHARACTER(LEN=*), PARAMETER :: routine_name = 'stop_file_header_definition' !< name of routine3453 3468 3454 3469 INTEGER, INTENT(IN) :: file_id !< file id … … 3472 3487 CASE DEFAULT 3473 3488 return_value = 1 3474 CALL internal_message( 'error', routine_name // &3475 ': file format "' // TRIM( file_format ) // &3489 CALL internal_message( 'error', routine_name // & 3490 ': file format "' // TRIM( file_format ) // & 3476 3491 '" not supported ' // TRIM( temp_string ) ) 3477 3492 … … 3480 3495 IF ( output_return_value /= 0 ) THEN 3481 3496 return_value = output_return_value 3482 CALL internal_message( 'error', routine_name // &3483 ': error while leaving file-definition state ' // &3497 CALL internal_message( 'error', routine_name // & 3498 ': error while leaving file-definition state ' // & 3484 3499 TRIM( temp_string ) ) 3485 3500 ENDIF … … 3494 3509 !> Find a requested variable 'variable_name' and its used dimensions in requested file 'file_name'. 3495 3510 !--------------------------------------------------------------------------------------------------! 3496 SUBROUTINE find_var_in_file( file_name, variable_name, file_format, file_id, variable_id, &3511 SUBROUTINE find_var_in_file( file_name, variable_name, file_format, file_id, variable_id, & 3497 3512 is_global, dimensions, return_value ) 3513 3514 CHARACTER(LEN=*), PARAMETER :: routine_name = 'find_var_in_file' !< name of routine 3498 3515 3499 3516 CHARACTER(LEN=charlen), INTENT(OUT) :: file_format !< file format chosen for file 3500 3517 CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file 3501 3518 CHARACTER(LEN=*), INTENT(IN) :: variable_name !< name of variable 3502 3503 CHARACTER(LEN=*), PARAMETER :: routine_name = 'find_var_in_file' !< name of routine3504 3519 3505 3520 INTEGER :: d !< loop index … … 3526 3541 IF ( .NOT. files(f)%is_init ) THEN 3527 3542 return_value = 1 3528 CALL internal_message( 'error', routine_name // &3529 ': file not initialized. ' // &3530 'Writing variable to file is impossible ' // &3531 '(variable "' // TRIM( variable_name ) // &3543 CALL internal_message( 'error', routine_name // & 3544 ': file not initialized. ' // & 3545 'Writing variable to file is impossible ' // & 3546 '(variable "' // TRIM( variable_name ) // & 3532 3547 '", file "' // TRIM( file_name ) // '")!' ) 3533 3548 EXIT … … 3591 3606 IF ( .NOT. found ) THEN 3592 3607 return_value = 1 3593 CALL internal_message( 'error', routine_name // &3594 ': variable not found in file ' // &3595 '(variable "' // TRIM( variable_name ) // &3608 CALL internal_message( 'error', routine_name // & 3609 ': variable not found in file ' // & 3610 '(variable "' // TRIM( variable_name ) // & 3596 3611 '", file "' // TRIM( file_name ) // '")!' ) 3597 3612 ENDIF … … 3604 3619 IF ( .NOT. found .AND. return_value == 0 ) THEN 3605 3620 return_value = 1 3606 CALL internal_message( 'error', routine_name // &3607 ': file not found ' // &3608 '(variable "' // TRIM( variable_name ) // &3621 CALL internal_message( 'error', routine_name // & 3622 ': file not found ' // & 3623 '(variable "' // TRIM( variable_name ) // & 3609 3624 '", file "' // TRIM( file_name ) // '")!' ) 3610 3625 ENDIF … … 3622 3637 !> starts and origins are set to zero for all dimensions. 3623 3638 !--------------------------------------------------------------------------------------------------! 3624 SUBROUTINE get_masked_indices_and_masked_dimension_bounds( &3625 dimensions, bounds_start, bounds_end, bounds_masked_start, value_counts, &3639 SUBROUTINE get_masked_indices_and_masked_dimension_bounds( & 3640 dimensions, bounds_start, bounds_end, bounds_masked_start, value_counts, & 3626 3641 bounds_origin, masked_indices ) 3627 3642 … … 3656 3671 !-- Find number of masked values within given variable bounds 3657 3672 value_counts(d) = 0 3658 DO i = LBOUND( dimensions(d)%masked_indices, DIM=1 ), &3673 DO i = LBOUND( dimensions(d)%masked_indices, DIM=1 ), & 3659 3674 UBOUND( dimensions(d)%masked_indices, DIM=1 ) 3660 3675 ! 3661 3676 !-- Is masked index within given bounds? 3662 IF ( dimensions(d)%masked_indices(i) >= bounds_start(d) .AND. &3677 IF ( dimensions(d)%masked_indices(i) >= bounds_start(d) .AND. & 3663 3678 dimensions(d)%masked_indices(i) <= bounds_end(d) ) THEN 3664 3679 ! … … 3702 3717 ! Description: 3703 3718 ! ------------ 3704 !> Message routine writing debug information into the debug file 3705 !> or creating the error messagestring.3719 !> Message routine writing debug information into the debug file or creating the error message 3720 !> string. 3706 3721 !--------------------------------------------------------------------------------------------------! 3707 3722 SUBROUTINE internal_message( level, string ) … … 3733 3748 3734 3749 CHARACTER(LEN=*), PARAMETER :: separation_string = '---' !< string separating blocks in output 3750 CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_database_debug_output' !< name of this routine 3751 3752 INTEGER, PARAMETER :: indent_depth = 3 !< space per indentation 3753 INTEGER, PARAMETER :: max_keyname_length = 6 !< length of longest key name 3754 3735 3755 CHARACTER(LEN=50) :: write_format1 !< format for write statements 3736 CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_database_debug_output' !< name of this routine3737 3756 3738 3757 INTEGER :: f !< loop index 3739 INTEGER, PARAMETER :: indent_depth = 3 !< space per indentation3740 3758 INTEGER :: indent_level !< indentation level 3741 INTEGER, PARAMETER :: max_keyname_length = 6 !< length of longest key name3742 3759 INTEGER :: natts !< number of attributes 3743 3760 INTEGER :: ndims !< number of dimensions … … 3750 3767 WRITE( debug_output_unit, '(A)' ) REPEAT( separation_string // ' ', 4 ) 3751 3768 3752 IF ( .NOT. ALLOCATED( files ) .OR.nfiles == 0 ) THEN3769 IF ( .NOT. ALLOCATED( files ) .OR. nfiles == 0 ) THEN 3753 3770 3754 3771 WRITE( debug_output_unit, '(A)' ) 'database is empty' … … 3757 3774 3758 3775 indent_level = 1 3759 WRITE( write_format1, '(A,I3,A,I3,A)' ) '(T', indent_level * indent_depth + 1, ',A,T', &3760 indent_level * indent_depth + 1 + max_keyname_length, &3761 ',(": ")'3776 WRITE( write_format1, '(A,I3,A,I3,A)' ) '(T', indent_level * indent_depth + 1, ',A,T', & 3777 indent_level * indent_depth + 1 + max_keyname_length, & 3778 ',(": ")' 3762 3779 3763 3780 DO f = 1, nfiles … … 3791 3808 CONTAINS 3792 3809 3793 !-------------------------------------------------------------------------------------------- !3794 3795 3796 3797 !-------------------------------------------------------------------------------------------- !3810 !--------------------------------------------------------------------------------------------------! 3811 ! Description: 3812 ! ------------ 3813 !> Print list of attributes. 3814 !--------------------------------------------------------------------------------------------------! 3798 3815 SUBROUTINE print_attributes( indent_level, attributes ) 3816 3817 INTEGER, PARAMETER :: max_keyname_length = 6 !< length of longest key name 3799 3818 3800 3819 CHARACTER(LEN=50) :: write_format1 !< format for write statements … … 3803 3822 INTEGER :: i !< loop index 3804 3823 INTEGER, INTENT(IN) :: indent_level !< indentation level 3805 INTEGER, PARAMETER :: max_keyname_length = 6 !< length of longest key name3806 3824 INTEGER :: nelement !< number of elements to print 3807 3825 … … 3810 3828 3811 3829 WRITE( write_format1, '(A,I3,A)' ) '(T', indent_level * indent_depth + 1, ',A' 3812 WRITE( write_format2, '(A,I3,A,I3,A)' ) &3813 '(T', ( indent_level + 1 ) * indent_depth + 1, ',A,T', &3830 WRITE( write_format2, '(A,I3,A,I3,A)' ) & 3831 '(T', ( indent_level + 1 ) * indent_depth + 1, ',A,T', & 3814 3832 ( indent_level + 1 ) * indent_depth + 1 + max_keyname_length, ',(": ")' 3815 3833 3816 WRITE( debug_output_unit, TRIM( write_format1 ) // ',A)' ) &3834 WRITE( debug_output_unit, TRIM( write_format1 ) // ',A)' ) & 3817 3835 REPEAT( separation_string // ' ', 4 ) 3818 3836 WRITE( debug_output_unit, TRIM( write_format1 ) // ')' ) 'attributes:' … … 3820 3838 nelement = SIZE( attributes ) 3821 3839 DO i = 1, nelement 3822 WRITE( debug_output_unit, TRIM( write_format2 ) // ',A)' ) &3840 WRITE( debug_output_unit, TRIM( write_format2 ) // ',A)' ) & 3823 3841 'name', TRIM( attributes(i)%name ) 3824 WRITE( debug_output_unit, TRIM( write_format2 ) // ',A)' ) &3842 WRITE( debug_output_unit, TRIM( write_format2 ) // ',A)' ) & 3825 3843 'type', TRIM( attributes(i)%data_type ) 3826 3844 3827 3845 IF ( TRIM( attributes(i)%data_type ) == 'char' ) THEN 3828 WRITE( debug_output_unit, TRIM( write_format2 ) // ',A)' ) &3846 WRITE( debug_output_unit, TRIM( write_format2 ) // ',A)' ) & 3829 3847 'value', TRIM( attributes(i)%value_char ) 3830 3848 ELSEIF ( TRIM( attributes(i)%data_type ) == 'int8' ) THEN 3831 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I4)' ) &3849 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I4)' ) & 3832 3850 'value', attributes(i)%value_int8 3833 3851 ELSEIF ( TRIM( attributes(i)%data_type ) == 'int16' ) THEN 3834 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I6)' ) &3852 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I6)' ) & 3835 3853 'value', attributes(i)%value_int16 3836 3854 ELSEIF ( TRIM( attributes(i)%data_type ) == 'int32' ) THEN 3837 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I11)' ) &3855 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I11)' ) & 3838 3856 'value', attributes(i)%value_int32 3839 3857 ELSEIF ( TRIM( attributes(i)%data_type ) == 'real32' ) THEN 3840 WRITE( debug_output_unit, TRIM( write_format2 ) // ',E14.7)' ) &3858 WRITE( debug_output_unit, TRIM( write_format2 ) // ',E14.7)' ) & 3841 3859 'value', attributes(i)%value_real32 3842 3860 ELSEIF ( TRIM(attributes(i)%data_type) == 'real64' ) THEN 3843 WRITE( debug_output_unit, TRIM( write_format2 ) // ',E22.15)' ) &3861 WRITE( debug_output_unit, TRIM( write_format2 ) // ',E22.15)' ) & 3844 3862 'value', attributes(i)%value_real64 3845 3863 ENDIF 3846 IF ( i < nelement ) &3864 IF ( i < nelement ) & 3847 3865 WRITE( debug_output_unit, TRIM( write_format1 ) // ')' ) separation_string 3848 3866 ENDDO … … 3850 3868 END SUBROUTINE print_attributes 3851 3869 3852 !-------------------------------------------------------------------------------------------- !3853 3854 3855 3856 !-------------------------------------------------------------------------------------------- !3870 !--------------------------------------------------------------------------------------------------! 3871 ! Description: 3872 ! ------------ 3873 !> Print list of dimensions. 3874 !--------------------------------------------------------------------------------------------------! 3857 3875 SUBROUTINE print_dimensions( indent_level, dimensions ) 3876 3877 INTEGER, PARAMETER :: max_keyname_length = 15 !< length of longest key name 3858 3878 3859 3879 CHARACTER(LEN=50) :: write_format1 !< format for write statements … … 3863 3883 INTEGER, INTENT(IN) :: indent_level !< indentation level 3864 3884 INTEGER :: j !< loop index 3865 INTEGER, PARAMETER :: max_keyname_length = 15 !< length of longest key name3866 3885 INTEGER :: nelement !< number of elements to print 3867 3886 … … 3872 3891 3873 3892 WRITE( write_format1, '(A,I3,A)' ) '(T', indent_level * indent_depth + 1, ',A' 3874 WRITE( write_format2, '(A,I3,A,I3,A)' ) &3875 '(T', ( indent_level + 1 ) * indent_depth + 1, ',A,T', &3893 WRITE( write_format2, '(A,I3,A,I3,A)' ) & 3894 '(T', ( indent_level + 1 ) * indent_depth + 1, ',A,T', & 3876 3895 ( indent_level + 1 ) * indent_depth + 1 + max_keyname_length, ',(": ")' 3877 3896 3878 WRITE( debug_output_unit, TRIM( write_format1 ) // ',A)' ) &3897 WRITE( debug_output_unit, TRIM( write_format1 ) // ',A)' ) & 3879 3898 REPEAT( separation_string // ' ', 4 ) 3880 3899 WRITE( debug_output_unit, TRIM( write_format1 ) // ')' ) 'dimensions:' … … 3885 3904 ! 3886 3905 !-- Print general information 3887 WRITE( debug_output_unit, TRIM( write_format2 ) // ',A)' ) &3906 WRITE( debug_output_unit, TRIM( write_format2 ) // ',A)' ) & 3888 3907 'name', TRIM( dimensions(i)%name ) 3889 WRITE( debug_output_unit, TRIM( write_format2 ) // ',A)' ) &3908 WRITE( debug_output_unit, TRIM( write_format2 ) // ',A)' ) & 3890 3909 'type', TRIM( dimensions(i)%data_type ) 3891 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I7)' ) &3910 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I7)' ) & 3892 3911 'id', dimensions(i)%id 3893 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I7)' ) &3912 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I7)' ) & 3894 3913 'length', dimensions(i)%length 3895 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I7,A,I7)' ) &3914 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I7,A,I7)' ) & 3896 3915 'bounds', dimensions(i)%bounds(1), ',', dimensions(i)%bounds(2) 3897 WRITE( debug_output_unit, TRIM( write_format2 ) // ',L1)' ) &3916 WRITE( debug_output_unit, TRIM( write_format2 ) // ',L1)' ) & 3898 3917 'is masked', dimensions(i)%is_masked 3899 3918 ! 3900 3919 !-- Print information about mask 3901 3920 IF ( is_masked ) THEN 3902 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I7)' ) &3921 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I7)' ) & 3903 3922 'masked length', dimensions(i)%length_mask 3904 3923 3905 WRITE( debug_output_unit, TRIM( write_format2 ) // ',L1)', ADVANCE='no' ) &3924 WRITE( debug_output_unit, TRIM( write_format2 ) // ',L1)', ADVANCE='no' ) & 3906 3925 'mask', dimensions(i)%mask(dimensions(i)%bounds(1)) 3907 3926 DO j = dimensions(i)%bounds(1)+1, dimensions(i)%bounds(2) … … 3910 3929 WRITE( debug_output_unit, '(A)' ) '' ! write line-end 3911 3930 3912 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I6)', ADVANCE='no' ) &3931 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I6)', ADVANCE='no' ) & 3913 3932 'masked indices', dimensions(i)%masked_indices(0) 3914 3933 DO j = 1, dimensions(i)%length_mask-1 3915 WRITE( debug_output_unit, '(A,I6)', ADVANCE='no' ) &3934 WRITE( debug_output_unit, '(A,I6)', ADVANCE='no' ) & 3916 3935 ',', dimensions(i)%masked_indices(j) 3917 3936 ENDDO … … 3922 3941 IF ( ALLOCATED( dimensions(i)%values_int8 ) ) THEN 3923 3942 3924 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I4)', ADVANCE='no' ) &3943 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I4)', ADVANCE='no' ) & 3925 3944 'values', dimensions(i)%values_int8(dimensions(i)%bounds(1)) 3926 3945 DO j = dimensions(i)%bounds(1)+1, dimensions(i)%bounds(2) 3927 WRITE( debug_output_unit, '(A,I4)', ADVANCE='no' ) &3946 WRITE( debug_output_unit, '(A,I4)', ADVANCE='no' ) & 3928 3947 ',', dimensions(i)%values_int8(j) 3929 3948 ENDDO 3930 3949 WRITE( debug_output_unit, '(A)' ) '' ! write line-end 3931 3950 IF ( is_masked ) THEN 3932 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I4)', ADVANCE='no' ) &3951 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I4)', ADVANCE='no' ) & 3933 3952 'masked values', dimensions(i)%masked_values_int8(0) 3934 3953 DO j = 1, dimensions(i)%length_mask-1 3935 WRITE( debug_output_unit, '(A,I4)', ADVANCE='no' ) &3954 WRITE( debug_output_unit, '(A,I4)', ADVANCE='no' ) & 3936 3955 ',', dimensions(i)%masked_values_int8(j) 3937 3956 ENDDO … … 3941 3960 ELSEIF ( ALLOCATED( dimensions(i)%values_int16 ) ) THEN 3942 3961 3943 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I6)', ADVANCE='no' ) &3962 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I6)', ADVANCE='no' ) & 3944 3963 'values', dimensions(i)%values_int16(dimensions(i)%bounds(1)) 3945 3964 DO j = dimensions(i)%bounds(1)+1, dimensions(i)%bounds(2) 3946 WRITE( debug_output_unit, '(A,I6)', ADVANCE='no' ) &3965 WRITE( debug_output_unit, '(A,I6)', ADVANCE='no' ) & 3947 3966 ',', dimensions(i)%values_int16(j) 3948 3967 ENDDO 3949 3968 WRITE( debug_output_unit, '(A)' ) '' ! write line-end 3950 3969 IF ( is_masked ) THEN 3951 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I6)', ADVANCE='no' ) &3970 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I6)', ADVANCE='no' ) & 3952 3971 'masked values', dimensions(i)%masked_values_int16(0) 3953 3972 DO j = 1, dimensions(i)%length_mask-1 3954 WRITE( debug_output_unit, '(A,I6)', ADVANCE='no' ) &3973 WRITE( debug_output_unit, '(A,I6)', ADVANCE='no' ) & 3955 3974 ',', dimensions(i)%masked_values_int16(j) 3956 3975 ENDDO … … 3960 3979 ELSEIF ( ALLOCATED( dimensions(i)%values_int32 ) ) THEN 3961 3980 3962 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I11)', ADVANCE='no' ) &3981 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I11)', ADVANCE='no' ) & 3963 3982 'values', dimensions(i)%values_int32(dimensions(i)%bounds(1)) 3964 3983 DO j = dimensions(i)%bounds(1)+1, dimensions(i)%bounds(2) 3965 WRITE( debug_output_unit, '(A,I11)', ADVANCE='no' ) &3984 WRITE( debug_output_unit, '(A,I11)', ADVANCE='no' ) & 3966 3985 ',', dimensions(i)%values_int32(j) 3967 3986 ENDDO 3968 3987 WRITE( debug_output_unit, '(A)' ) '' ! write line-end 3969 3988 IF ( is_masked ) THEN 3970 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I11)', ADVANCE='no' ) &3989 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I11)', ADVANCE='no' ) & 3971 3990 'masked values', dimensions(i)%masked_values_int32(0) 3972 3991 DO j = 1, dimensions(i)%length_mask-1 3973 WRITE( debug_output_unit, '(A,I11)', ADVANCE='no' ) &3992 WRITE( debug_output_unit, '(A,I11)', ADVANCE='no' ) & 3974 3993 ',', dimensions(i)%masked_values_int32(j) 3975 3994 ENDDO … … 3979 3998 ELSEIF ( ALLOCATED( dimensions(i)%values_intwp ) ) THEN 3980 3999 3981 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I11)', ADVANCE='no' ) &4000 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I11)', ADVANCE='no' ) & 3982 4001 'values', dimensions(i)%values_intwp(dimensions(i)%bounds(1)) 3983 4002 DO j = dimensions(i)%bounds(1)+1, dimensions(i)%bounds(2) 3984 WRITE( debug_output_unit, '(A,I11)', ADVANCE='no' ) &4003 WRITE( debug_output_unit, '(A,I11)', ADVANCE='no' ) & 3985 4004 ',', dimensions(i)%values_intwp(j) 3986 4005 ENDDO 3987 4006 WRITE( debug_output_unit, '(A)' ) '' ! write line-end 3988 4007 IF ( is_masked ) THEN 3989 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I11)', ADVANCE='no' ) &4008 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I11)', ADVANCE='no' ) & 3990 4009 'masked values', dimensions(i)%masked_values_intwp(0) 3991 4010 DO j = 1, dimensions(i)%length_mask-1 3992 WRITE( debug_output_unit, '(A,I11)', ADVANCE='no' ) &4011 WRITE( debug_output_unit, '(A,I11)', ADVANCE='no' ) & 3993 4012 ',', dimensions(i)%masked_values_intwp(j) 3994 4013 ENDDO … … 3998 4017 ELSEIF ( ALLOCATED( dimensions(i)%values_real32 ) ) THEN 3999 4018 4000 WRITE( debug_output_unit, TRIM( write_format2 ) // ',E14.7)', ADVANCE='no' ) &4019 WRITE( debug_output_unit, TRIM( write_format2 ) // ',E14.7)', ADVANCE='no' ) & 4001 4020 'values', dimensions(i)%values_real32(dimensions(i)%bounds(1)) 4002 4021 DO j = dimensions(i)%bounds(1)+1, dimensions(i)%bounds(2) 4003 WRITE( debug_output_unit, '(A,E14.7)', ADVANCE='no' ) &4022 WRITE( debug_output_unit, '(A,E14.7)', ADVANCE='no' ) & 4004 4023 ',', dimensions(i)%values_real32(j) 4005 4024 ENDDO 4006 4025 WRITE( debug_output_unit, '(A)' ) '' ! write line-end 4007 4026 IF ( is_masked ) THEN 4008 WRITE( debug_output_unit, TRIM( write_format2 ) // ',E14.7)', ADVANCE='no' ) &4027 WRITE( debug_output_unit, TRIM( write_format2 ) // ',E14.7)', ADVANCE='no' ) & 4009 4028 'masked values', dimensions(i)%masked_values_real32(0) 4010 4029 DO j = 1, dimensions(i)%length_mask-1 4011 WRITE( debug_output_unit, '(A,E14.7)', ADVANCE='no' ) &4030 WRITE( debug_output_unit, '(A,E14.7)', ADVANCE='no' ) & 4012 4031 ',', dimensions(i)%masked_values_real32(j) 4013 4032 ENDDO … … 4017 4036 ELSEIF ( ALLOCATED( dimensions(i)%values_real64 ) ) THEN 4018 4037 4019 WRITE( debug_output_unit, TRIM( write_format2 ) // ',E22.15)', ADVANCE='no' ) &4038 WRITE( debug_output_unit, TRIM( write_format2 ) // ',E22.15)', ADVANCE='no' ) & 4020 4039 'values', dimensions(i)%values_real64(dimensions(i)%bounds(1)) 4021 4040 DO j = dimensions(i)%bounds(1)+1, dimensions(i)%bounds(2) 4022 WRITE( debug_output_unit, '(A,E22.15)', ADVANCE='no' ) &4041 WRITE( debug_output_unit, '(A,E22.15)', ADVANCE='no' ) & 4023 4042 ',', dimensions(i)%values_real64(j) 4024 4043 ENDDO 4025 4044 WRITE( debug_output_unit, '(A)' ) '' ! write line-end 4026 4045 IF ( is_masked ) THEN 4027 WRITE( debug_output_unit, TRIM( write_format2 ) // ',E22.15)', ADVANCE='no' ) &4046 WRITE( debug_output_unit, TRIM( write_format2 ) // ',E22.15)', ADVANCE='no' ) & 4028 4047 'masked values', dimensions(i)%masked_values_real64(0) 4029 4048 DO j = 1, dimensions(i)%length_mask-1 4030 WRITE( debug_output_unit, '(A,E22.15)', ADVANCE='no' ) &4049 WRITE( debug_output_unit, '(A,E22.15)', ADVANCE='no' ) & 4031 4050 ',', dimensions(i)%masked_values_real64(j) 4032 4051 ENDDO … … 4036 4055 ELSEIF ( ALLOCATED( dimensions(i)%values_realwp ) ) THEN 4037 4056 4038 WRITE( debug_output_unit, TRIM( write_format2 ) // ',E22.15)', ADVANCE='no' ) &4057 WRITE( debug_output_unit, TRIM( write_format2 ) // ',E22.15)', ADVANCE='no' ) & 4039 4058 'values', dimensions(i)%values_realwp(dimensions(i)%bounds(1)) 4040 4059 DO j = dimensions(i)%bounds(1)+1, dimensions(i)%bounds(2) 4041 WRITE( debug_output_unit, '(A,E22.15)', ADVANCE='no' ) &4060 WRITE( debug_output_unit, '(A,E22.15)', ADVANCE='no' ) & 4042 4061 ',', dimensions(i)%values_realwp(j) 4043 4062 ENDDO 4044 4063 WRITE( debug_output_unit, '(A)' ) '' ! write line-end 4045 4064 IF ( is_masked ) THEN 4046 WRITE( debug_output_unit, TRIM( write_format2 ) // ',E22.15)', ADVANCE='no' ) &4065 WRITE( debug_output_unit, TRIM( write_format2 ) // ',E22.15)', ADVANCE='no' ) & 4047 4066 'masked values', dimensions(i)%masked_values_realwp(0) 4048 4067 DO j = 1, dimensions(i)%length_mask-1 4049 WRITE( debug_output_unit, '(A,E22.15)', ADVANCE='no' ) &4068 WRITE( debug_output_unit, '(A,E22.15)', ADVANCE='no' ) & 4050 4069 ',', dimensions(i)%masked_values_realwp(j) 4051 4070 ENDDO … … 4055 4074 ENDIF 4056 4075 4057 IF ( ALLOCATED( dimensions(i)%attributes ) ) &4076 IF ( ALLOCATED( dimensions(i)%attributes ) ) & 4058 4077 CALL print_attributes( indent_level+1, dimensions(i)%attributes ) 4059 4078 4060 IF ( i < nelement ) &4079 IF ( i < nelement ) & 4061 4080 WRITE( debug_output_unit, TRIM( write_format1 ) // ')' ) separation_string 4062 4081 ENDDO … … 4064 4083 END SUBROUTINE print_dimensions 4065 4084 4066 !-------------------------------------------------------------------------------------------- !4067 4068 4069 4070 !-------------------------------------------------------------------------------------------- !4085 !--------------------------------------------------------------------------------------------------! 4086 ! Description: 4087 ! ------------ 4088 !> Print list of variables. 4089 !--------------------------------------------------------------------------------------------------! 4071 4090 SUBROUTINE print_variables( indent_level, variables ) 4091 4092 INTEGER, PARAMETER :: max_keyname_length = 16 !< length of longest key name 4072 4093 4073 4094 CHARACTER(LEN=50) :: write_format1 !< format for write statements … … 4077 4098 INTEGER, INTENT(IN) :: indent_level !< indentation level 4078 4099 INTEGER :: j !< loop index 4079 INTEGER, PARAMETER :: max_keyname_length = 16 !< length of longest key name4080 4100 INTEGER :: nelement !< number of elements to print 4081 4101 … … 4084 4104 4085 4105 WRITE( write_format1, '(A,I3,A)' ) '(T', indent_level * indent_depth + 1, ',A' 4086 WRITE( write_format2, '(A,I3,A,I3,A)' ) &4087 '(T', ( indent_level + 1 ) * indent_depth + 1, ',A,T', &4106 WRITE( write_format2, '(A,I3,A,I3,A)' ) & 4107 '(T', ( indent_level + 1 ) * indent_depth + 1, ',A,T', & 4088 4108 ( indent_level + 1 ) * indent_depth + 1 + max_keyname_length, ',(": ")' 4089 4109 4090 WRITE( debug_output_unit, TRIM( write_format1 ) // ',A)' ) &4110 WRITE( debug_output_unit, TRIM( write_format1 ) // ',A)' ) & 4091 4111 REPEAT( separation_string // ' ', 4 ) 4092 4112 WRITE( debug_output_unit, TRIM( write_format1 ) // ')' ) 'variables:' … … 4094 4114 nelement = SIZE( variables ) 4095 4115 DO i = 1, nelement 4096 WRITE( debug_output_unit, TRIM( write_format2 ) // ',A)' ) &4116 WRITE( debug_output_unit, TRIM( write_format2 ) // ',A)' ) & 4097 4117 'name', TRIM( variables(i)%name ) 4098 WRITE( debug_output_unit, TRIM( write_format2 ) // ',A)' ) &4118 WRITE( debug_output_unit, TRIM( write_format2 ) // ',A)' ) & 4099 4119 'type', TRIM( variables(i)%data_type ) 4100 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I7)' ) &4120 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I7)' ) & 4101 4121 'id', variables(i)%id 4102 WRITE( debug_output_unit, TRIM( write_format2 ) // ',L1)' ) &4122 WRITE( debug_output_unit, TRIM( write_format2 ) // ',L1)' ) & 4103 4123 'is global', variables(i)%is_global 4104 4124 4105 WRITE( debug_output_unit, TRIM( write_format2 ) // ',A)', ADVANCE='no' ) &4125 WRITE( debug_output_unit, TRIM( write_format2 ) // ',A)', ADVANCE='no' ) & 4106 4126 'dimension names', TRIM( variables(i)%dimension_names(1) ) 4107 4127 DO j = 2, SIZE( variables(i)%dimension_names ) 4108 WRITE( debug_output_unit, '(A,A)', ADVANCE='no' ) &4128 WRITE( debug_output_unit, '(A,A)', ADVANCE='no' ) & 4109 4129 ',', TRIM( variables(i)%dimension_names(j) ) 4110 4130 ENDDO 4111 4131 WRITE( debug_output_unit, '(A)' ) '' ! write line-end 4112 4132 4113 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I7)', ADVANCE='no' ) &4133 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I7)', ADVANCE='no' ) & 4114 4134 'dimension ids', variables(i)%dimension_ids(1) 4115 4135 DO j = 2, SIZE( variables(i)%dimension_names ) 4116 WRITE( debug_output_unit, '(A,I7)', ADVANCE='no' ) &4136 WRITE( debug_output_unit, '(A,I7)', ADVANCE='no' ) & 4117 4137 ',', variables(i)%dimension_ids(j) 4118 4138 ENDDO 4119 4139 WRITE( debug_output_unit, '(A)' ) '' ! write line-end 4120 4140 4121 IF ( ALLOCATED( variables(i)%attributes ) ) &4141 IF ( ALLOCATED( variables(i)%attributes ) ) & 4122 4142 CALL print_attributes( indent_level+1, variables(i)%attributes ) 4123 IF ( i < nelement ) &4143 IF ( i < nelement ) & 4124 4144 WRITE( debug_output_unit, TRIM( write_format1 ) // ')' ) separation_string 4125 4145 ENDDO
Note: See TracChangeset
for help on using the changeset viewer.
