26 use,
intrinsic :: iso_fortran_env, only: real128
27 use,
intrinsic :: iso_c_binding, only: c_double,c_float,c_int64_t, &
28 c_int32_t,c_int16_t,c_intptr_t
42 USE diag_data_mod,
ONLY: output_fields, input_fields, files, do_diag_field_log, diag_log_unit,&
43 & very_large_axis_length, time_zero, very_large_file_freq, end_of_run, every_time,&
44 & diag_seconds, diag_minutes, diag_hours, diag_days, diag_months, diag_years,
get_base_time,&
68 USE time_manager_mod,
ONLY:
time_type,
OPERATOR(==),
OPERATOR(>), no_calendar, increment_date,&
70 &
OPERATOR(<),
OPERATOR(>=),
OPERATOR(<=),
OPERATOR(==)
72 USE constants_mod,
ONLY: seconds_per_day, seconds_per_hour, seconds_per_minute
75 USE netcdf,
ONLY: nf90_char
112 #include <file_version.h>
114 LOGICAL :: module_initialized = .false.
124 IF (module_initialized)
THEN
134 INTEGER,
INTENT(in) :: axes(:)
135 INTEGER,
INTENT(in) :: outnum
137 REAL,
ALLOCATABLE :: global_lat(:), global_lon(:), global_depth(:)
138 INTEGER :: global_axis_size, global_axis_sizey
139 INTEGER :: i,xbegin,xend,ybegin,yend,xbegin_l,xend_l,ybegin_l,yend_l
140 CHARACTER(len=1) :: cart
141 TYPE(
domain2d) :: domain2, domain2_new
142 TYPE(
domain1d) :: domain1, domain1x, domain1y
145 INTEGER :: gstart_indx(3)
146 INTEGER :: gend_indx(3)
147 REAL,
ALLOCATABLE :: subaxis_x(:)
148 REAL,
ALLOCATABLE :: subaxis_y(:)
149 REAL,
ALLOCATABLE :: subaxis_z(:)
150 CHARACTER(len=128) :: msg
151 INTEGER :: ishift, jshift
154 CHARACTER(len=128),
DIMENSION(2) :: axis_domain_name
164 IF ( region_out_use_alt_value )
THEN
165 grv = glo_reg_val_alt
171 start = output_fields(outnum)%output_grid%start
172 end = output_fields(outnum)%output_grid%end
174 CALL get_diag_axis_domain_name(axes(1), axis_domain_name(1))
175 CALL get_diag_axis_domain_name(axes(2), axis_domain_name(2))
177 IF ( index(lowercase(axis_domain_name(1)),
'cubed') == 0 .AND. &
178 & index(lowercase(axis_domain_name(2)),
'cubed') == 0 )
THEN
179 DO i = 1,
SIZE(axes(:))
180 global_axis_size = get_axis_global_length(axes(i))
181 output_fields(outnum)%output_grid%subaxes(i) = -1
182 CALL get_diag_axis_cart(axes(i), cart)
186 IF( i.NE.1 )
CALL error_mesg(
'diag_util_mod::get_subfield_size',&
187 &
'wrong order of axes, X should come first',fatal)
188 ALLOCATE(global_lon(global_axis_size))
189 CALL get_diag_axis_data(axes(i),global_lon)
190 IF( int(start(i)) == grv .AND. int(end(i)) == grv )
THEN
192 gend_indx(i) = global_axis_size
193 output_fields(outnum)%output_grid%subaxes(i) = axes(i)
195 gstart_indx(i) =
get_index(start(i),global_lon)
196 gend_indx(i) =
get_index(end(i),global_lon)
198 ALLOCATE(subaxis_x(gstart_indx(i):gend_indx(i)))
199 subaxis_x=global_lon(gstart_indx(i):gend_indx(i))
202 IF( i.NE.2 )
CALL error_mesg(
'diag_util_mod::get_subfield_size',&
203 &
'wrong order of axes, Y should come second',fatal)
204 ALLOCATE(global_lat(global_axis_size))
205 CALL get_diag_axis_data(axes(i),global_lat)
206 IF( int(start(i)) == grv .AND. int(end(i)) == grv )
THEN
208 gend_indx(i) = global_axis_size
209 output_fields(outnum)%output_grid%subaxes(i) = axes(i)
211 gstart_indx(i) =
get_index(start(i),global_lat)
212 gend_indx(i) =
get_index(end(i),global_lat)
214 ALLOCATE(subaxis_y(gstart_indx(i):gend_indx(i)))
215 subaxis_y=global_lat(gstart_indx(i):gend_indx(i))
218 IF ( start(i)*end(i)<0. )
CALL error_mesg(
'diag_util_mod::get_subfield_size',&
219 &
'wrong values in vertical axis of region',fatal)
220 IF ( start(i)>=0. .AND. end(i)>0. )
THEN
221 ALLOCATE(global_depth(global_axis_size))
222 CALL get_diag_axis_data(axes(i),global_depth)
223 gstart_indx(i) =
get_index(start(i),global_depth)
224 gend_indx(i) =
get_index(end(i),global_depth)
225 ALLOCATE(subaxis_z(gstart_indx(i):gend_indx(i)))
226 subaxis_z=global_depth(gstart_indx(i):gend_indx(i))
227 output_fields(outnum)%output_grid%subaxes(i) =&
228 & diag_subaxes_init(axes(i),subaxis_z, gstart_indx(i),gend_indx(i))
229 DEALLOCATE(subaxis_z,global_depth)
232 gend_indx(i) = global_axis_size
233 output_fields(outnum)%output_grid%subaxes(i) = axes(i)
235 IF( i /= 3 )
CALL error_mesg(
'diag_util_mod::get_subfield_size',&
236 &
'i should equal 3 for z axis', fatal)
240 CALL error_mesg(
'diag_util_mod::get_subfield_size',
'Wrong axis_cart', fatal)
244 DO i = 1,
SIZE(axes(:))
245 IF ( gstart_indx(i) == -1 .OR. gend_indx(i) == -1 )
THEN
250 WRITE(msg,
'(A,I2)')
' check region bounds for axis ', i
251 CALL error_mesg(
'diag_util_mod::get_subfield_size',
'can not find gstart_indx/gend_indx for '&
252 & //trim(output_fields(outnum)%output_name)//
','//trim(msg), fatal)
257 CALL get_local_indexes(lonstart=start(1), lonend=end(1), &
258 & latstart=start(2), latend=end(2), &
259 & istart=gstart_indx(1), iend=gend_indx(1), &
260 & jstart=gstart_indx(2), jend=gend_indx(2))
261 global_axis_size = get_axis_global_length(axes(1))
262 ALLOCATE(global_lon(global_axis_size))
263 global_axis_sizey = get_axis_global_length(axes(2))
264 ALLOCATE(global_lat(global_axis_sizey))
265 CALL get_diag_axis_data(axes(1),global_lon)
266 CALL get_diag_axis_data(axes(2),global_lat)
269 IF ((gstart_indx(1) .GT. 0 .AND. gstart_indx(2) .GT. 0) .AND. &
270 (gstart_indx(1) .LE. global_axis_size .AND. gstart_indx(2) .LE. global_axis_sizey) .AND. &
271 (gend_indx(1) .GT. 0 .AND. gend_indx(2) .GT. 0) .AND. &
272 (gend_indx(1) .LE. global_axis_size .AND. gend_indx(2) .LE. global_axis_sizey))
THEN
273 ALLOCATE(subaxis_x(gstart_indx(1):gend_indx(1)))
274 ALLOCATE(subaxis_y(gstart_indx(2):gend_indx(2)))
275 subaxis_x=global_lon(gstart_indx(1):gend_indx(1))
276 subaxis_y=global_lat(gstart_indx(2):gend_indx(2))
280 IF (
SIZE(axes(:)) > 2 )
THEN
281 global_axis_size = get_axis_global_length(axes(3))
282 output_fields(outnum)%output_grid%subaxes(3) = -1
283 CALL get_diag_axis_cart(axes(3), cart)
287 IF ( lowercase(cart) /=
'z' )
CALL error_mesg(
'diag_util_mod::get_subfield_size', &
288 &
'axis(3) should be Z-axis', fatal)
292 IF ( start(3)*end(3)<0. )
CALL error_mesg(
'diag_util_mod::get_subfield_size',&
293 &
'wrong values in vertical axis of region',fatal)
294 IF ( start(3)>=0. .AND. end(3)>0. )
THEN
295 ALLOCATE(global_depth(global_axis_size))
296 CALL get_diag_axis_data(axes(3),global_depth)
297 gstart_indx(3) =
get_index(start(3),global_depth)
298 IF( start(3) == 0.0 ) gstart_indx(3) = 1
299 gend_indx(3) =
get_index(end(3),global_depth)
300 IF( start(3) >= maxval(global_depth) ) gstart_indx(3)= global_axis_size
301 IF( end(3) >= maxval(global_depth) ) gend_indx(3) = global_axis_size
303 ALLOCATE(subaxis_z(gstart_indx(3):gend_indx(3)))
304 subaxis_z=global_depth(gstart_indx(3):gend_indx(3))
305 output_fields(outnum)%output_grid%subaxes(3) =&
306 & diag_subaxes_init(axes(3),subaxis_z, gstart_indx(3),gend_indx(3))
307 DEALLOCATE(subaxis_z,global_depth)
310 gend_indx(3) = global_axis_size
311 output_fields(outnum)%output_grid%subaxes(3) = axes(3)
322 domain2 = get_domain2d(axes)
323 IF ( domain2 .NE. null_domain2d )
THEN
324 CALL mpp_get_compute_domain(domain2, xbegin, xend, ybegin, yend)
327 DO i = 1, min(
SIZE(axes(:)),2)
328 domain1 = get_domain1d(axes(i))
329 IF ( domain1 .NE. null_domain1d )
THEN
330 CALL get_diag_axis_cart(axes(i),cart)
333 domain1x = get_domain1d(axes(i))
334 CALL mpp_get_compute_domain(domain1x, xbegin, xend)
336 domain1y = get_domain1d(axes(i))
337 CALL mpp_get_compute_domain(domain1y, ybegin, yend)
342 CALL error_mesg(
'diag_util_mod::get_subfield_size',
'NO domain available', fatal)
347 CALL get_axes_shift(axes, ishift, jshift)
351 IF ( xbegin == -1 .OR. xend == -1 .OR. ybegin == -1 .OR. yend == -1 )
THEN
353 CALL error_mesg(
'diag_util_mod::get_subfield_size',
'wrong compute domain indices',fatal)
357 IF( gstart_indx(1) > xend .OR. xbegin > gend_indx(1) )
THEN
358 output_fields(outnum)%output_grid%l_start_indx(1) = -1
359 output_fields(outnum)%output_grid%l_end_indx(1) = -1
360 output_fields(outnum)%need_compute = .false.
361 ELSEIF ( gstart_indx(2) > yend .OR. ybegin > gend_indx(2) )
THEN
362 output_fields(outnum)%output_grid%l_start_indx(2) = -1
363 output_fields(outnum)%output_grid%l_end_indx(2) = -1
364 output_fields(outnum)%need_compute = .false.
366 output_fields(outnum)%output_grid%l_start_indx(1) = max(xbegin, gstart_indx(1))
367 output_fields(outnum)%output_grid%l_start_indx(2) = max(ybegin, gstart_indx(2))
368 output_fields(outnum)%output_grid%l_end_indx(1) = min(xend, gend_indx(1))
369 output_fields(outnum)%output_grid%l_end_indx(2) = min(yend, gend_indx(2))
370 output_fields(outnum)%need_compute = .true.
373 IF ( output_fields(outnum)%need_compute )
THEN
375 xbegin_l = output_fields(outnum)%output_grid%l_start_indx(1)
376 xend_l = output_fields(outnum)%output_grid%l_end_indx(1)
377 ybegin_l = output_fields(outnum)%output_grid%l_start_indx(2)
378 yend_l = output_fields(outnum)%output_grid%l_end_indx(2)
379 CALL mpp_modify_domain(domain2, domain2_new, xbegin_l,xend_l, ybegin_l,yend_l,&
380 & gstart_indx(1),gend_indx(1), gstart_indx(2),gend_indx(2))
382 output_fields(outnum)%output_grid%subaxes(1) =&
383 & diag_subaxes_init(axes(1),subaxis_x, gstart_indx(1),gend_indx(1),domain2_new)
384 output_fields(outnum)%output_grid%subaxes(2) =&
385 & diag_subaxes_init(axes(2),subaxis_y, gstart_indx(2),gend_indx(2),domain2_new)
386 DO i = 1,
SIZE(axes(:))
387 IF ( output_fields(outnum)%output_grid%subaxes(i) == -1 )
THEN
391 WRITE(msg,
'(a,"/",I4)')
'at i = ',i
392 CALL error_mesg(
'diag_util_mod::get_subfield_size '//trim(output_fields(outnum)%output_name),&
393 'error '//trim(msg), fatal)
398 output_fields(outnum)%output_grid%l_start_indx(1) = max(xbegin, gstart_indx(1)) - xbegin + 1
399 output_fields(outnum)%output_grid%l_start_indx(2) = max(ybegin, gstart_indx(2)) - ybegin + 1
400 output_fields(outnum)%output_grid%l_end_indx(1) = min(xend, gend_indx(1)) - xbegin + 1
401 output_fields(outnum)%output_grid%l_end_indx(2) = min(yend, gend_indx(2)) - ybegin + 1
402 IF (
SIZE(axes(:))>2 )
THEN
403 output_fields(outnum)%output_grid%l_start_indx(3) = gstart_indx(3)
404 output_fields(outnum)%output_grid%l_end_indx(3) = gend_indx(3)
406 output_fields(outnum)%output_grid%l_start_indx(3) = 1
407 output_fields(outnum)%output_grid%l_end_indx(3) = 1
410 IF (
ALLOCATED(subaxis_x) )
DEALLOCATE(subaxis_x, global_lon)
411 IF (
ALLOCATED(subaxis_y) )
DEALLOCATE(subaxis_y, global_lat)
416 INTEGER,
DIMENSION(:),
INTENT(in) :: axes
417 INTEGER,
INTENT(in) :: outnum
419 REAL,
DIMENSION(3) :: start
420 REAL,
DIMENSION(3) :: end
421 REAL,
ALLOCATABLE,
DIMENSION(:) :: global_depth
422 REAL,
ALLOCATABLE,
DIMENSION(:) :: subaxis_z
423 INTEGER :: i, global_axis_size
424 INTEGER,
DIMENSION(3) :: gstart_indx
425 INTEGER,
DIMENSION(3) :: gend_indx
426 CHARACTER(len=1) :: cart
427 CHARACTER(len=128) :: msg
430 integer :: vert_dim_num
440 start= output_fields(outnum)%output_grid%start
441 end = output_fields(outnum)%output_grid%end
447 DO i = 1,
SIZE(axes(:))
448 global_axis_size = get_axis_global_length(axes(i))
449 output_fields(outnum)%output_grid%subaxes(i) = -1
450 CALL get_diag_axis_cart(axes(i), cart)
454 IF ( i.NE.1 )
CALL error_mesg(
'diag_util_mod::get_subfield_vert_size',&
455 &
'wrong order of axes, X should come first',fatal)
457 gend_indx(i) = global_axis_size
458 output_fields(outnum)%output_grid%subaxes(i) = axes(i)
461 IF( i.NE.2 )
CALL error_mesg(
'diag_util_mod::get_subfield_vert_size',&
462 &
'wrong order of axes, Y should come second',fatal)
464 gend_indx(i) = global_axis_size
465 output_fields(outnum)%output_grid%subaxes(i) = axes(i)
470 call error_mesg(
"diag_util_mod::get_subfield_vert_size", &
471 "the unstructured axis must be the first dimension.", &
475 gend_indx(i) = global_axis_size
476 output_fields(outnum)%output_grid%subaxes(i) = axes(i)
478 start(vert_dim_num) = start(3)
479 end(vert_dim_num) = end(3)
484 if (i .ne. vert_dim_num)
then
485 call error_mesg(
"diag_util_mod::get_subfield_vert_size",&
486 "i should equal vert_dim_num for z axis", &
491 IF( start(i)*end(i) < 0. )
CALL error_mesg(
'diag_util_mod::get_subfield_vert_size',&
492 &
'wrong values in vertical axis of region',fatal)
493 IF( start(i) >= 0. .AND. end(i) > 0. )
THEN
494 ALLOCATE(global_depth(global_axis_size))
495 CALL get_diag_axis_data(axes(i),global_depth)
496 gstart_indx(i) =
get_index(start(i),global_depth)
497 IF( start(i) == 0.0 ) gstart_indx(i) = 1
499 gend_indx(i) =
get_index(end(i),global_depth)
500 IF( start(i) >= maxval(global_depth) ) gstart_indx(i)= global_axis_size
501 IF( end(i) >= maxval(global_depth) ) gend_indx(i) = global_axis_size
503 ALLOCATE(subaxis_z(gstart_indx(i):gend_indx(i)))
504 subaxis_z=global_depth(gstart_indx(i):gend_indx(i))
505 output_fields(outnum)%output_grid%subaxes(i) = &
506 diag_subaxes_init(axes(i),subaxis_z, gstart_indx(i),gend_indx(i))
507 DEALLOCATE(subaxis_z,global_depth)
510 gend_indx(i) = global_axis_size
511 output_fields(outnum)%output_grid%subaxes(i) = axes(i)
515 CALL error_mesg(
'diag_util_mod::get_subfield_vert_size',
'Wrong axis_cart', fatal)
519 DO i = 1,
SIZE(axes(:))
520 IF ( gstart_indx(i) == -1 .OR. gend_indx(i) == -1 )
THEN
525 WRITE(msg,
'(A,I2)')
' check region bounds for axis ', i
526 CALL error_mesg(
'diag_util_mod::get_subfield_vert_size',
'can not find gstart_indx/gend_indx for '&
527 & //trim(output_fields(outnum)%output_name)//
','//trim(msg), fatal)
532 output_fields(outnum)%output_grid%l_start_indx(i) = gstart_indx(i)
533 output_fields(outnum)%output_grid%l_end_indx(i) = gend_indx(i)
536 IF(
SIZE(axes(:)) > 2 )
THEN
537 output_fields(outnum)%output_grid%l_start_indx(3) = gstart_indx(3)
538 output_fields(outnum)%output_grid%l_end_indx(3) = gend_indx(3)
540 output_fields(outnum)%output_grid%l_start_indx(3) = 1
541 output_fields(outnum)%output_grid%l_end_indx(3) = 1
547 REAL,
INTENT(in) :: number
548 REAL,
INTENT(in),
DIMENSION(:) :: array
556 IF( (array(i-1)<array(i).AND.array(i)>array(i+1)) .OR. (array(i-1)>array(i).AND.array(i)<array(i+1)))
THEN
558 CALL error_mesg(
'diag_util_mod::get_index',
'array NOT monotonously ordered',fatal)
565 IF ( (array(i)<=number).AND.(array(i+1)>= number) )
THEN
566 IF( number - array(i) <= array(i+1) - number )
THEN
577 IF( .NOT.found )
THEN
579 IF ( (array(i)>=number).AND.(array(i+1)<= number) )
THEN
580 IF ( array(i)-number <= number-array(i+1) )
THEN
595 IF ( .NOT. found )
THEN
596 IF ( 2*array(1)-array(3).LT.number .AND. number.LT.array(1) )
THEN
599 ELSE IF ( array(n).LT.number .AND. number.LT.2*array(n)-array(n-2) )
THEN
610 IF ( .NOT. found )
THEN
611 IF ( 2*array(1)-array(3).GT.number .AND. number.GT.array(1) )
THEN
614 ELSE IF ( array(n).GT.number .AND. number.GT.2*array(n)-array(n-2) )
THEN
635 & missing_value, range, dynamic )
636 CHARACTER(len=*),
INTENT(in) :: module_name
637 CHARACTER(len=*),
INTENT(in) :: field_name
638 INTEGER,
DIMENSION(:),
INTENT(in) :: axes
639 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: long_name
640 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: units
641 CLASS(*),
OPTIONAL,
INTENT(in) :: missing_value
642 CLASS(*),
DIMENSION(:),
OPTIONAL,
INTENT(IN) :: range
643 LOGICAL,
OPTIONAL,
INTENT(in) :: dynamic
646 CHARACTER(len=256) :: lmodule, lfield, lname, lunits
647 CHARACTER(len=64) :: lmissval, lmin, lmax
648 CHARACTER(len=8) :: numaxis, timeaxis
649 CHARACTER(len=1) :: sep =
'|'
650 CHARACTER(len=256) :: axis_name, axes_list
652 REAL :: missing_value_use
653 REAL,
DIMENSION(2) :: range_use
655 IF ( .NOT.do_diag_field_log )
RETURN
656 IF (
mpp_pe().NE.mpp_root_pe() )
RETURN
659 IF (
PRESENT(range) )
THEN
660 IF (
SIZE(range) .NE. 2 )
THEN
661 CALL error_mesg(
'diag_util_mod::fms_log_field_info',
'extent of range should be 2', fatal)
665 lmodule = trim(module_name)
666 lfield = trim(field_name)
668 IF (
PRESENT(long_name) )
THEN
669 lname = trim(long_name)
674 IF (
PRESENT(units) )
THEN
680 WRITE (numaxis,
'(i1)')
SIZE(axes)
682 IF (
PRESENT(missing_value))
THEN
684 WRITE (lmissval,*) cmor_missing_value
686 SELECT TYPE (missing_value)
687 TYPE IS (real(kind=r4_kind))
688 missing_value_use = missing_value
689 TYPE IS (real(kind=r8_kind))
690 missing_value_use = real(missing_value)
692 CALL error_mesg (
'diag_util_mod::log_diag_field_info',&
693 &
'The missing_value is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
695 WRITE (lmissval,*) missing_value_use
701 IF (
PRESENT(range) )
THEN
703 TYPE IS (real(kind=r4_kind))
705 TYPE IS (real(kind=r8_kind))
706 range_use = real(range)
708 CALL error_mesg (
'diag_util_mod::log_diag_field_info',&
709 &
'The range is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
711 WRITE (lmin,*) range_use(1)
712 WRITE (lmax,*) range_use(2)
718 IF (
PRESENT(dynamic) )
THEN
730 CALL get_diag_axis_name(axes(i),axis_name)
731 IF ( trim(axes_list) /=
'' ) axes_list = trim(axes_list)//
','
732 axes_list = trim(axes_list)//trim(axis_name)
735 WRITE (diag_log_unit,
'(777a)') &
746 SUBROUTINE update_bounds(out_num, lower_i, upper_i, lower_j, upper_j, lower_k, upper_k)
747 INTEGER,
INTENT(in) :: out_num
748 INTEGER,
INTENT(in) :: lower_i
749 INTEGER,
INTENT(in) :: upper_i
750 INTEGER,
INTENT(in) :: lower_j
751 INTEGER,
INTENT(in) :: upper_j
752 INTEGER,
INTENT(in) :: lower_k
753 INTEGER,
INTENT(in) :: upper_k
754 CALL output_fields(out_num)%buff_bounds%update_bounds &
755 & ( lower_i, upper_i, lower_j, upper_j, lower_k, upper_k )
767 TYPE (fmsdiagibounds_type),
INTENT(in) :: current_bounds
769 TYPE (fmsdiagibounds_type),
INTENT(in):: bounds
770 CHARACTER(*),
INTENT(out) :: error_str
775 LOGICAL FUNCTION lowerb_comp(a , b)
776 INTEGER,
INTENT(IN) :: a
777 INTEGER,
INTENT(IN) :: b
778 END FUNCTION lowerb_comp
783 LOGICAL FUNCTION upperb_comp(a, b)
784 INTEGER,
INTENT(IN) :: a
785 INTEGER,
INTENT(IN) :: b
786 END FUNCTION upperb_comp
791 IF (lowerb_comp( bounds%get_imin() , current_bounds%get_imin()) .OR. &
792 upperb_comp( bounds%get_imax() , current_bounds%get_imax()).OR.&
793 lowerb_comp( bounds%get_jmin() , current_bounds%get_jmin()) .OR.&
794 upperb_comp( bounds%get_jmax() , current_bounds%get_jmax()) .OR.&
795 lowerb_comp( bounds%get_kmin() , current_bounds%get_kmin()) .OR.&
796 upperb_comp( bounds%get_kmax() , current_bounds%get_kmax()))
THEN
798 error_str =
'Buffer bounds= : , : , : Actual bounds= : , : , : '
799 WRITE(error_str(15:17),
'(i3)') current_bounds%get_imin()
800 WRITE(error_str(19:21),
'(i3)') current_bounds%get_imax()
801 WRITE(error_str(23:25),
'(i3)') current_bounds%get_jmin()
802 WRITE(error_str(27:29),
'(i3)') current_bounds%get_jmax()
803 WRITE(error_str(31:33),
'(i3)') current_bounds%get_kmin()
804 WRITE(error_str(35:37),
'(i3)') current_bounds%get_kmax()
805 WRITE(error_str(54:56),
'(i3)') bounds%get_imin()
806 WRITE(error_str(58:60),
'(i3)') bounds%get_imax()
807 WRITE(error_str(62:64),
'(i3)') bounds%get_jmin()
808 WRITE(error_str(66:68),
'(i3)') bounds%get_jmax()
809 WRITE(error_str(70:72),
'(i3)') bounds%get_kmin()
810 WRITE(error_str(74:76),
'(i3)') bounds%get_kmax()
819 INTEGER,
INTENT(IN) :: a
820 INTEGER,
INTENT(IN) :: b
826 INTEGER,
INTENT(IN) :: a
827 INTEGER,
INTENT(IN) :: b
833 INTEGER,
INTENT(IN) :: a
834 INTEGER,
INTENT(IN) :: b
842 INTEGER,
INTENT(in) :: out_num
843 INTEGER,
INTENT(in) :: diag_field_id
844 CHARACTER(len=*),
INTENT(out) :: err_msg
847 CHARACTER(len=128) :: error_string1, error_string2
848 LOGICAL :: out_of_bounds = .true.
849 TYPE (fmsdiagibounds_type) :: array_bounds
850 associate(buff_bounds => output_fields(out_num)%buff_bounds)
852 CALL array_bounds%reset_bounds_from_array_4D(output_fields(out_num)%buffer)
857 IF (out_of_bounds .EQV. .true.)
THEN
858 WRITE(error_string1,
'(a,"/",a)') trim(input_fields(diag_field_id)%module_name), &
859 & trim(output_fields(out_num)%output_name)
860 err_msg =
'module/output_field='//trim(error_string1)//&
861 &
' Bounds of buffer exceeded. '//trim(error_string2)
863 call buff_bounds%reset(very_large_axis_length, 0)
874 REAL(kind=r4_kind),
INTENT (in),
DIMENSION(:,:,:,:,:) :: ofb
875 TYPE (fmsDiagIbounds_type),
INTENT(inout) :: bounds
876 CHARACTER(:),
ALLOCATABLE,
INTENT(in) :: output_name
877 CHARACTER(:),
ALLOCATABLE,
INTENT(in) :: module_name
878 CHARACTER(len=*),
INTENT(inout) :: err_msg
881 CHARACTER(len=128) :: error_string1, error_string2
882 LOGICAL :: out_of_bounds = .true.
883 TYPE (fmsDiagIbounds_type) :: array_bounds
885 CALL array_bounds%reset_bounds_from_array_5D(ofb)
890 IF (out_of_bounds .EQV. .true.)
THEN
891 WRITE(error_string1,
'(a,"/",a)') trim(module_name), trim(output_name)
892 err_msg =
'module/output_field='//trim(error_string1)//&
893 &
' Bounds of buffer exceeded. '//trim(error_string2)
895 call bounds%reset(very_large_axis_length,0)
906 REAL(kind=r8_kind),
INTENT (in),
DIMENSION(:,:,:,:,:) :: ofb
907 TYPE (fmsDiagIbounds_type),
INTENT(inout) :: bounds
908 CHARACTER(:),
ALLOCATABLE,
INTENT(in) :: output_name
909 CHARACTER(:),
ALLOCATABLE,
INTENT(in) :: module_name
910 CHARACTER(len=*),
INTENT(out) :: err_msg
913 CHARACTER(len=128) :: error_string1, error_string2
914 LOGICAL :: out_of_bounds = .true.
915 TYPE (fmsDiagIbounds_type) :: array_bounds
917 CALL array_bounds%reset_bounds_from_array_5D(ofb)
922 IF (out_of_bounds .EQV. .true.)
THEN
923 WRITE(error_string1,
'(a,"/",a)') trim(module_name), trim(output_name)
924 err_msg =
'module/output_field='//trim(error_string1)//&
925 &
' Bounds of buffer exceeded. '//trim(error_string2)
927 call bounds%reset(very_large_axis_length,0)
939 & Time, field_prev_Time, err_msg)
940 TYPE (fmsdiagibounds_type),
INTENT(in) :: current_bounds
942 TYPE (fmsdiagibounds_type),
INTENT(inout) :: bounds
943 CHARACTER(:),
ALLOCATABLE,
INTENT(in) :: output_name
944 CHARACTER(:),
ALLOCATABLE,
INTENT(in) :: module_name
945 TYPE(time_type),
INTENT(in) :: time
948 TYPE(time_type),
INTENT(inout) :: field_prev_time
949 CHARACTER(len=*),
INTENT(out) :: err_msg
953 CHARACTER(len=128) :: error_string1, error_string2
955 LOGICAL :: lims_not_exact
962 IF ( time == field_prev_time )
THEN
965 IF ( field_prev_time == time_zero )
THEN
972 field_prev_time = time
978 IF( lims_not_exact .eqv. .true.)
THEN
979 WRITE(error_string1,
'(a,"/",a)') trim(module_name), trim(output_name)
980 err_msg = trim(error_string1)//
' Bounds of data do not match those of buffer. '//trim(error_string2)
982 call bounds%reset(very_large_axis_length, 0)
990 INTEGER,
INTENT(in) :: out_num
991 INTEGER,
INTENT(in) :: diag_field_id
992 TYPE(time_type),
INTENT(in) :: time
995 CHARACTER(len=*),
INTENT(out) :: err_msg
998 CHARACTER(:),
ALLOCATABLE :: output_name
999 CHARACTER(:),
ALLOCATABLE :: module_name
1000 TYPE (fmsdiagibounds_type) :: current_bounds
1002 output_name = output_fields(out_num)%output_name
1003 module_name = input_fields(diag_field_id)%module_name
1005 CALL current_bounds%reset_bounds_from_array_4D(output_fields(out_num)%buffer)
1008 & output_name, module_name, &
1009 & time, output_fields(out_num)%Time_of_prev_field_data, err_msg)
1017 INTEGER,
INTENT(in) :: out_num
1018 INTEGER,
INTENT(in) :: diag_field_id
1019 CHARACTER(len=*),
INTENT(out) :: err_msg
1021 CHARACTER(:),
ALLOCATABLE :: output_name
1022 CHARACTER(:),
ALLOCATABLE :: module_name
1023 TYPE (fmsdiagibounds_type) :: current_bounds
1025 output_name = output_fields(out_num)%output_name
1026 module_name = input_fields(diag_field_id)%module_name
1028 CALL current_bounds%reset_bounds_from_array_4D(output_fields(out_num)%buffer)
1031 & output_name, module_name, err_msg)
1039 TYPE (fmsdiagibounds_type),
INTENT(in) :: current_bounds
1041 TYPE (fmsdiagibounds_type),
INTENT(inout) :: bounds
1042 CHARACTER(:),
ALLOCATABLE,
INTENT(in) :: output_name
1043 CHARACTER(:),
ALLOCATABLE,
INTENT(in) :: module_name
1044 CHARACTER(len=*),
INTENT(out) :: err_msg
1047 CHARACTER(len=128) :: error_string1, error_string2
1048 LOGICAL :: lims_not_exact
1053 IF( lims_not_exact .eqv. .true.)
THEN
1054 WRITE(error_string1,
'(a,"/",a)') trim(module_name), trim(output_name)
1055 err_msg = trim(error_string1)//
' Bounds of data do not match those of buffer. '//trim(error_string2)
1057 call bounds%reset(very_large_axis_length, 0)
1062 SUBROUTINE init_file(name, output_freq, output_units, format, time_units, long_name, tile_count,&
1063 & new_file_freq, new_file_freq_units, start_time, file_duration, file_duration_units, filename_time_bounds)
1064 CHARACTER(len=*),
INTENT(in) :: name
1065 CHARACTER(len=*),
INTENT(in) :: long_name
1066 INTEGER,
INTENT(in) :: output_freq
1067 INTEGER,
INTENT(in) :: output_units
1068 INTEGER,
INTENT(in) :: format
1069 INTEGER,
INTENT(in) :: time_units
1070 INTEGER,
INTENT(in) :: tile_count
1071 INTEGER,
INTENT(in),
OPTIONAL :: new_file_freq
1072 INTEGER,
INTENT(in),
OPTIONAL :: new_file_freq_units
1073 INTEGER,
INTENT(in),
OPTIONAL :: file_duration
1074 INTEGER,
INTENT(in),
OPTIONAL :: file_duration_units
1075 TYPE(time_type),
INTENT(in),
OPTIONAL :: start_time
1076 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: filename_time_bounds
1078 INTEGER :: new_file_freq1, new_file_freq_units1
1079 INTEGER :: file_duration1, file_duration_units1
1081 LOGICAL :: same_file_err
1084 REAL,
DIMENSION(1) :: tdata
1085 CHARACTER(len=128) :: time_units_str
1088 same_file_err=.false.
1091 IF ( trim(files(n)%name) == trim(name) )
THEN
1094 IF ( files(n)%output_freq.NE.output_freq .OR.&
1095 & files(n)%output_units.NE.output_units .OR.&
1096 & files(n)%format.NE.
format .OR.&
1097 & files(n)%time_units.NE.time_units .OR.&
1098 & trim(files(n)%long_name).NE.trim(long_name) .OR.&
1099 & files(n)%tile_count.NE.tile_count )
THEN
1100 same_file_err=.true.
1104 IF (
PRESENT(new_file_freq) )
THEN
1105 IF ( files(n)%new_file_freq.NE.new_file_freq )
THEN
1106 same_file_err=.true.
1110 IF (
PRESENT(new_file_freq_units) )
THEN
1111 IF ( files(n)%new_file_freq_units.NE.new_file_freq_units )
THEN
1112 same_file_err=.true.
1116 IF (
PRESENT(start_time) )
THEN
1117 IF ( files(n)%start_time==start_time )
THEN
1118 same_file_err=.true.
1122 IF (
PRESENT(file_duration) )
THEN
1123 IF ( files(n)%duration.NE.file_duration)
THEN
1124 same_file_err=.true.
1128 IF (
PRESENT(file_duration_units) )
THEN
1129 IF ( files(n)%duration_units.NE.file_duration_units )
THEN
1130 same_file_err=.true.
1135 IF ( same_file_err )
THEN
1138 CALL error_mesg(
'diag_util_mod::init_file',&
1139 &
'The file "'//trim(name)//
'" is defined multiple times in&
1140 & the diag_table.', fatal)
1143 CALL error_mesg(
'diag_util_mod::init_file',&
1144 &
'The file "'//trim(name)//
'" is defined multiple times in&
1145 & the diag_table.', note)
1153 num_files = num_files + 1
1154 IF ( num_files >= max_files )
THEN
1159 CALL error_mesg(
'diag_util_mod::init_file',&
1160 &
' max_files exceeded, increase max_files via the max_files variable&
1161 & in the namelist diag_manager_nml.', fatal)
1164 IF (
PRESENT(new_file_freq) )
THEN
1165 new_file_freq1 = new_file_freq
1167 new_file_freq1 = very_large_file_freq
1170 IF (
PRESENT(new_file_freq_units) )
THEN
1171 new_file_freq_units1 = new_file_freq_units
1172 ELSE IF ( get_calendar_type() == no_calendar )
THEN
1173 new_file_freq_units1 = diag_days
1175 new_file_freq_units1 = diag_years
1178 IF (
PRESENT(file_duration) )
THEN
1179 file_duration1 = file_duration
1181 file_duration1 = new_file_freq1
1184 IF (
PRESENT(file_duration_units) )
THEN
1185 file_duration_units1 = file_duration_units
1187 file_duration_units1 = new_file_freq_units1
1190 files(num_files)%tile_count = tile_count
1191 files(num_files)%name = trim(name)
1192 files(num_files)%output_freq = output_freq
1193 files(num_files)%output_units = output_units
1194 files(num_files)%format =
FORMAT
1195 files(num_files)%time_units = time_units
1196 files(num_files)%long_name = trim(long_name)
1197 files(num_files)%num_fields = 0
1198 files(num_files)%local = .false.
1199 files(num_files)%last_flush = get_base_time()
1200 files(num_files)%file_unit = -1
1201 files(num_files)%new_file_freq = new_file_freq1
1202 files(num_files)%new_file_freq_units = new_file_freq_units1
1203 files(num_files)%duration = file_duration1
1204 files(num_files)%duration_units = file_duration_units1
1206 files(num_files)%rtime_current = -1.0
1207 files(num_files)%time_index = 0
1208 files(num_files)%filename_time_bounds = filename_time_bounds
1210 IF (
PRESENT(start_time) )
THEN
1211 files(num_files)%start_time = start_time
1213 files(num_files)%start_time = get_base_time()
1215 files(num_files)%next_open=diag_time_inc(files(num_files)%start_time,new_file_freq1,new_file_freq_units1)
1216 files(num_files)%close_time = diag_time_inc(files(num_files)%start_time,file_duration1, file_duration_units1)
1217 IF ( files(num_files)%close_time>files(num_files)%next_open )
THEN
1222 CALL error_mesg(
'diag_util_mod::init_file',
'close time GREATER than next_open time, check file duration,&
1223 & file frequency in '//files(num_files)%name, fatal)
1227 WRITE(time_units_str, 11) trim(time_unit_list(files(num_files)%time_units)), get_base_year(),&
1228 & get_base_month(), get_base_day(), get_base_hour(), get_base_minute(), get_base_second()
1229 11
FORMAT(a,
' since ', i4.4,
'-', i2.2,
'-', i2.2,
' ', i2.2,
':', i2.2,
':', i2.2)
1230 files(num_files)%time_axis_id = diag_axis_init(trim(long_name), tdata, time_units_str,
'T',&
1231 & trim(long_name) , set_name=trim(name) )
1233 files(num_files)%time_bounds_id = diag_axis_init(
'nv',(/1.,2./),
'none',
'N',
'vertex number',&
1244 INTEGER,
INTENT(in) :: file_id
1245 TYPE(time_type),
INTENT(in) :: init_time
1246 CHARACTER(len=*),
OPTIONAL,
INTENT(out) :: err_msg
1248 CHARACTER(len=128) :: msg
1250 IF (
PRESENT(err_msg) ) err_msg =
''
1252 IF ( files(file_id)%start_time < init_time )
THEN
1254 files(file_id)%start_time = init_time
1256 files(file_id)%close_time = diag_time_inc(files(file_id)%start_time,&
1257 & files(file_id)%duration, files(file_id)%duration_units)
1261 DO WHILE ( files(file_id)%next_open <= init_time )
1262 files(file_id)%next_open = diag_time_inc(files(file_id)%next_open,&
1263 & files(file_id)%new_file_freq, files(file_id)%new_file_freq_units, err_msg=msg)
1264 IF ( msg /=
'' )
THEN
1265 IF ( fms_error_handler(
'diag_util_mod::sync_file_times',&
1266 &
' file='//trim(files(file_id)%name)//
': '//trim(msg), err_msg) )
RETURN
1274 INTEGER,
INTENT(in) :: tile_count
1275 CHARACTER(len=*),
INTENT(in) :: name
1281 IF( trim(files(i)%name) == trim(name) .AND. tile_count == files(i)%tile_count )
THEN
1291 CHARACTER(len=*),
INTENT(in) :: module_name
1292 CHARACTER(len=*),
INTENT(in) :: field_name
1293 INTEGER,
INTENT(in) :: tile_count
1298 DO i = 1, num_input_fields
1299 IF(tile_count == input_fields(i)%tile_count .AND.&
1300 & trim(input_fields(i)%module_name) == trim(module_name) .AND.&
1301 & lowercase(trim(input_fields(i)%field_name)) == lowercase(trim(field_name)))
THEN
1310 CHARACTER(len=*),
INTENT(in) :: module_name
1311 CHARACTER(len=*),
INTENT(in) :: field_name
1312 INTEGER,
INTENT(in) :: tile_count
1316 num_input_fields = num_input_fields + 1
1317 IF ( num_input_fields > max_input_fields )
THEN
1319 CALL error_mesg(
'diag_util_mod::init_input_field',&
1320 &
'max_input_fields exceeded, increase it via diag_manager_nml', fatal)
1327 input_fields(num_input_fields)%module_name = trim(module_name)
1328 input_fields(num_input_fields)%field_name = trim(field_name)
1329 input_fields(num_input_fields)%num_output_fields = 0
1331 input_fields(num_input_fields)%register = .false.
1332 input_fields(num_input_fields)%local = .false.
1333 input_fields(num_input_fields)%standard_name =
'none'
1334 input_fields(num_input_fields)%tile_count = tile_count
1335 input_fields(num_input_fields)%numthreads = 1
1336 input_fields(num_input_fields)%active_omp_level = 0
1337 input_fields(num_input_fields)%time = time_zero
1342 & time_method, pack, tile_count, local_coord)
1343 CHARACTER(len=*),
INTENT(in) :: module_name
1344 CHARACTER(len=*),
INTENT(in) :: field_name
1345 CHARACTER(len=*),
INTENT(in) :: output_name
1346 CHARACTER(len=*),
INTENT(in) :: output_file
1347 CHARACTER(len=*),
INTENT(in) :: time_method
1350 INTEGER,
INTENT(in) :: pack
1351 INTEGER,
INTENT(in) :: tile_count
1352 TYPE(coord_type),
INTENT(in),
OPTIONAL :: local_coord
1354 INTEGER :: out_num, in_num, file_num, file_num_tile1
1355 INTEGER :: num_fields, i, method_selected, l1
1360 CHARACTER(len=128) :: error_msg
1361 CHARACTER(len=50) :: t_method
1362 character(len=256) :: tmp_name
1366 IF ( region_out_use_alt_value )
THEN
1367 grv = glo_reg_val_alt
1374 num_output_fields = num_output_fields + 1
1375 IF ( num_output_fields > max_output_fields )
THEN
1377 WRITE (unit=error_msg,fmt=*) max_output_fields
1378 CALL error_mesg(
'diag_util_mod::init_output_field',
'max_output_fields = '//trim(error_msg)//
' exceeded.&
1379 & Increase via diag_manager_nml', fatal)
1381 out_num = num_output_fields
1385 IF ( in_num < 0 )
THEN
1386 IF ( tile_count > 1 )
THEN
1387 WRITE (error_msg,
'(A,"/",A,"/",A)') trim(module_name),trim(field_name),&
1388 &
"tile_count="//trim(string(tile_count))
1390 WRITE (error_msg,
'(A,"/",A)') trim(module_name),trim(field_name)
1394 CALL error_mesg(
'diag_util_mod::init_output_field',&
1395 &
'module_name/field_name '//trim(error_msg)//
' NOT registered', fatal)
1399 input_fields(in_num)%num_output_fields =&
1400 & input_fields(in_num)%num_output_fields + 1
1401 IF ( input_fields(in_num)%num_output_fields > max_out_per_in_field )
THEN
1407 WRITE (unit=error_msg,fmt=*) max_out_per_in_field
1408 CALL error_mesg(
'diag_util_mod::init_output_field',&
1409 &
'MAX_OUT_PER_IN_FIELD exceeded for '//trim(module_name)//
"/"//trim(field_name)//&
1410 &
', increase MAX_OUT_PER_IN_FIELD in the diag_manager_nml namelist', fatal)
1412 input_fields(in_num)%output_fields(input_fields(in_num)%num_output_fields) = out_num
1415 output_fields(out_num)%input_field = in_num
1418 IF ( trim(output_file).EQ.
'null' )
THEN
1419 file_num = max_files
1422 IF ( file_num < 0 )
THEN
1426 CALL error_mesg(
'diag_util_mod::init_output_field',
'file '&
1427 & //trim(output_file)//
' is NOT found in the diag_table', fatal)
1429 IF ( tile_count > 1 )
THEN
1430 file_num_tile1 = file_num
1431 file_num =
find_file(output_file, tile_count)
1432 IF(file_num < 0)
THEN
1433 CALL init_file(files(file_num_tile1)%name, files(file_num_tile1)%output_freq,&
1434 & files(file_num_tile1)%output_units, files(file_num_tile1)%format,&
1435 & files(file_num_tile1)%time_units, files(file_num_tile1)%long_name,&
1436 & tile_count, files(file_num_tile1)%new_file_freq,&
1437 & files(file_num_tile1)%new_file_freq_units, files(file_num_tile1)%start_time,&
1438 & files(file_num_tile1)%duration, files(file_num_tile1)%duration_units )
1439 file_num =
find_file(output_file, tile_count)
1440 IF ( file_num < 0 )
THEN
1444 CALL error_mesg(
'diag_util_mod::init_output_field',
'file '//trim(output_file)//&
1445 &
' is not initialized for tile_count = '//trim(string(tile_count)), fatal)
1452 files(file_num)%num_fields = files(file_num)%num_fields + 1
1453 IF ( files(file_num)%num_fields > max_fields_per_file )
THEN
1454 WRITE (unit=error_msg, fmt=*) max_fields_per_file
1458 CALL error_mesg(
'diag_util_mod::init_output_field',&
1459 &
'MAX_FIELDS_PER_FILE = '//trim(error_msg)// &
1460 &
' exceeded. Increase MAX_FIELDS_PER_FILE in diag_data.F90.', fatal)
1462 num_fields = files(file_num)%num_fields
1463 files(file_num)%fields(num_fields) = out_num
1466 output_fields(out_num)%output_file = file_num
1469 output_fields(out_num)%output_name = trim(output_name)
1470 output_fields(out_num)%pack = pack
1471 output_fields(out_num)%pow_value = 1
1472 output_fields(out_num)%num_axes = 0
1473 output_fields(out_num)%total_elements = 0
1474 output_fields(out_num)%region_elements = 0
1476 call output_fields(out_num)%buff_bounds%reset(very_large_axis_length, 0)
1479 output_fields(out_num)%n_diurnal_samples = 1
1483 output_fields(out_num)%time_average = .false.
1484 output_fields(out_num)%time_rms = .false.
1485 output_fields(out_num)%time_min = .false.
1486 output_fields(out_num)%time_max = .false.
1487 output_fields(out_num)%time_sum = .false.
1488 output_fields(out_num)%time_ops = .false.
1489 output_fields(out_num)%written_once = .false.
1491 t_method = lowercase(time_method)
1493 IF ( files(file_num)%output_freq == every_time )
THEN
1494 output_fields(out_num)%time_average = .false.
1495 method_selected = method_selected+1
1497 ELSEIF ( index(t_method,
'diurnal') == 1 )
THEN
1499 READ (unit=t_method(8:len_trim(t_method)), fmt=*, iostat=ioerror) output_fields(out_num)%n_diurnal_samples
1500 IF ( ioerror /= 0 )
THEN
1504 CALL error_mesg(
'diag_util_mod::init_output_field',&
1505 &
'could not find integer number of diurnal samples in string "' //trim(t_method)//
'"', fatal)
1506 ELSE IF ( output_fields(out_num)%n_diurnal_samples <= 0 )
THEN
1510 CALL error_mesg(
'diag_util_mod::init_output_field',&
1511 &
'The integer value of diurnal samples must be greater than zero.', fatal)
1513 output_fields(out_num)%time_average = .true.
1514 method_selected = method_selected+1
1516 ELSEIF ( index(t_method,
'pow') == 1 )
THEN
1518 READ (unit=t_method(4:len_trim(t_method)), fmt=*, iostat=ioerror) pow_value
1519 IF ( ioerror /= 0 .OR. output_fields(out_num)%pow_value < 1 .OR. floor(pow_value) /= ceiling(pow_value) )
THEN
1523 CALL error_mesg(
'diag_util_mod::init_output_field',&
1524 &
'Invalid power number in time operation "'//trim(t_method)//
'". Must be a positive integer', fatal)
1526 output_fields(out_num)%pow_value = int(pow_value)
1527 output_fields(out_num)%time_average = .true.
1528 method_selected = method_selected+1
1529 t_method =
'mean_pow('//t_method(4:len_trim(t_method))//
')'
1531 SELECT CASE(trim(t_method))
1532 CASE (
'.true.',
'mean',
'average',
'avg' )
1533 output_fields(out_num)%time_average = .true.
1534 method_selected = method_selected+1
1537 output_fields(out_num)%time_average = .true.
1538 output_fields(out_num)%time_rms = .true.
1539 output_fields(out_num)%pow_value = 2.0
1540 method_selected = method_selected+1
1541 t_method =
'root_mean_square'
1542 CASE (
'.false.',
'none',
'point' )
1543 output_fields(out_num)%time_average = .false.
1544 method_selected = method_selected+1
1546 CASE (
'maximum',
'max' )
1547 output_fields(out_num)%time_max = .true.
1548 l1 = len_trim(output_fields(out_num)%output_name)
1550 tmp_name = trim(adjustl(output_fields(out_num)%output_name(l1-2:l1)))
1551 IF (lowercase(trim(tmp_name)) /=
'max' )
then
1552 output_fields(out_num)%output_name = trim(output_name)//
'_max'
1555 method_selected = method_selected+1
1557 CASE (
'minimum',
'min' )
1558 output_fields(out_num)%time_min = .true.
1559 l1 = len_trim(output_fields(out_num)%output_name)
1561 tmp_name = trim(adjustl(output_fields(out_num)%output_name(l1-2:l1)))
1562 IF (lowercase(trim(tmp_name)) /=
'min' )
then
1563 output_fields(out_num)%output_name = trim(output_name)//
'_min'
1566 method_selected = method_selected+1
1568 CASE (
'sum',
'cumsum' )
1569 output_fields(out_num)%time_sum = .true.
1570 l1 = len_trim(output_fields(out_num)%output_name)
1571 IF ( output_fields(out_num)%output_name(l1-2:l1) /=
'sum' )&
1572 & output_fields(out_num)%output_name = trim(output_name)//
'_sum'
1573 method_selected = method_selected+1
1579 output_fields(out_num)%time_ops = output_fields(out_num)%time_min.OR.output_fields(out_num)%time_max&
1580 & .OR.output_fields(out_num)%time_average .OR. output_fields(out_num)%time_sum
1582 output_fields(out_num)%phys_window = .false.
1584 IF (
PRESENT(local_coord) )
THEN
1585 input_fields(in_num)%local = .true.
1586 input_fields(in_num)%local_coord = local_coord
1587 IF ( int(local_coord%xbegin) == grv .AND. int(local_coord%xend) == grv .AND.&
1588 & int(local_coord%ybegin) == grv .AND. int(local_coord%yend) == grv )
THEN
1589 output_fields(out_num)%local_output = .false.
1590 output_fields(out_num)%need_compute = .false.
1591 output_fields(out_num)%reduced_k_range = .true.
1593 output_fields(out_num)%local_output = .true.
1594 output_fields(out_num)%need_compute = .false.
1595 output_fields(out_num)%reduced_k_range = .false.
1598 output_fields(out_num)%output_grid%start(1) = local_coord%xbegin
1599 output_fields(out_num)%output_grid%start(2) = local_coord%ybegin
1600 output_fields(out_num)%output_grid%start(3) = local_coord%zbegin
1601 output_fields(out_num)%output_grid%end(1) = local_coord%xend
1602 output_fields(out_num)%output_grid%end(2) = local_coord%yend
1603 output_fields(out_num)%output_grid%end(3) = local_coord%zend
1605 output_fields(out_num)%output_grid%l_start_indx(i) = -1
1606 output_fields(out_num)%output_grid%l_end_indx(i) = -1
1607 output_fields(out_num)%output_grid%subaxes(i) = -1
1610 output_fields(out_num)%local_output = .false.
1611 output_fields(out_num)%need_compute = .false.
1612 output_fields(out_num)%reduced_k_range = .false.
1618 IF ( method_selected /= 1 )
CALL error_mesg(
'diag_util_mod::init_output_field',&
1619 &
'improper time method in diag_table for output field:'//trim(output_name),fatal)
1621 output_fields(out_num)%time_method = trim(t_method)
1626 ALLOCATE(output_fields(out_num)%count_0d(output_fields(out_num)%n_diurnal_samples))
1627 ALLOCATE(output_fields(out_num)%num_elements(output_fields(out_num)%n_diurnal_samples))
1628 output_fields(out_num)%count_0d(:) = 0
1629 output_fields(out_num)%num_elements(:) = 0
1630 output_fields(out_num)%num_attributes = 0
1636 INTEGER,
INTENT(in) :: file
1637 TYPE(time_type),
INTENT(in) :: time
1638 TYPE(time_type),
INTENT(in),
optional :: filename_time
1641 TYPE(time_type) :: fname_time
1642 REAL,
DIMENSION(2) :: open_file_data
1643 INTEGER :: j, field_num, input_field_num, num_axes, k
1644 INTEGER :: field_num1
1646 INTEGER :: dir, edges
1647 INTEGER :: year, month, day, hour, minute, second
1648 INTEGER,
DIMENSION(1) :: time_axis_id, time_bounds_id
1652 INTEGER,
DIMENSION(6) :: axes
1653 INTEGER,
ALLOCATABLE :: axesc(:)
1654 LOGICAL :: time_ops, aux_present, match_aux_name, req_present, match_req_fields
1655 CHARACTER(len=7) :: avg_name =
'average'
1656 CHARACTER(len=128) :: time_units, timeb_units, avg, error_string, aux_name, req_fields, fieldname
1657 CHARACTER(len=FMS_FILE_LEN) :: filename
1658 CHARACTER(len=128) :: suffix, base_name
1659 CHARACTER(len=32) :: time_name, timeb_name,time_longname, timeb_longname, cart_name
1660 CHARACTER(len=FMS_FILE_LEN) :: fname
1661 CHARACTER(len=24) :: start_date
1662 TYPE(domain1d) :: domain
1663 TYPE(domain2d) :: domain2
1664 TYPE(domainug) :: domainU
1665 INTEGER :: is, ie, last, ind
1666 class(fmsnetcdffile_t),
pointer :: fileob
1667 integer :: actual_num_axes
1669 aux_present = .false.
1670 match_aux_name = .false.
1671 req_present = .false.
1672 match_req_fields = .false.
1675 WRITE (time_units, 11) trim(time_unit_list(files(file)%time_units)), get_base_year(),&
1676 & get_base_month(), get_base_day(), get_base_hour(), get_base_minute(), get_base_second()
1677 11
FORMAT(a,
' since ', i4.4,
'-', i2.2,
'-', i2.2,
' ', i2.2,
':', i2.2,
':', i2.2)
1678 base_name = files(file)%name
1679 IF ( files(file)%new_file_freq < very_large_file_freq )
THEN
1680 position = index(files(file)%name,
'%')
1681 IF ( position > 0 )
THEN
1682 base_name = base_name(1:position-1)
1687 CALL error_mesg(
'diag_util_mod::opening_file',&
1688 &
'file name '//trim(files(file)%name)//
' does not contain % for time stamp string', fatal)
1690 if (
present(filename_time))
then
1691 fname_time = filename_time
1695 suffix = get_time_string(files(file)%name, fname_time)
1702 call get_instance_filename(fname, base_name)
1705 filename = trim(base_name)//trim(suffix)
1708 IF ( prepend_date )
THEN
1709 call get_date(diag_init_time, year, month, day, hour, minute, second)
1710 write (start_date,
'(1I20.4, 2I2.2)') year, month, day
1712 filename = trim(adjustl(start_date))//
'.'//trim(filename)
1717 domain2 = null_domain2d
1718 domainu = null_domainug
1719 DO j = 1, files(file)%num_fields
1720 field_num = files(file)%fields(j)
1721 if (output_fields(field_num)%local_output .AND. .NOT. output_fields(field_num)%need_compute) cycle
1722 num_axes = output_fields(field_num)%num_axes
1723 IF ( num_axes > 1 )
THEN
1724 domain2 = get_domain2d( output_fields(field_num)%axes(1:num_axes) )
1725 domainu = get_domainug( output_fields(field_num)%axes(1) )
1726 IF ( domain2 .NE. null_domain2d )
EXIT
1727 ELSEIF (num_axes == 1)
THEN
1728 if (domainu .EQ. null_domainug)
then
1729 domainu = get_domainug( output_fields(field_num)%axes(num_axes) )
1734 IF (domainu .NE. null_domainug .AND. domain2 .NE. null_domain2d)
THEN
1735 CALL error_mesg(
'diag_util_mod::opening_file', &
1736 'Domain2 and DomainU are somehow both set.', &
1740 IF (
allocated(files(file)%attributes) )
THEN
1741 CALL diag_output_init(filename, global_descriptor,&
1742 & files(file)%file_unit, domain2, domainu,&
1743 & fileobj(file),fileobju(file), fileobjnd(file), fnum_for_domain(file),&
1744 & attributes=files(file)%attributes(1:files(file)%num_attributes))
1746 CALL diag_output_init(filename, global_descriptor,&
1747 & files(file)%file_unit, domain2,domainu, &
1748 & fileobj(file),fileobju(file),fileobjnd(file),fnum_for_domain(file))
1751 files(file)%bytes_written = 0
1754 DO j = 1, files(file)%num_fields
1755 field_num = files(file)%fields(j)
1756 IF ( output_fields(field_num)%time_ops )
THEN
1762 DO j = 1, files(file)%num_fields
1763 field_num = files(file)%fields(j)
1764 input_field_num = output_fields(field_num)%input_field
1765 IF (.NOT.input_fields(input_field_num)%register)
THEN
1766 WRITE (error_string,
'(A,"/",A)') trim(input_fields(input_field_num)%module_name),&
1767 & trim(input_fields(input_field_num)%field_name)
1768 IF(
mpp_pe() .EQ. mpp_root_pe())
THEN
1769 CALL error_mesg(
'diag_util_mod::opening_file',&
1770 &
'module/field_name ('//trim(error_string)//
') NOT registered', warning)
1774 if (output_fields(field_num)%local_output .AND. .NOT. output_fields(field_num)%need_compute) cycle
1777 num_axes = output_fields(field_num)%num_axes
1778 axes(1:num_axes) = output_fields(field_num)%axes(1:num_axes)
1781 IF ( axes(k) < 0 )
THEN
1782 WRITE(error_string,
'(a)') output_fields(field_num)%output_name
1786 CALL error_mesg(
'diag_util_mod::opening_file',
'output_name '//trim(error_string)//&
1787 &
' has axis_id = -1', fatal)
1791 IF ( .NOT.aux_present )
THEN
1793 aux_name = get_axis_aux(axes(k))
1794 IF ( trim(aux_name) /=
'none' )
THEN
1795 aux_present = .true.
1801 IF ( .NOT.req_present )
THEN
1803 req_fields = get_axis_reqfld(axes(k))
1804 IF ( trim(req_fields) /=
'none' )
THEN
1805 CALL error_mesg(
'diag_util_mod::opening_file',
'required fields found: '//&
1806 &trim(req_fields)//
' in file '//trim(files(file)%name),note)
1807 req_present = .true.
1813 axes(num_axes + 1) = files(file)%time_axis_id
1815 if (.not.
allocated(files(file)%is_time_axis_registered))
then
1816 allocate(files(file)%is_time_axis_registered)
1817 files(file)%is_time_axis_registered = .false.
1821 actual_num_axes = num_axes + 2
1822 axes(num_axes + 2) = files(file)%time_bounds_id
1825 actual_num_axes = num_axes + 1
1828 if (fnum_for_domain(file) ==
"2d")
then
1829 CALL write_axis_meta_data(files(file)%file_unit, axes(1:actual_num_axes),fileobj(file), time_ops=time_ops, &
1830 time_axis_registered=files(file)%is_time_axis_registered)
1831 elseif (fnum_for_domain(file) ==
"nd")
then
1832 CALL write_axis_meta_data(files(file)%file_unit, axes(1:actual_num_axes),fileobjnd(file), time_ops=time_ops,&
1833 time_axis_registered=files(file)%is_time_axis_registered)
1834 elseif (fnum_for_domain(file) ==
"ug")
then
1835 CALL write_axis_meta_data(files(file)%file_unit, axes(1:actual_num_axes),fileobju(file), time_ops=time_ops, &
1836 time_axis_registered=files(file)%is_time_axis_registered)
1842 IF (axis_is_compressed(axes(k)))
THEN
1843 CALL get_compressed_axes_ids(axes(k), axesc)
1844 if (fnum_for_domain(file) ==
"ug")
then
1845 CALL write_axis_meta_data(files(file)%file_unit, axesc,fileobju(file), &
1846 time_axis_registered=files(file)%is_time_axis_registered)
1848 CALL error_mesg(
'diag_util_mod::opening_file::'//trim(filename),
"Compressed "//&
1849 "dimensions are only allowed with axis in the unstructured dimension", fatal)
1857 field_num1 = files(file)%fields(1)
1858 DO j = 1, files(file)%num_fields
1859 field_num = files(file)%fields(j)
1860 IF ( output_fields(field_num)%time_ops )
THEN
1861 field_num1 = field_num
1865 nfields_loop:
DO j = 1, files(file)%num_fields
1866 field_num = files(file)%fields(j)
1867 input_field_num = output_fields(field_num)%input_field
1868 IF (.NOT.input_fields(input_field_num)%register) cycle
1869 IF (output_fields(field_num)%local_output .AND. .NOT. output_fields(field_num)%need_compute) cycle
1872 IF ( .NOT.mix_snapshot_average_fields )
THEN
1873 IF ( (output_fields(field_num)%time_ops.NEQV.output_fields(field_num1)%time_ops) .AND.&
1874 & .NOT.output_fields(field_num1)%static .AND. .NOT.output_fields(field_num)%static)
THEN
1875 IF (
mpp_pe() == mpp_root_pe() )
THEN
1880 CALL error_mesg(
'diag_util_mod::opening_file',
'file '//trim(files(file)%name)// &
1881 &
' can NOT have BOTH time average AND instantaneous fields.'//&
1882 &
' Create a new file or set mix_snapshot_average_fields=.TRUE. in the namelist diag_manager_nml.'&
1888 IF ( aux_present .AND. .NOT.match_aux_name )
THEN
1889 fieldname = output_fields(field_num)%output_name
1890 IF ( index(aux_name, trim(fieldname)) > 0 ) match_aux_name = .true.
1893 IF ( req_present .AND. .NOT.match_req_fields )
THEN
1894 fieldname = output_fields(field_num)%output_name
1895 is = 1; last = len_trim(req_fields)
1897 ind = index(req_fields(is:last),
' ')
1898 IF (ind .eq. 0) ind = last-is+2
1900 if (req_fields(is:ie) .EQ. trim(fieldname))
then
1901 match_req_fields = .true.
1906 if (is .GT. last)
EXIT
1911 num_axes = output_fields(field_num)%num_axes
1912 axes(1:num_axes) = output_fields(field_num)%axes(1:num_axes)
1913 IF ( .NOT.output_fields(field_num)%static )
THEN
1915 axes(num_axes) = files(file)%time_axis_id
1917 IF(output_fields(field_num)%time_average)
THEN
1919 ELSE IF(output_fields(field_num)%time_max)
THEN
1921 ELSE IF(output_fields(field_num)%time_min)
THEN
1927 if (fnum_for_domain(file) ==
"2d")
then
1928 fileob => fileobj(file)
1929 elseif (fnum_for_domain(file) ==
"nd")
then
1930 fileob => fileobjnd(file)
1931 elseif (fnum_for_domain(file) ==
"ug")
then
1932 fileob => fileobju(file)
1934 IF ( input_fields(input_field_num)%missing_value_present )
THEN
1935 IF ( len_trim(input_fields(input_field_num)%interp_method) > 0 )
THEN
1936 output_fields(field_num)%f_type = write_field_meta_data(files(file)%file_unit,&
1937 & output_fields(field_num)%output_name, axes(1:num_axes),&
1938 & input_fields(input_field_num)%units,&
1939 & input_fields(input_field_num)%long_name,&
1940 & input_fields(input_field_num)%range, output_fields(field_num)%pack,&
1941 & input_fields(input_field_num)%missing_value, avg_name = avg,&
1942 & time_method=output_fields(field_num)%time_method,&
1943 & standard_name = input_fields(input_field_num)%standard_name,&
1944 & interp_method = input_fields(input_field_num)%interp_method,&
1945 & attributes=output_fields(field_num)%attributes,&
1946 & num_attributes=output_fields(field_num)%num_attributes,&
1947 & use_ugdomain=files(file)%use_domainUG , &
1950 output_fields(field_num)%f_type = write_field_meta_data(files(file)%file_unit,&
1951 & output_fields(field_num)%output_name, axes(1:num_axes),&
1952 & input_fields(input_field_num)%units,&
1953 & input_fields(input_field_num)%long_name,&
1954 & input_fields(input_field_num)%range, output_fields(field_num)%pack,&
1955 & input_fields(input_field_num)%missing_value, avg_name = avg,&
1956 & time_method=output_fields(field_num)%time_method,&
1957 & standard_name = input_fields(input_field_num)%standard_name,&
1958 & attributes=output_fields(field_num)%attributes,&
1959 & num_attributes=output_fields(field_num)%num_attributes,&
1960 & use_ugdomain=files(file)%use_domainUG , &
1966 IF ( len_trim(input_fields(input_field_num)%interp_method) > 0 )
THEN
1967 output_fields(field_num)%f_type = write_field_meta_data(files(file)%file_unit,&
1968 & output_fields(field_num)%output_name, axes(1:num_axes),&
1969 & input_fields(input_field_num)%units,&
1970 & input_fields(input_field_num)%long_name,&
1971 & input_fields(input_field_num)%range, output_fields(field_num)%pack,&
1973 & time_method=output_fields(field_num)%time_method,&
1974 & standard_name = input_fields(input_field_num)%standard_name,&
1975 & interp_method = input_fields(input_field_num)%interp_method,&
1976 & attributes=output_fields(field_num)%attributes,&
1977 & num_attributes=output_fields(field_num)%num_attributes,&
1978 & use_ugdomain=files(file)%use_domainUG , &
1982 output_fields(field_num)%f_type = write_field_meta_data(files(file)%file_unit,&
1983 & output_fields(field_num)%output_name, axes(1:num_axes),&
1984 & input_fields(input_field_num)%units,&
1985 & input_fields(input_field_num)%long_name,&
1986 & input_fields(input_field_num)%range, output_fields(field_num)%pack,&
1988 & time_method=output_fields(field_num)%time_method,&
1989 & standard_name = input_fields(input_field_num)%standard_name,&
1990 & attributes=output_fields(field_num)%attributes,&
1991 & num_attributes=output_fields(field_num)%num_attributes,&
1992 & use_ugdomain=files(file)%use_domainUG , &
2000 IF ( time_ops )
THEN
2001 time_axis_id(1) = files(file)%time_axis_id
2002 files(file)%f_avg_start = write_field_meta_data(files(file)%file_unit,&
2003 & avg_name //
'_T1', time_axis_id, time_units,&
2004 &
"Start time for average period", pack=pack_size , &
2006 files(file)%f_avg_end = write_field_meta_data(files(file)%file_unit,&
2007 & avg_name //
'_T2', time_axis_id, time_units,&
2008 &
"End time for average period", pack=pack_size , &
2010 files(file)%f_avg_nitems = write_field_meta_data(files(file)%file_unit,&
2011 & avg_name //
'_DT', time_axis_id,&
2012 & trim(time_unit_list(files(file)%time_units)),&
2013 &
"Length of average period", pack=pack_size , &
2017 IF ( time_ops )
THEN
2018 time_axis_id(1) = files(file)%time_axis_id
2019 time_bounds_id(1) = files(file)%time_bounds_id
2020 CALL get_diag_axis( time_axis_id(1), time_name, time_units, time_longname,&
2021 & cart_name, dir, edges, domain, domainu, open_file_data)
2022 CALL get_diag_axis( time_bounds_id(1), timeb_name, timeb_units, timeb_longname,&
2023 & cart_name, dir, edges, domain, domainu, open_file_data)
2025 files(file)%f_bounds = write_field_meta_data(files(file)%file_unit,&
2026 & trim(time_name)//
'_bnds', (/time_bounds_id,time_axis_id/),&
2027 & time_units, trim(time_name)//
' axis boundaries', pack=pack_size , &
2031 call done_meta_data(files(file)%file_unit)
2033 IF( aux_present .AND. .NOT.match_aux_name )
THEN
2038 IF (
mpp_pe() == mpp_root_pe() )
CALL error_mesg(
'diag_util_mod::opening_file',&
2039 &
'one axis has auxiliary but the corresponding field is NOT found in file '// &
2040 & trim(files(file)%name), warning)
2042 IF( req_present .AND. .NOT.match_req_fields )
THEN
2047 IF (
mpp_pe() == mpp_root_pe() )
CALL error_mesg(
'diag_util_mod::opening_file',&
2048 &
'one axis has required fields ('//trim(req_fields)//
') but the '// &
2049 &
'corresponding fields are NOT found in file '//trim(files(file)%name), fatal)
2052 if (
associated(fileob))
nullify(fileob)
2056 SUBROUTINE diag_data_out(file, field, dat, time, final_call_in, static_write_in, filename_time)
2057 INTEGER,
INTENT(in) :: file
2058 INTEGER,
INTENT(in) :: field
2059 REAL,
DIMENSION(:,:,:,:),
INTENT(inout) :: dat
2060 TYPE(time_type),
INTENT(in) :: time
2061 LOGICAL,
OPTIONAL,
INTENT(in):: final_call_in
2062 LOGICAL,
OPTIONAL,
INTENT(in):: static_write_in
2063 type(time_type),
intent(in),
optional :: filename_time
2066 LOGICAL :: final_call, do_write, static_write
2067 REAL :: dif, time_data(2, 1, 1, 1), dt_time(1, 1, 1, 1), start_dif, end_dif
2068 REAL :: time_in_file
2072 time_in_file = files(file)%rtime_current
2075 final_call = .false.
2076 IF (
PRESENT(final_call_in) ) final_call = final_call_in
2077 static_write = .false.
2078 IF (
PRESENT(static_write_in) ) static_write = static_write_in
2080 dif = get_date_dif(time, get_base_time(), files(file)%time_units)
2083 IF ( .NOT.static_write .OR. files(file)%file_unit < 0 ) &
2084 CALL check_and_open(file, time, do_write, filename_time=filename_time)
2085 IF ( .NOT.do_write )
RETURN
2087 if (dif > files(file)%rtime_current)
then
2088 files(file)%time_index = files(file)%time_index + 1
2089 files(file)%rtime_current = dif
2090 if (fnum_for_domain(file) ==
"2d")
then
2091 call diag_write_time (fileobj(file), files(file)%rtime_current, files(file)%time_index, &
2092 time_name=fileobj(file)%time_name)
2093 elseif (fnum_for_domain(file) ==
"ug")
then
2094 call diag_write_time (fileobju(file), files(file)%rtime_current, files(file)%time_index, &
2095 time_name=fileobju(file)%time_name)
2096 elseif (fnum_for_domain(file) ==
"nd")
then
2097 call diag_write_time (fileobjnd(file), files(file)%rtime_current, files(file)%time_index, &
2098 time_name=fileobjnd(file)%time_name)
2100 call error_mesg(
"diag_util_mod::diag_data_out",
"Error opening the file "//files(file)%name,fatal)
2102 elseif (dif < files(file)%rtime_current .and. .not.(static_write) )
then
2103 call error_mesg(
"diag_util_mod::diag_data_out",
"The time for the file "//trim(files(file)%name)//&
2104 " has gone backwards. There may be missing values for some of the variables",note)
2107 call diag_field_write (output_fields(field)%output_name, dat, static_write, file, fileobju, &
2108 fileobj, fileobjnd, fnum_for_domain(file), time_in=files(file)%time_index)
2110 files(file)%bytes_written = files(file)%bytes_written +&
2111 & (
SIZE(dat,1)*
SIZE(dat,2)*
SIZE(dat,3))*(8/output_fields(field)%pack)
2112 IF ( .NOT.output_fields(field)%written_once ) output_fields(field)%written_once = .true.
2114 IF ( .NOT.output_fields(field)%static )
THEN
2115 start_dif = get_date_dif(output_fields(field)%last_output, get_base_time(),files(file)%time_units)
2116 IF ( .NOT.mix_snapshot_average_fields )
THEN
2117 end_dif = get_date_dif(output_fields(field)%next_output, get_base_time(), files(file)%time_units)
2123 if (files(file)%rtime_current > time_in_file)
then
2124 if (output_fields(field)%time_ops)
then
2126 time_data(1, 1, 1, 1) = start_dif
2127 call diag_field_write (files(file)%f_avg_start%fieldname, time_data(1:1,:,:,:), static_write, file, &
2128 fileobju, fileobj, fileobjnd, &
2129 fnum_for_domain(file), time_in=files(file)%time_index)
2130 time_data(2, 1, 1, 1) = end_dif
2131 call diag_field_write (files(file)%f_avg_end%fieldname, time_data(2:2,:,:,:), static_write, file, &
2132 fileobju, fileobj, fileobjnd, &
2133 fnum_for_domain(file), time_in=files(file)%time_index)
2135 dt_time(1, 1, 1, 1) = end_dif - start_dif
2136 call diag_field_write (files(file)%f_avg_nitems%fieldname, dt_time(1:1,:,:,:), static_write, file, &
2137 fileobju, fileobj, fileobjnd, &
2138 fnum_for_domain(file), time_in=files(file)%time_index)
2140 call diag_field_write (files(file)%f_bounds%fieldname, time_data(1:2,:,:,:), static_write, file, &
2141 fileobju, fileobj, fileobjnd, &
2142 fnum_for_domain(file), time_in=files(file)%time_index)
2147 IF ( final_call )
THEN
2148 IF ( time >= files(file)%last_flush )
THEN
2149 files(file)%last_flush = time
2152 IF ( time > files(file)%last_flush .AND. (flush_nc_files.OR.debug_diag_manager) )
THEN
2153 call diag_flush(file, fileobju, fileobj, fileobjnd, fnum_for_domain(file))
2154 files(file)%last_flush = time
2164 INTEGER,
INTENT(in) :: file
2165 TYPE(time_type),
INTENT(in) :: time
2166 LOGICAL,
INTENT(out) :: do_write
2168 TYPE(time_type),
INTENT(in),
optional :: filename_time
2171 IF ( time >= files(file)%start_time )
THEN
2172 IF ( files(file)%file_unit < 0 )
THEN
2173 CALL opening_file(file, time, filename_time=filename_time)
2177 IF ( time > files(file)%close_time .AND. time < files(file)%next_open )
THEN
2179 ELSE IF ( time > files(file)%next_open )
THEN
2181 CALL opening_file(file, time, filename_time=filename_time)
2182 files(file)%time_index = 0
2183 files(file)%start_time = files(file)%next_open
2184 files(file)%close_time =&
2185 & diag_time_inc(files(file)%start_time,files(file)%duration, files(file)%duration_units)
2186 files(file)%next_open =&
2187 & diag_time_inc(files(file)%next_open, files(file)%new_file_freq,&
2188 & files(file)%new_file_freq_units)
2189 IF ( files(file)%close_time > files(file)%next_open )
THEN
2194 CALL error_mesg(
'diag_util_mod::check_and_open',&
2195 & files(file)%name// &
2196 &
' has close time GREATER than next_open time, check file duration and frequency',fatal)
2207 INTEGER,
INTENT(in) :: file
2208 INTEGER :: j, i, input_num
2210 DO j = 1, files(file)%num_fields
2211 i = files(file)%fields(j)
2212 input_num = output_fields(i)%input_field
2214 IF ( .NOT.input_fields(input_num)%register ) cycle
2215 IF ( output_fields(i)%local_output .AND. .NOT. output_fields(i)%need_compute) cycle
2217 IF ( .NOT.output_fields(i)%static ) cycle
2218 CALL diag_data_out(file, i, output_fields(i)%buffer, files(file)%last_flush, .true., .true.)
2224 if (fnum_for_domain(file) ==
"2d" )
then
2225 if (check_if_open(fileobj(file)))
call close_file (fileobj(file) )
2226 elseif (fnum_for_domain(file) ==
"nd")
then
2227 if (check_if_open(fileobjnd(file)) )
then
2228 call close_file (fileobjnd(file))
2230 elseif (fnum_for_domain(file) ==
"ug")
then
2231 if (check_if_open(fileobju(file)))
call close_file (fileobju(file))
2233 files(file)%file_unit = -1
2238 CHARACTER(len=*),
INTENT(out),
OPTIONAL :: err_msg
2240 INTEGER :: i, j, tmp_file
2241 CHARACTER(len=128) :: tmp_name
2242 CHARACTER(len=256) :: err_msg_local
2244 IF (
PRESENT(err_msg) ) err_msg=
''
2246 IF ( num_output_fields <= 1 )
RETURN
2249 i_loop:
DO i = 1, num_output_fields-1
2250 tmp_name = trim(output_fields(i)%output_name)
2251 tmp_file = output_fields(i)%output_file
2252 DO j = i+1, num_output_fields
2253 IF ( (tmp_name == trim(output_fields(j)%output_name)) .AND. &
2254 &(tmp_file == output_fields(j)%output_file))
THEN
2255 err_msg_local =
' output_field "'//trim(tmp_name)//&
2256 &
'" duplicated in file "'//trim(files(tmp_file)%name)//
'"'
2261 IF ( err_msg_local /=
'' )
THEN
2262 IF ( fms_error_handler(
' ERROR in diag_table',err_msg_local,err_msg) )
RETURN
2268 TYPE(output_field_type),
INTENT(inout) :: out_field
2269 CHARACTER(LEN=*),
INTENT(out),
OPTIONAL :: err_msg
2274 IF (
PRESENT(err_msg) ) err_msg =
''
2277 IF ( .NOT.
allocated(out_field%attributes) )
THEN
2278 ALLOCATE(out_field%attributes(max_field_attributes), stat=istat)
2279 IF ( istat.NE.0 )
THEN
2283 IF ( fms_error_handler(
'diag_util_mod::attribute_init_field',&
2284 &
'Unable to allocate memory for attributes', err_msg) )
THEN
2289 out_field%num_attributes = 0
2297 TYPE(output_field_type),
INTENT(inout) :: out_field
2298 CHARACTER(len=*),
INTENT(in) :: att_name
2299 CHARACTER(len=*),
INTENT(in) :: prepend_value
2300 CHARACTER(len=*),
INTENT(out) ,
OPTIONAL :: err_msg
2302 INTEGER :: length, i, this_attribute
2303 CHARACTER(len=512) :: err_msg_local
2307 IF (
PRESENT(err_msg) ) err_msg =
''
2311 IF ( trim(err_msg_local) .NE.
'' )
THEN
2312 IF ( fms_error_handler(
'diag_util_mod::prepend_attribute_field', trim(err_msg_local), err_msg) )
THEN
2319 DO i=1, out_field%num_attributes
2320 IF ( trim(out_field%attributes(i)%name) .EQ. trim(att_name) )
THEN
2326 IF ( this_attribute > 0 )
THEN
2327 IF ( out_field%attributes(this_attribute)%type .NE. nf90_char )
THEN
2331 IF ( fms_error_handler(
'diag_util_mod::prepend_attribute_field', &
2332 &
'Attribute "'//trim(att_name)//
'" is not a character attribute.',&
2340 this_attribute = out_field%num_attributes + 1
2341 IF ( this_attribute .GT. max_field_attributes )
THEN
2346 IF ( fms_error_handler(
'diag_util_mod::prepend_attribute_field',&
2347 &
'Number of attributes exceeds max_field_attributes for attribute "'&
2348 & //trim(att_name)//
'". Increase diag_manager_nml:max_field_attributes.',&
2353 out_field%num_attributes = this_attribute
2355 out_field%attributes(this_attribute)%name = att_name
2356 out_field%attributes(this_attribute)%type = nf90_char
2358 out_field%attributes(this_attribute)%catt =
''
2363 IF ( index(trim(out_field%attributes(this_attribute)%catt), trim(prepend_value)).EQ.0 )
THEN
2365 length = len_trim(trim(prepend_value)//
" "//trim(out_field%attributes(this_attribute)%catt))
2366 IF ( length.GT.len(out_field%attributes(this_attribute)%catt) )
THEN
2370 IF ( fms_error_handler(
'diag_util_mod::prepend_attribute_field',&
2371 &
'Prepend length for attribute "'//trim(att_name)//
'" is longer than allowed.',&
2377 out_field%attributes(this_attribute)%catt =&
2378 & trim(prepend_value)//
' '//trim(out_field%attributes(this_attribute)%catt)
2379 out_field%attributes(this_attribute)%len = length
2384 TYPE(file_type),
INTENT(inout) :: out_file
2385 CHARACTER(LEN=*),
INTENT(out),
OPTIONAL :: err_msg
2390 IF (
PRESENT(err_msg) ) err_msg =
''
2393 IF ( .NOT.
allocated(out_file%attributes) )
THEN
2394 ALLOCATE(out_file%attributes(max_field_attributes), stat=istat)
2395 IF ( istat.NE.0 )
THEN
2399 IF ( fms_error_handler(
'diag_util_mod::attribute_init_file', &
2400 &
'Unable to allocate memory for file attributes', err_msg) )
THEN
2405 out_file%num_attributes = 0
2413 TYPE(file_type),
INTENT(inout) :: out_file
2414 CHARACTER(len=*),
INTENT(in) :: att_name
2415 CHARACTER(len=*),
INTENT(in) :: prepend_value
2416 CHARACTER(len=*),
INTENT(out) ,
OPTIONAL :: err_msg
2418 INTEGER :: length, i, this_attribute
2419 CHARACTER(len=512) :: err_msg_local
2423 IF (
PRESENT(err_msg) ) err_msg =
''
2427 IF ( trim(err_msg_local) .NE.
'' )
THEN
2428 IF ( fms_error_handler(
'diag_util_mod::prepend_attribute_file', trim(err_msg_local), err_msg) )
THEN
2435 DO i=1, out_file%num_attributes
2436 IF ( trim(out_file%attributes(i)%name) .EQ. trim(att_name) )
THEN
2442 IF ( this_attribute > 0 )
THEN
2443 IF ( out_file%attributes(this_attribute)%type .NE. nf90_char )
THEN
2447 IF ( fms_error_handler(
'diag_util_mod::prepend_attribute_file',&
2448 &
'Attribute "'//trim(att_name)//
'" is not a character attribute.',&
2456 this_attribute = out_file%num_attributes + 1
2457 IF ( this_attribute .GT. max_file_attributes )
THEN
2462 IF ( fms_error_handler(
'diag_util_mod::prepend_attribute_file',&
2463 &
'Number of attributes exceeds max_file_attributes for attribute "'&
2464 &//trim(att_name)//
'". Increase diag_manager_nml:max_file_attributes.',&
2469 out_file%num_attributes = this_attribute
2471 out_file%attributes(this_attribute)%name = att_name
2472 out_file%attributes(this_attribute)%type = nf90_char
2474 out_file%attributes(this_attribute)%catt =
''
2479 IF ( index(trim(out_file%attributes(this_attribute)%catt), trim(prepend_value)).EQ.0 )
THEN
2481 length = len_trim(trim(prepend_value)//
" "//trim(out_file%attributes(this_attribute)%catt))
2482 IF ( length.GT.len(out_file%attributes(this_attribute)%catt) )
THEN
2486 IF ( fms_error_handler(
'diag_util_mod::prepend_attribute_file',&
2487 &
'Prepend length for attribute "'//trim(att_name)//
'" is longer than allowed.',&
2493 out_file%attributes(this_attribute)%catt =&
2494 & trim(prepend_value)//
' '//trim(out_file%attributes(this_attribute)%catt)
2495 out_file%attributes(this_attribute)%len = length
2503 integer,
intent(in) :: file_num
2505 TYPE(time_type) :: start_time
2507 start_time = files(file_num)%start_time
2509 END MODULE diag_util_mod
subroutine, public get_compressed_axes_ids(id, r)
given an index of compressed-by-gathering axis, return an array of axes used in compression....
subroutine, public get_diag_axis(id, name, units, long_name, cart_name, direction, edges, Domain, DomainU, array_data, num_attributes, attributes, domain_position)
Return information about the axis with index ID.
subroutine, public get_diag_axis_cart(id, cart_name)
Return the axis cartesian.
integer function, public get_axis_global_length(id)
Return the global length of the axis.
type(domain2d) function, public get_domain2d(ids)
Return the 2D domain for the axis IDs given.
type(domainug) function, public get_domainug(id)
Retrun the 1D domain for the axis ID given.
subroutine, public get_diag_axis_data(id, axis_data)
Return the axis data.
character(len=128) function, public get_axis_reqfld(id)
Return the required field names for the axis.
subroutine, public get_diag_axis_name(id, axis_name)
Return the short name of the axis.
character(len=128) function, public get_axis_aux(id)
Return the auxiliary name for the axis.
integer function, public diag_axis_init(name, array_data, units, cart_name, long_name, direction, set_name, edges, Domain, Domain2, DomainU, aux, req, tile_count, domain_position)
Initialize the axis, and return the axis ID.
logical function, public axis_is_compressed(id)
given an axis, returns TRUE if the axis uses compression-by-gathering: that is, if this is an axis fo...
subroutine, public get_axes_shift(ids, ishift, jshift)
Return the value of the shift for the axis IDs given.
subroutine, public get_diag_axis_domain_name(id, name)
Return the name of the axis' domain.
type(domain1d) function, public get_domain1d(id)
Retrun the 1D domain for the axis ID given.
integer function, public diag_subaxes_init(axis, subdata, start_indx, end_indx, domain_2d)
Create a subaxis on a parent axis.
integer max_output_fields
Maximum number of output fields. Increase via diag_manager_nml.
integer pack_size
1 for double and 2 for float
integer function get_base_minute()
gets the module variable base_minute
integer function get_base_year()
gets the module variable base_year
integer num_input_fields
Number of input fields in use.
integer function get_base_hour()
gets the module variable base_hour
logical use_cmor
Indicates if we should overwrite the MISSING_VALUE to use the CMOR missing value.
logical flush_nc_files
Control if diag_manager will force a flush of the netCDF file on each write. Note: changing this to ....
integer, parameter glo_reg_val_alt
Alternate value used in the region specification of the diag_table to indicate to use the full axis i...
type(time_type) function get_base_time()
gets the module variable base_time
integer, parameter diag_field_not_found
Return value for a diag_field that isn't found in the diag_table.
integer max_out_per_in_field
Maximum number of output_fields per input_field. Increase via diag_manager_nml.
integer max_input_fields
Maximum number of input fields. Increase via diag_manager_nml.
logical region_out_use_alt_value
Will determine which value to use when checking a regional output if the region is the full axis or a...
integer num_output_fields
Number of output fields in use.
integer function get_base_day()
gets the module variable base_day
type(time_type) diag_init_time
Time diag_manager_init called. If init_time not included in diag_manager_init call,...
integer max_files
Maximum number of output files allowed. Increase via diag_manager_nml.
integer num_files
Number of output files currenly in use by the diag_manager.
integer max_file_attributes
Maximum number of user definable global attributes per file.
real(r8_kind), parameter cmor_missing_value
CMOR standard missing value.
logical prepend_date
Should the history file have the start date prepended to the file name. .TRUE. is only supported if t...
character(len=2), dimension(:), allocatable fnum_for_domain
If this file number in the array is for the "unstructured" or "2d" domain.
integer function get_base_month()
gets the module variable base_month
integer, parameter glo_reg_val
Value used in the region specification of the diag_table to indicate to use the full axis instead of ...
integer function get_base_second()
gets the module variable base_second
integer, parameter max_fields_per_file
Maximum number of fields per file.
integer max_field_attributes
Maximum number of user definable attributes per field. Liptak: Changed from 2 to 4 20170718.
Define the region for field output.
Type to define the diagnostic files that will be written as defined by the diagnostic table.
Type to hold the output field description.
subroutine, public get_local_indexes(latStart, latEnd, lonStart, lonEnd, istart, iend, jstart, jend)
Find the local start and local end indexes on the local PE for regional output.
subroutine, public diag_field_write(varname, buffer, static, file_num, fileobjU, fileobj, fileobjND, fnum_for_domain, time_in)
Writes diagnostic data out using fms2_io routine.
subroutine, public diag_output_init(file_name, file_title, file_unit, domain, domainU, fileobj, fileobjU, fileobjND, fnum_domain, attributes)
Opens the output file.
subroutine, public diag_flush(file_num, fileobjU, fileobj, fileobjND, fnum_for_domain)
Flushes the file into disk.
subroutine, public done_meta_data(file_unit)
Writes axis data to file.
subroutine, public diag_write_time(fileob, rtime_value, time_index, time_name)
Writes the time data to the history file.
subroutine, public write_axis_meta_data(file_unit, axes, fileob, time_ops, time_axis_registered)
Write the axis meta data to file.
type(diag_fieldtype) function, public write_field_meta_data(file_unit, name, axes, units, long_name, range, pack, mval, avg_name, time_method, standard_name, interp_method, attributes, num_attributes, use_UGdomain, fileob)
Write the field meta data to file.
subroutine, public get_subfield_size(axes, outnum)
Get the size, start, and end indices for output fields.
subroutine opening_file(file, time, filename_time)
Open file for output, and write the meta data.
subroutine, public init_input_field(module_name, field_name, tile_count)
Initialize the input field.
subroutine, public init_file(name, output_freq, output_units, format, time_units, long_name, tile_count, new_file_freq, new_file_freq_units, start_time, file_duration, file_duration_units, filename_time_bounds)
Initialize the output file.
subroutine, public check_bounds_are_exact_static(out_num, diag_field_id, err_msg)
Check if the array indices for output_fields(out_num) are equal to the output_fields(out_num)buffer u...
integer function, public find_input_field(module_name, field_name, tile_count)
Return the field number for the given module name, field name, and tile number.
subroutine, public write_static(file)
Output all static fields in this file.
subroutine, public diag_data_out(file, field, dat, time, final_call_in, static_write_in, filename_time)
Write data out to file, and if necessary flush the buffers.
subroutine, public init_output_field(module_name, field_name, output_name, output_file, time_method, pack, tile_count, local_coord)
Initialize the output field.
type(time_type) function, public get_file_start_time(file_num)
Get the a diag_file's start_time as it is defined in the diag_table.
logical function a_lessthan_b(a, b)
return true iff a<b.
integer function find_file(name, tile_count)
Return the file number for file name and tile.
subroutine, public check_duplicate_output_fields(err_msg)
Checks to see if output_name and output_file are unique in output_fields.
subroutine, public sync_file_times(file_id, init_time, err_msg)
Synchronize the file's start and close times with the model start and end times.
subroutine fms_diag_check_out_of_bounds_r8(ofb, bounds, output_name, module_name, err_msg)
Checks if the array indices for output_field buffer (ofb) are outside the are outside the bounding bo...
character(len=1), public field_log_separator
separator used for csv-style log of registered fields set by nml in diag_manager init
subroutine, public check_out_of_bounds(out_num, diag_field_id, err_msg)
Checks if the array indices for output_fields(out_num) are outside the output_fields(out_num)buffer u...
subroutine, public fms_diag_check_bounds_are_exact_static(current_bounds, bounds, output_name, module_name, err_msg)
Check if the array indices specified in the bounding box "current_bounds" are equal to those specifie...
logical function a_greaterthan_b(a, b)
return true iff a>b.
subroutine, public get_subfield_vert_size(axes, outnum)
Get size, start and end indices for output fields.
logical function compare_buffer_bounds_to_size(current_bounds, bounds, error_str, lowerb_comp, upperb_comp)
Compares the bounding indices of an array specified in "current_bounds" to the corresponding lower an...
subroutine, public log_diag_field_info(module_name, field_name, axes, long_name, units, missing_value, range, dynamic)
Writes brief diagnostic field info to the log file.
subroutine, public update_bounds(out_num, lower_i, upper_i, lower_j, upper_j, lower_k, upper_k)
Update the output_fields x, y, and z min and max boundaries (array indices) with the six specified bo...
subroutine prepend_attribute_file(out_file, att_name, prepend_value, err_msg)
Prepends the attribute value to an already existing attribute. If the attribute isn't yet defined,...
subroutine prepend_attribute_field(out_field, att_name, prepend_value, err_msg)
Prepends the attribute value to an already existing attribute. If the attribute isn't yet defined,...
subroutine, public diag_util_init()
Write the version number of this file to the log file.
subroutine attribute_init_file(out_file, err_msg)
Allocates the atttype in out_file.
logical function a_noteq_b(a, b)
return true iff a /= b
subroutine attribute_init_field(out_field, err_msg)
Allocates the atttype in out_field.
subroutine check_and_open(file, time, do_write, filename_time)
Checks if it is time to open a new file.
subroutine, public check_bounds_are_exact_dynamic(out_num, diag_field_id, Time, err_msg)
This is an adaptor to the check_bounds_are_exact_dynamic_modern function to maintain an interface ser...
subroutine, public fms_diag_check_bounds_are_exact_dynamic(current_bounds, bounds, output_name, module_name, Time, field_prev_Time, err_msg)
Checks that array indices specified in the bounding box "current_bounds" are identical to those in th...
integer function get_index(number, array)
Find index i of array such that array(i) is closest to number.
subroutine fms_diag_check_out_of_bounds_r4(ofb, bounds, output_name, module_name, err_msg)
Checks if the array indices for output_fields(out_num) are outside the output_fields(out_num)buffer u...
Allocates the atttype in out_file.
Prepend a value to a string attribute in the output field or output file.
character(len=128) function, public get_time_string(filename, current_time)
This function determines a string based on current time. This string is used as suffix in output file...
real function, public get_date_dif(t2, t1, units)
Return the difference between two times in units.
subroutine, public write_version_number(version, tag, unit)
Prints to the log file (or a specified unit) the version id string and tag name.
logical function, public fms_error_handler(routine, message, err_msg)
Facilitates the control of fatal error conditions.
subroutine, public error_mesg(routine, message, level)
Print notes, warnings and error messages; terminates program for warning and error messages....
integer function mpp_get_tile_npes(domain)
Returns number of processors used on current tile.
subroutine mpp_get_domain_components(domain, x, y, tile_count)
Retrieve 1D components of 2D decomposition.
integer function, dimension(size(domain%tile_id(:))) mpp_get_tile_id(domain)
Returns the tile_id on current pe.
logical function mpp_mosaic_defined()
Accessor function for value of mosaic_defined.
integer function mpp_get_current_ntile(domain)
Returns number of tile on current pe.
integer function mpp_get_ntile_count(domain)
Returns number of tiles in mosaic.
These routines retrieve the axis specifications associated with the compute domains....
Modifies the extents (compute, data and global) of a given domain.
One dimensional domain used to manage shared data access between pes.
The domain2D type contains all the necessary information to define the global, compute and data domai...
Domain information for managing data on unstructured grids.
integer function mpp_npes()
Returns processor count for current pelist.
integer function mpp_pe()
Returns processor ID.
logical function, public leap_year(Time, err_msg)
Returns true if the year corresponding to the input time is a leap year (for default calendar)....
subroutine, public get_time(Time, seconds, days, ticks, err_msg)
Returns days and seconds ( < 86400 ) corresponding to a time. err_msg should be checked for any error...
subroutine, public get_date(time, year, month, day, hour, minute, second, tick, err_msg)
Gets the date for different calendar types. Given a time_interval, returns the corresponding date und...
type(time_type) function, public increment_time(Time, seconds, days, ticks, err_msg, allow_neg_inc)
Increments a time by seconds and days.
integer function, public get_calendar_type()
Returns default calendar type for mapping from time to date.
Type to represent amounts of time. Implemented as seconds and days to allow for larger intervals.
Data structure holding a 3D bounding box. It is commonlyused to represent the interval bounds or limi...