1685 & mask, rmask, ie_in, je_in, ke_in, weight, err_msg)
1686 INTEGER,
INTENT(in) :: diag_field_id
1687 CLASS(*),
DIMENSION(:,:,:),
INTENT(in),
TARGET,
CONTIGUOUS :: field
1688 CLASS(*),
INTENT(in),
OPTIONAL :: weight
1689 TYPE (
time_type),
INTENT(in),
OPTIONAL :: time
1690 INTEGER,
INTENT(in),
OPTIONAL :: is_in, js_in, ks_in,ie_in,je_in, ke_in
1691 LOGICAL,
DIMENSION(:,:,:),
INTENT(in),
OPTIONAL,
contiguous,
target :: mask
1692 CLASS(*),
DIMENSION(:,:,:),
INTENT(in),
OPTIONAL,
contiguous,
target :: rmask
1693 CHARACTER(len=*),
INTENT(out),
OPTIONAL :: err_msg
1697 INTEGER :: pow_value
1699 INTEGER :: i, out_num, file_num, n1, n2, n3, number_of_outputs, ii,f1,f2,f3,f4
1700 INTEGER :: freq, units, is, js, ks, ie, je, ke, i1, j1,k1, j, k
1701 INTEGER,
DIMENSION(3) :: l_start
1702 INTEGER,
DIMENSION(3) :: l_end
1712 INTEGER :: numthreads
1713 INTEGER :: active_omp_level
1715 INTEGER :: omp_get_num_threads
1716 INTEGER :: omp_get_level
1718 LOGICAL :: average, phys_window, need_compute
1719 LOGICAL :: reduced_k_range, local_output
1721 LOGICAL :: missvalue_present
1722 LOGICAL,
ALLOCATABLE,
DIMENSION(:,:,:) :: oor_mask
1723 CHARACTER(len=256) :: err_msg_local
1724 CHARACTER(len=128) :: error_string, error_string1
1726 REAL,
ALLOCATABLE,
DIMENSION(:,:,:) :: field_out
1727 class(*),
allocatable,
dimension(:,:,:,:) :: field_remap
1728 logical,
allocatable,
dimension(:,:,:,:) :: mask_remap
1729 class(*),
allocatable,
dimension(:,:,:,:) :: rmask_remap
1730 REAL(kind=r4_kind),
POINTER,
DIMENSION(:,:,:) :: rmask_ptr_r4
1731 REAL(kind=r8_kind),
POINTER,
DIMENSION(:,:,:) :: rmask_ptr_r8
1735 LOGICAL :: mf_result
1737 REAL :: rmask_threshold
1739 character(len=:),
allocatable :: field_name
1742 IF ( diag_field_id <= 0 )
THEN
1749 IF (
PRESENT(err_msg) ) err_msg =
''
1750 IF ( .NOT.module_is_initialized )
THEN
1751 IF ( fms_error_handler(
'diag_manager_mod::send_data_3d',
'diag_manager NOT initialized', err_msg) )
RETURN
1764 ALLOCATE(field_out(
SIZE(field,1),
SIZE(field,2),
SIZE(field,3)), stat=status)
1765 IF ( status .NE. 0 )
THEN
1766 WRITE (err_msg_local, fmt=
'("Unable to allocate field_out(",I5,",",I5,",",I5,"). (STAT: ",I5,")")')&
1767 &
SIZE(field,1),
SIZE(field,2),
SIZE(field,3), status
1768 IF ( fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
RETURN
1771 TYPE IS (real(kind=r4_kind))
1773 TYPE IS (real(kind=r8_kind))
1774 field_out = real(field)
1776 CALL error_mesg (
'diag_manager_mod::send_data_3d',&
1777 &
'The field is not one of the supported types (real(kind=4) or real(kind=8)). '//&
1778 &
'If using an integer, please set use_modern_diag=.t. in the diag_manager_nml.', fatal)
1782 field_name = fms_diag_object%fms_get_field_name_from_id(diag_field_id)
1783 call copy_3d_to_4d(field, field_remap, trim(field_name)//
"'s data")
1784 if (
present(rmask))
call copy_3d_to_4d(rmask, rmask_remap, trim(field_name)//
"'s mask")
1785 if (
present(mask))
then
1786 allocate(mask_remap(1:
size(mask,1), 1:
size(mask,2), 1:
size(mask,3), 1))
1787 mask_remap(:,:,:,1) = mask
1789 call fms_diag_object%fms_diag_accept_data(diag_field_id, field_remap, mask_remap, rmask_remap, &
1790 time, is_in, js_in, ks_in, ie_in, je_in, ke_in, weight, &
1792 deallocate (field_remap)
1793 if (
allocated(mask_remap))
deallocate(mask_remap)
1794 if (
allocated(rmask_remap))
deallocate(rmask_remap)
1797 ALLOCATE(oor_mask(
SIZE(field,1),
SIZE(field,2),
SIZE(field,3)), stat=status)
1798 IF ( status .NE. 0 )
THEN
1799 WRITE (err_msg_local, fmt=
'("Unable to allocate oor_mask(",I5,",",I5,",",I5,"). (STAT: ",I5,")")')&
1800 &
SIZE(field,1),
SIZE(field,2),
SIZE(field,3), status
1801 IF ( fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
RETURN
1804 IF (
PRESENT(mask) )
THEN
1810 rmask_ptr_r4 => null()
1811 rmask_ptr_r8 => null()
1812 IF (
PRESENT(rmask) )
THEN
1814 TYPE IS (real(kind=r4_kind))
1815 WHERE ( rmask < 0.5_r4_kind ) oor_mask = .false.
1816 rmask_threshold = 0.5_r4_kind
1817 rmask_ptr_r4 => rmask
1818 TYPE IS (real(kind=r8_kind))
1819 WHERE ( rmask < 0.5_r8_kind ) oor_mask = .false.
1820 rmask_threshold = 0.5_r8_kind
1821 rmask_ptr_r8 => rmask
1823 CALL error_mesg (
'diag_manager_mod::send_data_3d',&
1824 &
'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
1839 IF (
PRESENT(ie_in) )
THEN
1840 IF ( .NOT.
PRESENT(is_in) )
THEN
1841 IF ( fms_error_handler(
'diag_manager_mod::send_data_3d',
'ie_in present without is_in', err_msg) )
THEN
1842 DEALLOCATE(field_out)
1843 DEALLOCATE(oor_mask)
1847 IF (
PRESENT(js_in) .AND. .NOT.
PRESENT(je_in) )
THEN
1848 IF ( fms_error_handler(
'diag_manager_modsend_data_3d',&
1849 &
'is_in and ie_in present, but js_in present without je_in', err_msg) )
THEN
1850 DEALLOCATE(field_out)
1851 DEALLOCATE(oor_mask)
1856 IF (
PRESENT(je_in) )
THEN
1857 IF ( .NOT.
PRESENT(js_in) )
THEN
1858 IF ( fms_error_handler(
'diag_manager_mod::send_data_3d',
'je_in present without js_in', err_msg) )
THEN
1859 DEALLOCATE(field_out)
1860 DEALLOCATE(oor_mask)
1864 IF (
PRESENT(is_in) .AND. .NOT.
PRESENT(ie_in) )
THEN
1865 IF ( fms_error_handler(
'diag_manager_mod::send_data_3d',&
1866 &
'js_in and je_in present, but is_in present without ie_in', err_msg))
THEN
1867 DEALLOCATE(field_out)
1868 DEALLOCATE(oor_mask)
1878 IF (
PRESENT(is_in) ) is = is_in
1879 IF (
PRESENT(js_in) ) js = js_in
1880 IF (
PRESENT(ks_in) ) ks = ks_in
1887 IF (
PRESENT(ie_in) ) ie = ie_in
1888 IF (
PRESENT(je_in) ) je = je_in
1889 IF (
PRESENT(ke_in) ) ke = ke_in
1890 twohi = n1-(ie-is+1)
1891 IF ( mod(twohi,2) /= 0 )
THEN
1892 IF ( fms_error_handler(
'diag_manager_mod::send_data_3d',
'non-symmetric halos in first dimension', &
1894 DEALLOCATE(field_out)
1895 DEALLOCATE(oor_mask)
1899 twohj = n2-(je-js+1)
1900 IF ( mod(twohj,2) /= 0 )
THEN
1901 IF ( fms_error_handler(
'diag_manager_mod::send_data_3d',
'non-symmetric halos in second dimension', &
1903 DEALLOCATE(field_out)
1904 DEALLOCATE(oor_mask)
1913 IF (
PRESENT(ie_in) .AND.
PRESENT(je_in) )
THEN
1927 IF (
PRESENT(weight) )
THEN
1928 SELECT TYPE (weight)
1929 TYPE IS (real(kind=r4_kind))
1931 TYPE IS (real(kind=r8_kind))
1932 weight1 = real(weight)
1934 CALL error_mesg (
'diag_manager_mod::send_data_3d',&
1935 &
'The weight is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
1942 missvalue_present = input_fields(diag_field_id)%missing_value_present
1943 IF ( missvalue_present ) missvalue = input_fields(diag_field_id)%missing_value
1945 number_of_outputs = input_fields(diag_field_id)%num_output_fields
1947 input_fields(diag_field_id)%numthreads = 1
1950 input_fields(diag_field_id)%numthreads = omp_get_num_threads()
1951 input_fields(diag_field_id)%active_omp_level = omp_get_level()
1953 numthreads = input_fields(diag_field_id)%numthreads
1954 active_omp_level = input_fields(diag_field_id)%active_omp_level
1957 if(
present(time)) input_fields(diag_field_id)%time = time
1960 IF ( input_fields(diag_field_id)%range_present )
THEN
1962 WRITE (error_string,
'("[",ES14.5E3,",",ES14.5E3,"]")')&
1963 & input_fields(diag_field_id)%range(1:2)
1964 WRITE (error_string1,
'("(Min: ",ES14.5E3,", Max: ",ES14.5E3, ")")')&
1965 & minval(field_out(f1:f2,f3:f4,ks:ke),mask=oor_mask(f1:f2,f3:f4,ks:ke)),&
1966 & maxval(field_out(f1:f2,f3:f4,ks:ke),mask=oor_mask(f1:f2,f3:f4,ks:ke))
1967 IF ( missvalue_present )
THEN
1968 IF ( any(oor_mask(f1:f2,f3:f4,ks:ke) .AND.&
1969 & ((field_out(f1:f2,f3:f4,ks:ke) < input_fields(diag_field_id)%range(1) .OR.&
1970 & field_out(f1:f2,f3:f4,ks:ke) > input_fields(diag_field_id)%range(2)).AND.&
1971 & field_out(f1:f2,f3:f4,ks:ke) .NE. missvalue)) )
THEN
1977 CALL error_mesg(
'diag_manager_mod::send_data_3d',&
1979 &trim(input_fields(diag_field_id)%module_name)//
' in field '//&
1980 &trim(input_fields(diag_field_id)%field_name)//
' '&
1981 &//trim(error_string1)//&
1982 &
' is outside the range '//trim(error_string)//
',&
1983 & and not equal to the missing value.',&
1987 IF ( any(oor_mask(f1:f2,f3:f4,ks:ke) .AND.&
1988 & (field_out(f1:f2,f3:f4,ks:ke) < input_fields(diag_field_id)%range(1) .OR.&
1989 & field_out(f1:f2,f3:f4,ks:ke) > input_fields(diag_field_id)%range(2))) )
THEN
1994 CALL error_mesg(
'diag_manager_mod::send_data_3d',&
1996 &trim(input_fields(diag_field_id)%module_name)//
' in field '//&
1997 &trim(input_fields(diag_field_id)%field_name)//
' '&
1998 &//trim(error_string1)//&
1999 &
' is outside the range '//trim(error_string)//
'.',&
2007 num_out_fields:
DO ii = 1, number_of_outputs
2009 out_num = input_fields(diag_field_id)%output_fields(ii)
2012 local_output = output_fields(out_num)%local_output
2014 need_compute = output_fields(out_num)%need_compute
2016 reduced_k_range = output_fields(out_num)%reduced_k_range
2019 IF ( local_output .AND. (.NOT.need_compute) ) cycle
2022 file_num = output_fields(out_num)%output_file
2025 freq = files(file_num)%output_freq
2026 units = files(file_num)%output_units
2028 average = output_fields(out_num)%time_average
2031 time_rms = output_fields(out_num)%time_rms
2033 pow_value = output_fields(out_num)%pow_value
2035 time_max = output_fields(out_num)%time_max
2036 time_min = output_fields(out_num)%time_min
2038 time_sum = output_fields(out_num)%time_sum
2039 IF ( output_fields(out_num)%total_elements >
SIZE(field_out(f1:f2,f3:f4,ks:ke)) )
THEN
2040 output_fields(out_num)%phys_window = .true.
2042 output_fields(out_num)%phys_window = .false.
2044 phys_window = output_fields(out_num)%phys_window
2045 IF ( need_compute )
THEN
2046 l_start = output_fields(out_num)%output_grid%l_start_indx
2047 l_end = output_fields(out_num)%output_grid%l_end_indx
2052 IF (
PRESENT(time) )
THEN
2053 CALL get_time(time,second,day,tick)
2055 & * output_fields(out_num)%n_diurnal_samples/seconds_per_day) + 1
2059 IF ( reduced_k_range )
THEN
2062 if (output_fields(out_num)%reduced_k_unstruct)
then
2063 js = output_fields(out_num)%output_grid%l_start_indx(2)
2064 je = output_fields(out_num)%output_grid%l_end_indx(2)
2066 l_start(3) = output_fields(out_num)%output_grid%l_start_indx(3)
2067 l_end(3) = output_fields(out_num)%output_grid%l_end_indx(3)
2074 IF ( freq == every_time .AND. .NOT.output_fields(out_num)%static )
THEN
2075 IF (output_fields(out_num)%next_output == output_fields(out_num)%last_output)
THEN
2076 IF(
PRESENT(time))
THEN
2077 output_fields(out_num)%next_output = time
2079 WRITE (error_string,
'(a,"/",a)')&
2080 & trim(input_fields(diag_field_id)%module_name),&
2081 & trim(output_fields(out_num)%output_name)
2082 IF ( fms_error_handler(
'diag_manager_mod::send_data_3d',
'module/output_field '//trim(error_string)//&
2083 &
', time must be present when output frequency = EVERY_TIME', err_msg))
THEN
2084 DEALLOCATE(field_out)
2085 DEALLOCATE(oor_mask)
2091 IF ( .NOT.output_fields(out_num)%static .AND. .NOT.
PRESENT(time) )
THEN
2092 WRITE (error_string,
'(a,"/",a)')&
2093 & trim(input_fields(diag_field_id)%module_name), &
2094 & trim(output_fields(out_num)%output_name)
2095 IF ( fms_error_handler(
'diag_manager_mod::send_data_3d',
'module/output_field '//trim(error_string)//&
2096 &
', time must be present for nonstatic field', err_msg))
THEN
2097 DEALLOCATE(field_out)
2098 DEALLOCATE(oor_mask)
2106 IF ( (numthreads == 1) .AND. (active_omp_level.LE.1) )
then
2107 IF ( .NOT.output_fields(out_num)%static .AND. freq /= end_of_run )
THEN
2108 IF ( time > output_fields(out_num)%next_output )
THEN
2110 IF ( time > output_fields(out_num)%next_next_output .AND. freq > 0 )
THEN
2111 IF ( mpp_pe() .EQ. mpp_root_pe() )
THEN
2112 WRITE (error_string,
'(a,"/",a)')&
2113 & trim(input_fields(diag_field_id)%module_name), &
2114 & trim(output_fields(out_num)%output_name)
2115 IF ( fms_error_handler(
'diag_manager_mod::send_data_3d',
'module/output_field '//&
2116 & trim(error_string)//
' is skipped one time level in output data', err_msg))
THEN
2117 DEALLOCATE(field_out)
2118 DEALLOCATE(oor_mask)
2124 status =
writing_field(out_num, .false., error_string, time)
2125 IF(status == -1)
THEN
2126 IF ( mpp_pe() .EQ. mpp_root_pe() )
THEN
2127 IF(fms_error_handler(
'diag_manager_mod::send_data_3d',
'module/output_field '//trim(error_string)&
2128 & //
', write EMPTY buffer', err_msg))
THEN
2129 DEALLOCATE(field_out)
2130 DEALLOCATE(oor_mask)
2140 if (
present(time))
then
2142 if (output_fields(out_num)%last_output > time) cycle
2145 IF ( .NOT.output_fields(out_num)%static .AND. .NOT.need_compute .AND. debug_diag_manager )
THEN
2147 IF ( err_msg_local /=
'' )
THEN
2148 IF ( fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
2149 DEALLOCATE(field_out)
2150 DEALLOCATE(oor_mask)
2157 ALLOCATE( ofield_index_cfg )
2158 CALL ofield_index_cfg%initialize( is, js, ks, ie, je, ke, &
2159 & hi, hj, f1, f2, f3, f4)
2161 ALLOCATE( ofield_cfg )
2162 CALL ofield_cfg%initialize( input_fields(diag_field_id), output_fields(out_num),
PRESENT(mask), freq)
2166 mf_result =
fieldbuff_update(ofield_cfg, ofield_index_cfg, field_out, sample, &
2167 & output_fields(out_num)%buffer, output_fields(out_num)%counter ,output_fields(out_num)%buff_bounds,&
2168 & output_fields(out_num)%count_0d(sample), output_fields(out_num)%num_elements(sample), &
2169 & mask, weight1 ,missvalue, &
2170 & input_fields(diag_field_id)%numthreads, input_fields(diag_field_id)%active_omp_level,&
2171 & input_fields(diag_field_id)%issued_mask_ignore_warning, &
2172 & l_start, l_end, err_msg, err_msg_local )
2173 IF (mf_result .eqv. .false.)
THEN
2174 DEALLOCATE(ofield_index_cfg)
2175 DEALLOCATE(ofield_cfg)
2176 DEALLOCATE(field_out)
2177 DEALLOCATE(oor_mask)
2182 & output_fields(out_num)%buffer, output_fields(out_num)%buff_bounds , &
2183 & output_fields(out_num)%count_0d(sample), &
2184 & mask, missvalue, l_start, l_end, err_msg, err_msg_local)
2185 IF (mf_result .eqv. .false.)
THEN
2186 DEALLOCATE(ofield_index_cfg)
2187 DEALLOCATE(ofield_cfg)
2188 DEALLOCATE(field_out)
2189 DEALLOCATE(oor_mask)
2194 IF ( output_fields(out_num)%static .AND. .NOT.need_compute .AND. debug_diag_manager )
THEN
2196 IF ( err_msg_local /=
'' )
THEN
2197 IF ( fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg))
THEN
2198 DEALLOCATE(field_out)
2199 DEALLOCATE(oor_mask)
2226 IF(
ALLOCATED(ofield_index_cfg))
THEN
2227 DEALLOCATE(ofield_index_cfg)
2229 IF(
ALLOCATED(ofield_cfg))
THEN
2230 DEALLOCATE(ofield_cfg)
2237 IF ( input_fields(diag_field_id)%mask_variant )
THEN
2238 IF ( need_compute )
THEN
2239 WRITE (error_string,
'(a,"/",a)') &
2240 & trim(input_fields(diag_field_id)%module_name), &
2241 & trim(output_fields(out_num)%output_name)
2242 IF ( fms_error_handler(
'diag_manager_mod::send_data_3d',
'module/output_field '//trim(error_string)//&
2243 &
', regional output NOT supported with mask_variant', err_msg))
THEN
2244 DEALLOCATE(field_out)
2245 DEALLOCATE(oor_mask)
2252 IF (
PRESENT(mask) )
THEN
2253 IF ( missvalue_present )
THEN
2254 IF ( debug_diag_manager )
THEN
2255 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
2257 IF ( err_msg_local /=
'' )
THEN
2258 IF ( fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
2259 DEALLOCATE(field_out)
2260 DEALLOCATE(oor_mask)
2265 IF( numthreads>1 .AND. phys_window )
then
2266 IF ( reduced_k_range )
THEN
2271 IF ( mask(i-is+1+hi, j-js+1+hj, k) )
THEN
2272 IF ( pow_value /= 1 )
THEN
2273 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2274 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2275 & (field_out(i-is+1+hi, j-js+1+hj, k) * weight1)**(pow_value)
2277 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2278 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2279 & field_out(i-is+1+hi, j-js+1+hj, k) * weight1
2281 output_fields(out_num)%counter(i-hi,j-hj,k1,sample) =&
2282 & output_fields(out_num)%counter(i-hi,j-hj,k1,sample) + weight1
2291 IF ( mask(i-is+1+hi, j-js+1+hj, k) )
THEN
2292 IF ( pow_value /= 1 )
THEN
2293 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2294 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2295 & (field_out(i-is+1+hi,j-js+1+hj,k)*weight1)**(pow_value)
2297 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2298 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2299 & field_out(i-is+1+hi,j-js+1+hj,k)*weight1
2301 output_fields(out_num)%counter(i-hi,j-hj,k,sample) =&
2302 &output_fields(out_num)%counter(i-hi,j-hj,k,sample) + weight1
2310 IF ( reduced_k_range )
THEN
2315 IF ( mask(i-is+1+hi, j-js+1+hj, k) )
THEN
2316 IF ( pow_value /= 1 )
THEN
2317 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2318 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2319 & (field_out(i-is+1+hi, j-js+1+hj, k) * weight1)**(pow_value)
2321 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2322 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2323 & field_out(i-is+1+hi, j-js+1+hj, k) * weight1
2325 output_fields(out_num)%counter(i-hi,j-hj,k1,sample) =&
2326 & output_fields(out_num)%counter(i-hi,j-hj,k1,sample) + weight1
2335 IF ( mask(i-is+1+hi, j-js+1+hj, k) )
THEN
2336 IF ( pow_value /= 1 )
THEN
2337 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2338 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2339 & (field_out(i-is+1+hi,j-js+1+hj,k)*weight1)**(pow_value)
2341 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2342 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2343 & field_out(i-is+1+hi,j-js+1+hj,k)*weight1
2345 output_fields(out_num)%counter(i-hi,j-hj,k,sample) =&
2346 &output_fields(out_num)%counter(i-hi,j-hj,k,sample) + weight1
2355 WRITE (error_string,
'(a,"/",a)')&
2356 & trim(input_fields(diag_field_id)%module_name), &
2357 & trim(output_fields(out_num)%output_name)
2358 IF(fms_error_handler(
'diag_manager_mod::send_data_3d',
'module/output_field '//trim(error_string)//&
2359 &
', variable mask but no missing value defined', err_msg))
THEN
2360 DEALLOCATE(field_out)
2361 DEALLOCATE(oor_mask)
2366 WRITE (error_string,
'(a,"/",a)')&
2367 & trim(input_fields(diag_field_id)%module_name), &
2368 & trim(output_fields(out_num)%output_name)
2369 IF(fms_error_handler(
'diag_manager_mod::send_data_3d',
'module/output_field '//trim(error_string)//&
2370 &
', variable mask but no mask given', err_msg))
THEN
2371 DEALLOCATE(field_out)
2372 DEALLOCATE(oor_mask)
2377 IF (
PRESENT(mask) )
THEN
2378 IF ( missvalue_present )
THEN
2379 IF ( need_compute )
THEN
2380 IF (numthreads>1 .AND. phys_window)
then
2381 DO k = l_start(3), l_end(3)
2385 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2386 & j <= l_end(2)+hj )
THEN
2387 i1 = i-l_start(1)-hi+1
2388 j1= j-l_start(2)-hj+1
2389 IF ( mask(i-is+1+hi, j-js+1+hj, k) )
THEN
2390 IF ( pow_value /= 1 )
THEN
2391 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2392 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2393 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2395 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2396 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2397 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2400 output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
2408 DO k = l_start(3), l_end(3)
2412 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2413 & j <= l_end(2)+hj )
THEN
2414 i1 = i-l_start(1)-hi+1
2415 j1= j-l_start(2)-hj+1
2416 IF ( mask(i-is+1+hi, j-js+1+hj, k) )
THEN
2417 IF ( pow_value /= 1 )
THEN
2418 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2419 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2420 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2422 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2423 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2424 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2427 output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
2438 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2439 & j <= l_end(2)+hj )
THEN
2440 output_fields(out_num)%num_elements(sample) = &
2441 output_fields(out_num)%num_elements(sample) + l_end(3) - l_start(3) + 1
2446 ELSE IF ( reduced_k_range )
THEN
2447 IF (numthreads>1 .AND. phys_window)
then
2452 IF ( mask(i-is+1+hi,j-js+1+hj,k) )
THEN
2453 IF ( pow_value /= 1 )
THEN
2454 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2455 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2456 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2458 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2459 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2460 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2463 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue
2474 IF ( mask(i-is+1+hi,j-js+1+hj,k) )
THEN
2475 IF ( pow_value /= 1 )
THEN
2476 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2477 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2478 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2480 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2481 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2482 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2485 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue
2493 IF ( debug_diag_manager )
THEN
2494 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
2496 IF ( err_msg_local /=
'' )
THEN
2497 IF ( fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
2498 DEALLOCATE(field_out)
2499 DEALLOCATE(oor_mask)
2504 IF (numthreads>1 .AND. phys_window)
then
2508 IF ( mask(i-is+1+hi,j-js+1+hj,k) )
THEN
2509 IF ( pow_value /= 1 )
THEN
2510 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2511 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2512 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2514 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2515 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2516 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2519 output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue
2529 IF ( mask(i-is+1+hi,j-js+1+hj,k) )
THEN
2530 IF ( pow_value /= 1 )
THEN
2531 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2532 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2533 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2535 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2536 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2537 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2540 output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue
2549 IF ( need_compute .AND. .NOT.phys_window )
THEN
2550 IF ( any(mask(l_start(1)+hi:l_end(1)+hi,l_start(2)+hj:l_end(2)+hj,l_start(3):l_end(3))) ) &
2551 & output_fields(out_num)%count_0d(sample) =&
2552 & output_fields(out_num)%count_0d(sample) + weight1
2554 IF ( any(mask(f1:f2,f3:f4,ks:ke)) ) output_fields(out_num)%count_0d(sample) =&
2555 & output_fields(out_num)%count_0d(sample)+weight1
2560 IF ( (.NOT.all(mask(f1:f2,f3:f4,ks:ke)) .AND. mpp_pe() .EQ. mpp_root_pe()).AND.&
2561 & .NOT.input_fields(diag_field_id)%issued_mask_ignore_warning )
THEN
2566 CALL error_mesg(
'diag_manager_mod::send_data_3d',&
2567 &
'Mask will be ignored since missing values were not specified for field '//&
2568 & trim(input_fields(diag_field_id)%field_name)//
' in module '//&
2569 & trim(input_fields(diag_field_id)%module_name), warning)
2570 input_fields(diag_field_id)%issued_mask_ignore_warning = .true.
2572 IF ( need_compute )
THEN
2573 IF (numthreads>1 .AND. phys_window)
then
2576 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2577 & j <= l_end(2)+hj )
THEN
2578 i1 = i-l_start(1)-hi+1
2579 j1 = j-l_start(2)-hj+1
2580 IF ( pow_value /= 1 )
THEN
2581 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2582 & output_fields(out_num)%buffer(i1,j1,:,sample)+ &
2583 & (field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value)
2585 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2586 & output_fields(out_num)%buffer(i1,j1,:,sample)+ &
2587 & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
2596 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2597 & j <= l_end(2)+hj )
THEN
2598 i1 = i-l_start(1)-hi+1
2599 j1 = j-l_start(2)-hj+1
2600 IF ( pow_value /= 1 )
THEN
2601 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2602 & output_fields(out_num)%buffer(i1,j1,:,sample)+ &
2603 & (field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value)
2605 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2606 & output_fields(out_num)%buffer(i1,j1,:,sample)+ &
2607 & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
2617 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2618 & j <= l_end(2)+hj )
THEN
2619 output_fields(out_num)%num_elements(sample)=&
2620 & output_fields(out_num)%num_elements(sample)+l_end(3)-l_start(3)+1
2626 ELSE IF ( reduced_k_range )
THEN
2627 IF (numthreads>1 .AND. phys_window)
then
2630 IF ( pow_value /= 1 )
THEN
2631 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2632 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) +&
2633 & (field_out(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value)
2635 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2636 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) +&
2637 & field_out(f1:f2,f3:f4,ksr:ker)*weight1
2643 IF ( pow_value /= 1 )
THEN
2644 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2645 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) +&
2646 & (field_out(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value)
2648 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2649 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) +&
2650 & field_out(f1:f2,f3:f4,ksr:ker)*weight1
2655 IF ( debug_diag_manager )
THEN
2656 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
2658 IF ( err_msg_local /=
'')
THEN
2659 IF ( fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
2660 DEALLOCATE(field_out)
2661 DEALLOCATE(oor_mask)
2666 IF (numthreads>1 .AND. phys_window)
then
2667 IF ( pow_value /= 1 )
THEN
2668 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
2669 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
2670 & (field_out(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value)
2672 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
2673 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
2674 & field_out(f1:f2,f3:f4,ks:ke)*weight1
2678 IF ( pow_value /= 1 )
THEN
2679 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
2680 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
2681 & (field_out(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value)
2683 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
2684 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
2685 & field_out(f1:f2,f3:f4,ks:ke)*weight1
2691 IF ( .NOT.phys_window ) output_fields(out_num)%count_0d(sample) =&
2692 & output_fields(out_num)%count_0d(sample) + weight1
2696 IF ( missvalue_present )
THEN
2697 IF ( need_compute )
THEN
2698 if( numthreads>1 .AND. phys_window )
then
2699 DO k = l_start(3), l_end(3)
2700 k1 = k - l_start(3) + 1
2703 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2704 & j <= l_end(2)+hj)
THEN
2705 i1 = i-l_start(1)-hi+1
2706 j1= j-l_start(2)-hj+1
2707 IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue )
THEN
2708 IF ( pow_value /= 1 )
THEN
2709 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2710 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2711 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2713 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2714 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2715 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2718 output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
2726 DO k = l_start(3), l_end(3)
2727 k1 = k - l_start(3) + 1
2730 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2731 & j <= l_end(2)+hj)
THEN
2732 i1 = i-l_start(1)-hi+1
2733 j1= j-l_start(2)-hj+1
2734 IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue )
THEN
2735 IF ( pow_value /= 1 )
THEN
2736 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2737 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2738 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2740 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2741 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2742 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2745 output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
2756 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2757 & j <= l_end(2)+hj)
THEN
2758 output_fields(out_num)%num_elements(sample) =&
2759 & output_fields(out_num)%num_elements(sample) + l_end(3) - l_start(3) + 1
2763 IF ( .NOT.phys_window )
THEN
2764 outer0:
DO k = l_start(3), l_end(3)
2765 DO j=l_start(2)+hj, l_end(2)+hj
2766 DO i=l_start(1)+hi, l_end(1)+hi
2767 IF ( field_out(i,j,k) /= missvalue )
THEN
2768 output_fields(out_num)%count_0d(sample) = output_fields(out_num)%count_0d(sample)&
2777 ELSE IF ( reduced_k_range )
THEN
2778 if( numthreads>1 .AND. phys_window )
then
2785 IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue )
THEN
2786 IF ( pow_value /= 1 )
THEN
2787 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2788 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2789 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2791 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2792 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2793 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2796 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) = missvalue
2809 IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue )
THEN
2810 IF ( pow_value /= 1 )
THEN
2811 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2812 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2813 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2815 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2816 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2817 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2820 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) = missvalue
2828 outer3:
DO k = ksr, ker
2832 IF ( field_out(i,j,k) /= missvalue )
THEN
2833 output_fields(out_num)%count_0d(sample) = output_fields(out_num)%count_0d(sample) &
2842 IF ( debug_diag_manager )
THEN
2843 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
2845 IF ( err_msg_local /=
'' )
THEN
2846 IF ( fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
2847 DEALLOCATE(field_out)
2848 DEALLOCATE(oor_mask)
2853 IF( numthreads > 1 .AND. phys_window )
then
2857 IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue )
THEN
2858 IF ( pow_value /= 1 )
THEN
2859 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2860 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2861 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2863 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2864 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2865 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2868 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) = missvalue
2878 IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue )
THEN
2879 IF ( pow_value /= 1 )
THEN
2880 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2881 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2882 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2884 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2885 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2886 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2889 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) = missvalue
2900 IF ( field_out(i,j,k) /= missvalue )
THEN
2901 output_fields(out_num)%count_0d(sample) = output_fields(out_num)%count_0d(sample) &
2911 IF ( need_compute )
THEN
2912 IF( numthreads > 1 .AND. phys_window )
then
2915 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2916 & j <= l_end(2)+hj )
THEN
2917 i1 = i-l_start(1)-hi+1
2918 j1= j-l_start(2)-hj+1
2919 IF ( pow_value /= 1 )
THEN
2920 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2921 & output_fields(out_num)%buffer(i1,j1,:,sample) +&
2922 & (field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value)
2924 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2925 & output_fields(out_num)%buffer(i1,j1,:,sample) +&
2926 & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
2935 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2936 & j <= l_end(2)+hj )
THEN
2937 i1 = i-l_start(1)-hi+1
2938 j1= j-l_start(2)-hj+1
2939 IF ( pow_value /= 1 )
THEN
2940 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2941 & output_fields(out_num)%buffer(i1,j1,:,sample) +&
2942 & (field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value)
2944 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2945 & output_fields(out_num)%buffer(i1,j1,:,sample) +&
2946 & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
2957 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2958 & j <= l_end(2)+hj )
THEN
2959 output_fields(out_num)%num_elements(sample) =&
2960 & output_fields(out_num)%num_elements(sample)+l_end(3)-l_start(3)+1
2966 ELSE IF ( reduced_k_range )
THEN
2969 IF( numthreads > 1 .AND. phys_window )
then
2970 IF ( pow_value /= 1 )
THEN
2971 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2972 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
2973 & (field_out(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value)
2975 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2976 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
2977 & field_out(f1:f2,f3:f4,ksr:ker)*weight1
2981 IF ( pow_value /= 1 )
THEN
2982 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2983 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
2984 & (field_out(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value)
2986 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2987 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
2988 & field_out(f1:f2,f3:f4,ksr:ker)*weight1
2993 IF ( debug_diag_manager )
THEN
2994 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
2996 IF ( err_msg_local /=
'' )
THEN
2997 IF ( fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
2998 DEALLOCATE(field_out)
2999 DEALLOCATE(oor_mask)
3004 IF( numthreads > 1 .AND. phys_window )
then
3005 IF ( pow_value /= 1 )
THEN
3006 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
3007 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
3008 & (field_out(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value)
3010 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
3011 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
3012 & field_out(f1:f2,f3:f4,ks:ke)*weight1
3016 IF ( pow_value /= 1 )
THEN
3017 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
3018 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
3019 & (field_out(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value)
3021 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
3022 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
3023 & field_out(f1:f2,f3:f4,ks:ke)*weight1
3029 IF ( .NOT.phys_window ) output_fields(out_num)%count_0d(sample) =&
3030 & output_fields(out_num)%count_0d(sample) + weight1
3036 IF ( .NOT.need_compute .AND. .NOT.reduced_k_range )&
3037 & output_fields(out_num)%num_elements(sample) =&
3038 & output_fields(out_num)%num_elements(sample) + (ie-is+1)*(je-js+1)*(ke-ks+1)
3039 IF ( reduced_k_range ) &
3040 & output_fields(out_num)%num_elements(sample) = output_fields(out_num)%num_elements(sample) +&
3041 & (ie-is+1)*(je-js+1)*(ker-ksr+1)
3045 IF (
PRESENT(mask) )
THEN
3046 IF ( need_compute )
THEN
3047 DO k = l_start(3), l_end(3)
3048 k1 = k - l_start(3) + 1
3051 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
3052 & j <= l_end(2)+hj )
THEN
3053 i1 = i-l_start(1)-hi+1
3054 j1= j-l_start(2)-hj+1
3055 IF ( mask(i-is+1+hi,j-js+1+hj,k) .AND. field_out(i-is+1+hi,j-js+1+hj,k)>&
3056 & output_fields(out_num)%buffer(i1,j1,k1,sample) )
THEN
3057 output_fields(out_num)%buffer(i1,j1,k1,sample) = field_out(i-is+1+hi,j-js+1+hj,k)
3064 ELSE IF ( reduced_k_range )
THEN
3067 WHERE ( mask(f1:f2,f3:f4,ksr:ker) .AND. field_out(f1:f2,f3:f4,ksr:ker) >&
3068 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) )&
3069 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker)
3071 IF ( debug_diag_manager )
THEN
3072 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3074 IF ( err_msg_local /=
'' )
THEN
3075 IF ( fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3076 DEALLOCATE(field_out)
3077 DEALLOCATE(oor_mask)
3082 WHERE ( mask(f1:f2,f3:f4,ks:ke) .AND. field_out(f1:f2,f3:f4,ks:ke)>&
3083 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) )&
3084 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke)
3087 IF ( need_compute )
THEN
3088 DO k = l_start(3), l_end(3)
3089 k1 = k - l_start(3) + 1
3092 IF(l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
3093 & j <= l_end(2)+hj )
THEN
3094 i1 = i-l_start(1)-hi+1
3095 j1 = j-l_start(2)-hj+1
3096 IF ( field_out(i-is+1+hi,j-js+1+hj,k)>output_fields(out_num)%buffer(i1,j1,k1,sample) )
THEN
3097 output_fields(out_num)%buffer(i1,j1,k1,sample) = field_out(i-is+1+hi,j-js+1+hj,k)
3104 ELSE IF ( reduced_k_range )
THEN
3107 WHERE ( field_out(f1:f2,f3:f4,ksr:ker) >&
3108 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) ) &
3109 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker)
3111 IF ( debug_diag_manager )
THEN
3112 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3114 IF ( err_msg_local /=
'' )
THEN
3115 IF ( fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3116 DEALLOCATE(field_out)
3117 DEALLOCATE(oor_mask)
3122 WHERE ( field_out(f1:f2,f3:f4,ks:ke) >&
3123 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) ) &
3124 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke)
3127 output_fields(out_num)%count_0d(sample) = 1
3129 IF (
PRESENT(mask) )
THEN
3130 IF ( need_compute )
THEN
3131 DO k = l_start(3), l_end(3)
3132 k1 = k - l_start(3) + 1
3135 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
3136 & j <= l_end(2)+hj )
THEN
3137 i1 = i-l_start(1)-hi+1
3138 j1 = j-l_start(2)-hj+1
3139 IF ( mask(i-is+1+hi,j-js+1+hj,k) .AND. field_out(i-is+1+hi,j-js+1+hj,k) <&
3140 & output_fields(out_num)%buffer(i1,j1,k1,sample) )
THEN
3141 output_fields(out_num)%buffer(i1,j1,k1,sample) = field_out(i-is+1+hi,j-js+1+hj,k)
3148 ELSE IF ( reduced_k_range )
THEN
3151 WHERE ( mask(f1:f2,f3:f4,ksr:ker) .AND. field_out(f1:f2,f3:f4,ksr:ker) <&
3152 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) ) &
3153 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker)
3155 IF ( debug_diag_manager )
THEN
3156 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3158 IF ( err_msg_local /=
'' )
THEN
3159 IF ( fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3160 DEALLOCATE(field_out)
3161 DEALLOCATE(oor_mask)
3166 WHERE ( mask(f1:f2,f3:f4,ks:ke) .AND. field_out(f1:f2,f3:f4,ks:ke) <&
3167 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) ) &
3168 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke)
3171 IF ( need_compute )
THEN
3172 DO k = l_start(3), l_end(3)
3173 k1 = k - l_start(3) + 1
3176 IF ( l_start(1)+hi <=i.AND.i<=l_end(1)+hi.AND.l_start(2)+hj<=j.AND.j<=l_end(2)+hj)
THEN
3177 i1 = i-l_start(1)-hi+1
3178 j1= j-l_start(2)-hj+1
3179 IF ( field_out(i-is+1+hi,j-js+1+hj,k) <&
3180 & output_fields(out_num)%buffer(i1,j1,k1,sample) )
THEN
3181 output_fields(out_num)%buffer(i1,j1,k1,sample) = field_out(i-is+1+hi,j-js+1+hj,k)
3188 ELSE IF ( reduced_k_range )
THEN
3191 WHERE ( field_out(f1:f2,f3:f4,ksr:ker) <&
3192 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) ) &
3193 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker)
3195 IF ( debug_diag_manager )
THEN
3196 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3198 IF ( err_msg_local /=
'' )
THEN
3199 IF ( fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3200 DEALLOCATE(field_out)
3201 DEALLOCATE(oor_mask)
3206 WHERE ( field_out(f1:f2,f3:f4,ks:ke) <&
3207 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) )&
3208 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke)
3211 output_fields(out_num)%count_0d(sample) = 1
3213 IF (
PRESENT(mask) )
THEN
3214 IF ( need_compute )
THEN
3215 DO k = l_start(3), l_end(3)
3216 k1 = k - l_start(3) + 1
3219 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
3220 & j <= l_end(2)+hj )
THEN
3221 i1 = i-l_start(1)-hi+1
3222 j1 = j-l_start(2)-hj+1
3223 IF ( mask(i-is+1+hi,j-js+1+hj,k) )
THEN
3224 output_fields(out_num)%buffer(i1,j1,k1,sample) = &
3225 output_fields(out_num)%buffer(i1,j1,k1,sample) + &
3226 field_out(i-is+1+hi,j-js+1+hj,k)
3233 ELSE IF ( reduced_k_range )
THEN
3236 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = &
3237 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
3238 & field_out(f1:f2,f3:f4,ksr:ker)
3240 IF ( debug_diag_manager )
THEN
3241 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3243 IF ( err_msg_local /=
'' )
THEN
3244 IF ( fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3245 DEALLOCATE(field_out)
3246 DEALLOCATE(oor_mask)
3251 WHERE ( mask(f1:f2,f3:f4,ks:ke) ) &
3252 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = &
3253 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) + &
3254 & field_out(f1:f2,f3:f4,ks:ke)
3257 IF ( need_compute )
THEN
3258 DO k = l_start(3), l_end(3)
3259 k1 = k - l_start(3) + 1
3262 IF ( l_start(1)+hi <=i.AND.i<=l_end(1)+hi.AND.l_start(2)+hj<=j.AND.j<=l_end(2)+hj)
THEN
3263 i1 = i-l_start(1)-hi+1
3264 j1= j-l_start(2)-hj+1
3265 output_fields(out_num)%buffer(i1,j1,k1,sample) = &
3266 & output_fields(out_num)%buffer(i1,j1,k1,sample) + &
3267 & field_out(i-is+1+hi,j-js+1+hj,k)
3272 ELSE IF ( reduced_k_range )
THEN
3275 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = &
3276 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
3277 & field_out(f1:f2,f3:f4,ksr:ker)
3279 IF ( debug_diag_manager )
THEN
3280 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3282 IF ( err_msg_local /=
'' )
THEN
3283 IF ( fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3284 DEALLOCATE(field_out)
3285 DEALLOCATE(oor_mask)
3290 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = &
3291 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) + &
3292 & field_out(f1:f2,f3:f4,ks:ke)
3295 output_fields(out_num)%count_0d(sample) = 1
3297 output_fields(out_num)%count_0d(sample) = 1
3298 IF ( need_compute )
THEN
3301 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. j <= l_end(2)+hj)
THEN
3302 i1 = i-l_start(1)-hi+1
3303 j1 = j-l_start(2)-hj+1
3304 output_fields(out_num)%buffer(i1,j1,:,sample) =&
3305 & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))
3310 ELSE IF ( reduced_k_range )
THEN
3313 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker)
3315 IF ( debug_diag_manager )
THEN
3316 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3318 IF ( err_msg_local /=
'' )
THEN
3319 IF ( fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3320 DEALLOCATE(field_out)
3321 DEALLOCATE(oor_mask)
3326 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke)
3329 IF (
PRESENT(mask) .AND. missvalue_present )
THEN
3330 IF ( need_compute )
THEN
3331 DO k = l_start(3), l_end(3)
3332 k1 = k - l_start(3) + 1
3335 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
3336 & j <= l_end(2)+hj )
THEN
3337 i1 = i-l_start(1)-hi+1
3338 j1 = j-l_start(2)-hj+1
3339 IF ( .NOT.mask(i-is+1+hi,j-js+1+hj,k) )&
3340 & output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
3345 ELSE IF ( reduced_k_range )
THEN
3352 IF ( .NOT.mask(i-is+1+hi,j-js+1+hj,k) ) &
3353 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue
3361 IF ( .NOT.mask(i-is+1+hi,j-js+1+hj,k) )&
3362 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue
3370 IF ( output_fields(out_num)%static .AND. .NOT.need_compute .AND. debug_diag_manager )
THEN
3372 IF ( err_msg_local /=
'' )
THEN
3373 IF ( fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg))
THEN
3374 DEALLOCATE(field_out)
3375 DEALLOCATE(oor_mask)
3384 IF (
PRESENT(rmask) .AND. missvalue_present )
THEN
3385 IF ( need_compute )
THEN
3387 TYPE IS (real(kind=r4_kind))
3388 DO k = l_start(3), l_end(3)
3389 k1 = k - l_start(3) + 1
3392 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND.&
3393 & j <= l_end(2)+hj )
THEN
3394 i1 = i-l_start(1)-hi+1
3395 j1 = j-l_start(2)-hj+1
3396 IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r4_kind ) &
3397 & output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
3402 TYPE IS (real(kind=r8_kind))
3403 DO k = l_start(3), l_end(3)
3404 k1 = k - l_start(3) + 1
3407 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND.&
3408 & j <= l_end(2)+hj )
THEN
3409 i1 = i-l_start(1)-hi+1
3410 j1 = j-l_start(2)-hj+1
3411 IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r8_kind ) &
3412 & output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
3418 CALL error_mesg (
'diag_manager_mod::send_data_3d',&
3419 &
'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
3421 ELSE IF ( reduced_k_range )
THEN
3425 TYPE IS (real(kind=r4_kind))
3430 IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r4_kind ) &
3431 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue
3435 TYPE IS (real(kind=r8_kind))
3440 IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r8_kind ) &
3441 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue
3446 CALL error_mesg (
'diag_manager_mod::send_data_3d',&
3447 &
'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
3451 TYPE IS (real(kind=r4_kind))
3455 IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r4_kind ) &
3456 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue
3460 TYPE IS (real(kind=r8_kind))
3464 IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r8_kind ) &
3465 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue
3470 CALL error_mesg (
'diag_manager_mod::send_data_3d',&
3471 &
'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
3476 END DO num_out_fields
3478 DEALLOCATE(field_out)
3479 DEALLOCATE(oor_mask)