145 MODULE diag_manager_mod
206 &
OPERATOR(<),
OPERATOR(==),
OPERATOR(/=),
OPERATOR(/),
OPERATOR(+),
ASSIGNMENT(=),
get_date, &
210 USE mpp_mod,
ONLY: input_nml_file,
mpp_error
223 & end_of_run, diag_seconds, diag_minutes, diag_hours, diag_days, diag_months, diag_years,
num_files,&
227 & output_fields, time_zero, append_pelist_name, mix_snapshot_average_fields,&
228 & first_send_data_call, do_diag_field_log, write_bytes_in_file, debug_diag_manager,&
239 use fms_diag_object_mod,
only:fms_diag_object
241 USE constants_mod,
ONLY: seconds_per_day
245 USE fms_string_utils_mod,
ONLY:
string
247 USE netcdf,
ONLY: nf90_int, nf90_float, nf90_char
260 &
need_data, diag_all, diag_ocean, diag_other, get_date_dif, diag_seconds,&
264 PUBLIC :: center, north, east
270 PUBLIC :: diag_field_not_found
274 #include<file_version.h>
276 type(time_type) :: Time_end
379 & long_name, units, missing_value, range, standard_name, do_not_log, err_msg,&
380 & area, volume, realm, multiple_send_data)
381 CHARACTER(len=*),
INTENT(in) :: module_name
382 CHARACTER(len=*),
INTENT(in) :: field_name
383 TYPE(
time_type),
OPTIONAL,
INTENT(in) :: init_time
384 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: long_name
385 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: units
386 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: standard_name
387 CLASS(*),
OPTIONAL,
INTENT(in) :: missing_value
388 CLASS(*),
OPTIONAL,
INTENT(in) :: range(:)
389 LOGICAL,
OPTIONAL,
INTENT(in) :: do_not_log
390 CHARACTER(len=*),
OPTIONAL,
INTENT(out):: err_msg
391 INTEGER,
OPTIONAL,
INTENT(in) :: area
392 INTEGER,
OPTIONAL,
INTENT(in) :: volume
393 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: realm
394 LOGICAL,
OPTIONAL,
INTENT(in) :: multiple_send_data
398 IF (
PRESENT(range) )
THEN
399 IF (
SIZE(range) .NE. 2 )
THEN
401 CALL error_mesg (
'diag_manager_mod::register_diag_field',
'extent of range should be 2', fatal)
404 if (use_modern_diag)
then
405 if( do_diag_field_log)
then
406 if (
PRESENT(do_not_log) )
THEN
407 if(.not. do_not_log)
call log_diag_field_info(module_name, field_name, (/null_axis_id/), long_name,&
408 & units, missing_value, range, dynamic=.true.)
411 & missing_value, range, dynamic=.true.)
415 & module_name, field_name, init_time, long_name=long_name, units=units, &
416 & missing_value=missing_value, var_range=range, standard_name=standard_name, &
417 & do_not_log=do_not_log, err_msg=err_msg, area=area, volume=volume, realm=realm, &
418 multiple_send_data=multiple_send_data)
421 & long_name=long_name, units=units, missing_value=missing_value, range=range, standard_name=standard_name, &
422 & do_not_log=do_not_log, err_msg=err_msg, area=area, volume=volume, realm=realm)
429 & long_name, units, missing_value, range, mask_variant, standard_name, verbose,&
430 & do_not_log, err_msg, interp_method, tile_count, area, volume, realm, multiple_send_data)
431 CHARACTER(len=*),
INTENT(in) :: module_name
432 CHARACTER(len=*),
INTENT(in) :: field_name
433 INTEGER,
INTENT(in) :: axes(:)
434 TYPE(
time_type),
OPTIONAL,
INTENT(in) :: init_time
435 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: long_name
436 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: units
437 CLASS(*),
OPTIONAL,
INTENT(in) :: missing_value
438 CLASS(*),
OPTIONAL,
INTENT(in) :: range(:)
439 LOGICAL,
OPTIONAL,
INTENT(in) :: mask_variant
440 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: standard_name
441 LOGICAL,
OPTIONAL,
INTENT(in) :: verbose
442 LOGICAL,
OPTIONAL,
INTENT(in) :: do_not_log
443 CHARACTER(len=*),
OPTIONAL,
INTENT(out):: err_msg
444 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: interp_method
448 INTEGER,
OPTIONAL,
INTENT(in) :: tile_count
449 INTEGER,
OPTIONAL,
INTENT(in) :: area
450 INTEGER,
OPTIONAL,
INTENT(in) :: volume
451 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: realm
452 LOGICAL,
OPTIONAL,
INTENT(in) :: multiple_send_data
455 if (use_modern_diag)
then
456 if( do_diag_field_log)
then
457 if (
PRESENT(do_not_log) )
THEN
459 & units, missing_value, range, dynamic=.true.)
462 & missing_value, range, dynamic=.true.)
466 & module_name, field_name, axes, init_time, long_name=long_name, &
467 & units=units, missing_value=missing_value, var_range=range, mask_variant=mask_variant, &
468 & standard_name=standard_name, verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
469 & interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm, &
470 multiple_send_data=multiple_send_data)
473 & long_name=long_name, units=units, missing_value=missing_value, range=range, mask_variant=mask_variant, &
474 & standard_name=standard_name, verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
475 & interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm)
482 & missing_value, range, mask_variant, standard_name, DYNAMIC, do_not_log, interp_method,&
483 & tile_count, area, volume, realm)
484 CHARACTER(len=*),
INTENT(in) :: module_name
485 CHARACTER(len=*),
INTENT(in) :: field_name
486 INTEGER,
DIMENSION(:),
INTENT(in) :: axes
487 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: long_name
488 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: units
489 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: standard_name
490 CLASS(*),
OPTIONAL,
INTENT(in) :: missing_value
491 CLASS(*),
DIMENSION(:),
OPTIONAL,
INTENT(in) :: range
492 LOGICAL,
OPTIONAL,
INTENT(in) :: mask_variant
493 LOGICAL,
OPTIONAL,
INTENT(in) :: dynamic
494 LOGICAL,
OPTIONAL,
INTENT(in) :: do_not_log
495 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: interp_method
499 INTEGER,
OPTIONAL,
INTENT(in) :: tile_count
500 INTEGER,
OPTIONAL,
INTENT(in) :: area
502 INTEGER,
OPTIONAL,
INTENT(in) :: volume
504 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: realm
508 IF ( .NOT.module_is_initialized )
THEN
510 CALL error_mesg (
'diag_manager_mod::register_static_field',
'diag_manager has NOT been initialized', fatal)
513 if (use_modern_diag)
then
514 if( do_diag_field_log)
then
515 if (
PRESENT(do_not_log) )
THEN
517 & units, missing_value, range, dynamic=.false.)
520 & missing_value, range, dynamic=.false.)
524 & long_name=long_name, units=units, missing_value=missing_value, range=range, mask_variant=mask_variant, &
525 & standard_name=standard_name, dynamic=dynamic, do_not_log=do_not_log, interp_method=interp_method,&
526 & tile_count=tile_count, area=area, volume=volume, realm=realm)
529 & long_name=long_name, units=units, missing_value=missing_value, range=range, mask_variant=mask_variant, &
530 & standard_name=standard_name, dynamic=dynamic, do_not_log=do_not_log, interp_method=interp_method,&
531 & tile_count=tile_count, area=area, volume=volume, realm=realm)
538 & long_name, units, missing_value, range, standard_name, do_not_log, err_msg,&
539 & area, volume, realm)
540 CHARACTER(len=*),
INTENT(in) :: module_name
541 CHARACTER(len=*),
INTENT(in) :: field_name
542 TYPE(
time_type),
OPTIONAL,
INTENT(in) :: init_time
543 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: long_name
544 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: units
545 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: standard_name
546 CLASS(*),
OPTIONAL,
INTENT(in) :: missing_value
547 CLASS(*),
OPTIONAL,
INTENT(in) :: range(:)
548 LOGICAL,
OPTIONAL,
INTENT(in) :: do_not_log
549 CHARACTER(len=*),
OPTIONAL,
INTENT(out):: err_msg
550 INTEGER,
OPTIONAL,
INTENT(in) :: area
551 INTEGER,
OPTIONAL,
INTENT(in) :: volume
552 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: realm
554 IF (
PRESENT(err_msg) ) err_msg =
''
556 IF (
PRESENT(init_time) )
THEN
558 & (/null_axis_id/), init_time,long_name, units, missing_value, range, &
559 & standard_name=standard_name, do_not_log=do_not_log, err_msg=err_msg,&
560 & area=area, volume=volume, realm=realm)
563 & (/null_axis_id/),long_name, units, missing_value, range,&
564 & standard_name=standard_name, do_not_log=do_not_log, realm=realm)
571 & long_name, units, missing_value, range, mask_variant, standard_name, verbose,&
572 & do_not_log, err_msg, interp_method, tile_count, area, volume, realm)
573 CHARACTER(len=*),
INTENT(in) :: module_name, field_name
574 INTEGER,
INTENT(in) :: axes(:)
576 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: long_name, units, standard_name
577 CLASS(*),
OPTIONAL,
INTENT(in) :: missing_value
578 CLASS(*),
DIMENSION(:),
OPTIONAL,
INTENT(in) :: range
579 LOGICAL,
OPTIONAL,
INTENT(in) :: mask_variant,verbose
580 LOGICAL,
OPTIONAL,
INTENT(in) :: do_not_log
581 CHARACTER(len=*),
OPTIONAL,
INTENT(out):: err_msg
582 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: interp_method
586 INTEGER,
OPTIONAL,
INTENT(in) :: tile_count
587 INTEGER,
OPTIONAL,
INTENT(in) :: area
588 INTEGER,
OPTIONAL,
INTENT(in) :: volume
589 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: realm
591 INTEGER :: field, j, ind, file_num, freq
592 INTEGER :: output_units
593 INTEGER :: stdout_unit
594 LOGICAL :: mask_variant1, verbose1
595 CHARACTER(len=128) :: msg
601 IF (
PRESENT(mask_variant) )
THEN
602 mask_variant1 = mask_variant
604 mask_variant1 = .false.
607 IF (
PRESENT(verbose) )
THEN
613 IF (
PRESENT(err_msg) ) err_msg =
''
616 IF (
PRESENT(range) )
THEN
617 IF (
SIZE(range) .NE. 2 )
THEN
619 CALL error_mesg (
'diag_manager_mod::register_diag_field',
'extent of range should be 2', fatal)
625 & long_name, units, missing_value, range, mask_variant1, standard_name=standard_name,&
626 & dynamic=.true., do_not_log=do_not_log, interp_method=interp_method, tile_count=tile_count, realm=realm)
628 IF ( .NOT.first_send_data_call )
THEN
633 IF (
mpp_pe() == mpp_root_pe() ) &
634 &
CALL error_mesg (
'diag_manager_mod::register_diag_field',
'module/output_field '&
635 &//trim(module_name)//
'/'// trim(field_name)//&
636 &
' registered AFTER first send_data call, TOO LATE', warning)
643 IF ( debug_diag_manager .OR. verbose1 )
THEN
644 IF (
mpp_pe() == mpp_root_pe() ) &
645 &
CALL error_mesg (
'diag_manager_mod::register_diag_field',
'module/output_field '&
646 &//trim(module_name)//
'/'// trim(field_name)//
' NOT found in diag_table',&
655 IF (
PRESENT(volume).AND.
PRESENT(area) )
THEN
656 IF ( area.EQ.volume )
THEN
657 IF (
PRESENT(err_msg))
THEN
658 err_msg =
'diag_manager_mod::register_diag_field: module/output_field '&
659 &//trim(module_name)//
'/'// trim(field_name)//
' AREA and VOLUME CANNOT be the same variable.&
660 & Contact the developers.'
664 CALL error_mesg (
'diag_manager_mod::register_diag_field',
'module/output_field '&
665 &//trim(module_name)//
'/'// trim(field_name)//
' AREA and VOLUME CANNOT be the same variable.&
666 & Contact the developers.',&
673 IF (
PRESENT(area) )
THEN
675 IF (
PRESENT(err_msg))
THEN
676 err_msg =
'diag_manager_mod::register_diag_field: module/output_field '&
677 &//trim(module_name)//
'/'// trim(field_name)//
' AREA measures field NOT found in diag_table.&
678 & Contact the model liaison.'
682 CALL error_mesg (
'diag_manager_mod::register_diag_field',
'module/output_field '&
683 &//trim(module_name)//
'/'// trim(field_name)//
' AREA measures field NOT found in diag_table.&
684 & Contact the model liaison.',&
689 IF (
PRESENT(volume) )
THEN
690 IF ( volume < 0 )
THEN
691 IF (
PRESENT(err_msg))
THEN
692 err_msg =
'diag_manager_mod::register_diag_field: module/output_field '&
693 &//trim(module_name)//
'/'// trim(field_name)//
' VOLUME measures field NOT found in diag_table.&
694 & Contact the model liaison.'
698 CALL error_mesg (
'diag_manager_mod::register_diag_field',
'module/output_field '&
699 &//trim(module_name)//
'/'// trim(field_name)//
' VOLUME measures field NOT found in diag_table.&
700 & Contact the model liaison.',&
706 IF (
PRESENT(standard_name) ) input_fields(field)%standard_name = standard_name
708 DO j = 1, input_fields(field)%num_output_fields
709 ind = input_fields(field)%output_fields(j)
710 output_fields(ind)%static = .false.
713 file_num = output_fields(ind)%output_file
714 IF ( file_num == max_files ) cycle
715 IF ( output_fields(ind)%local_output )
THEN
716 IF ( output_fields(ind)%need_compute)
THEN
717 files(file_num)%local = .true.
725 IF ( msg /=
'' )
THEN
726 IF (
fms_error_handler(
'diag_manager_mod::register_diag_field', trim(msg), err_msg) )
RETURN
729 freq = files(file_num)%output_freq
731 output_units = files(file_num)%output_units
732 output_fields(ind)%last_output = diag_file_init_time
733 output_fields(ind)%next_output = diag_time_inc(diag_file_init_time, freq, output_units, err_msg=msg)
734 IF ( msg /=
'' )
THEN
736 &
' file='//trim(files(file_num)%name)//
': '//trim(msg),err_msg))
RETURN
738 output_fields(ind)%next_next_output = &
739 & diag_time_inc(output_fields(ind)%next_output, freq, output_units, err_msg=msg)
740 IF ( msg /=
'' )
THEN
742 &
' file='//trim(files(file_num)%name)//
': '//trim(msg),err_msg) )
RETURN
744 IF ( debug_diag_manager .AND.
mpp_pe() == mpp_root_pe() .AND. output_fields(ind)%local_output )
THEN
745 WRITE (msg,
'(" lon(",F5.1,", ",F5.1,"), lat(",F5.1,", ",F5.1,"), dep(",F5.1,", ",F5.1,")")') &
746 & output_fields(ind)%output_grid%start(1),output_fields(ind)%output_grid%end(1),&
747 & output_fields(ind)%output_grid%start(2),output_fields(ind)%output_grid%end(2),&
748 & output_fields(ind)%output_grid%start(3),output_fields(ind)%output_grid%end(3)
749 WRITE(stdout_unit,* )
'module/output_field '//trim(module_name)//
'/'//trim(field_name)// &
750 &
' will be output in region:'//trim(msg)
755 IF ( len_trim(err_msg).GT.0 )
THEN
756 CALL error_mesg (
'diag_manager_mod::register_diag_field',&
757 & trim(err_msg)//
' for module/field '//trim(module_name)//
'/'//trim(field_name),&
768 & missing_value, range, mask_variant, standard_name, DYNAMIC, do_not_log, interp_method,&
769 & tile_count, area, volume, realm)
770 CHARACTER(len=*),
INTENT(in) :: module_name, field_name
771 INTEGER,
DIMENSION(:),
INTENT(in) :: axes
772 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: long_name, units, standard_name
773 CLASS(*),
OPTIONAL,
INTENT(in) :: missing_value
774 CLASS(*),
DIMENSION(:),
OPTIONAL,
INTENT(in) :: range
775 LOGICAL,
OPTIONAL,
INTENT(in) :: mask_variant
776 LOGICAL,
OPTIONAL,
INTENT(in) :: dynamic
777 LOGICAL,
OPTIONAL,
INTENT(in) :: do_not_log
778 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: interp_method
782 INTEGER,
OPTIONAL,
INTENT(in) :: tile_count
783 INTEGER,
OPTIONAL,
INTENT(in) :: area
784 INTEGER,
OPTIONAL,
INTENT(in) :: volume
785 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: realm
787 REAL :: missing_value_use
788 REAL,
DIMENSION(2) :: range_use
789 INTEGER :: field, num_axes, j, out_num, k
790 INTEGER,
DIMENSION(3) :: siz, local_siz, local_start, local_end
791 INTEGER :: tile, file_num
792 LOGICAL :: mask_variant1, dynamic1, allow_log
793 CHARACTER(len=128) :: msg
794 INTEGER :: domain_type, i
795 character(len=256) :: axis_name
798 IF ( .NOT.module_is_initialized )
THEN
800 CALL error_mesg (
'diag_manager_mod::register_static_field_old',
'diag_manager has NOT been initialized', fatal)
804 IF (
PRESENT(missing_value) )
THEN
806 missing_value_use = cmor_missing_value
808 SELECT TYPE (missing_value)
809 TYPE IS (real(kind=r4_kind))
810 missing_value_use = missing_value
811 TYPE IS (real(kind=r8_kind))
812 missing_value_use = real(missing_value)
814 CALL error_mesg (
'diag_manager_mod::register_static_field',&
815 &
'The missing_value is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
820 IF (
PRESENT(mask_variant) )
THEN
821 mask_variant1 = mask_variant
823 mask_variant1 = .false.
826 IF (
PRESENT(dynamic) )
THEN
832 IF (
PRESENT(tile_count) )
THEN
838 IF (
PRESENT(do_not_log) )
THEN
839 allow_log = .NOT.do_not_log
845 IF (
PRESENT(range) )
THEN
846 IF (
SIZE(range) .NE. 2 )
THEN
848 CALL error_mesg (
'diag_manager_mod::register_static_field',
'extent of range should be 2', fatal)
854 IF ( do_diag_field_log.AND.allow_log )
THEN
856 & long_name, units, missing_value=missing_value, range=range, &
866 domain_type = axis_compatible_check(axes,field_name)
869 IF ( .NOT.input_fields(field)%register )
THEN
874 CALL error_mesg (
'diag_manager_mod::register_diag_field',
'module/output_field '//trim(module_name)//
'/'//&
875 & trim(field_name)//
' is not registered for tile_count = 1, should not register for tile_count > 1',&
881 DO j = 1, input_fields(field)%num_output_fields
882 out_num = input_fields(field)%output_fields(j)
883 file_num = output_fields(out_num)%output_file
884 IF(input_fields(field)%local)
THEN
885 CALL init_output_field(module_name, field_name,output_fields(out_num)%output_name,&
886 & files(file_num)%name,output_fields(out_num)%time_method, output_fields(out_num)%pack,&
887 & tile, input_fields(field)%local_coord)
889 CALL init_output_field(module_name, field_name,output_fields(out_num)%output_name,&
890 & files(file_num)%name,output_fields(out_num)%time_method, output_fields(out_num)%pack, tile)
900 input_fields(field)%static = .true.
902 IF ( input_fields(field)%register .AND.
mpp_pe() == mpp_root_pe() )
THEN
907 CALL error_mesg (
'diag_manager_mod::register_diag_field',
'module/output_field '//trim(module_name)//
'/'//&
908 & trim(field_name)//
' ALREADY registered, should not register twice', fatal)
912 IF (
PRESENT(volume).AND.
PRESENT(area) )
THEN
913 IF ( area.EQ.volume )
THEN
914 CALL error_mesg (
'diag_manager_mod::register_static_field_old',
'module/output_field '&
915 &//trim(module_name)//
'/'// trim(field_name)//
' AREA and VOLUME CANNOT be the same variable.&
916 & Contact the developers.',&
922 IF (
PRESENT(area) )
THEN
924 CALL error_mesg (
'diag_manager_mod::register_static_field_old',
'module/output_field '&
925 &//trim(module_name)//
'/'// trim(field_name)//
' AREA measures field NOT found in diag_table.&
926 & Contact the model liaison.n',&
930 IF (
PRESENT(volume) )
THEN
931 IF ( volume < 0 )
THEN
932 CALL error_mesg (
'diag_manager_mod::register_static_field_old',
'module/output_field '&
933 &//trim(module_name)//
'/'// trim(field_name)//
' VOLUME measures field NOT found in diag_table&
934 & Contact the model liaison.',&
940 input_fields(field)%register = .true.
942 input_fields(field)%mask_variant = mask_variant1
944 input_fields(field)%issued_mask_ignore_warning = .false.
947 IF (
PRESENT(long_name) )
THEN
948 input_fields(field)%long_name = trim(long_name)
950 input_fields(field)%long_name = input_fields(field)%field_name
953 IF (
PRESENT(standard_name) ) input_fields(field)%standard_name = standard_name
955 IF (
PRESENT(units) )
THEN
956 input_fields(field)%units = trim(units)
958 input_fields(field)%units =
'none'
961 IF (
PRESENT(missing_value) )
THEN
962 input_fields(field)%missing_value = missing_value_use
963 input_fields(field)%missing_value_present = .true.
965 input_fields(field)%missing_value_present = .false.
968 IF (
PRESENT(range) )
THEN
970 TYPE IS (real(kind=r4_kind))
972 TYPE IS (real(kind=r8_kind))
973 range_use = real(range)
975 CALL error_mesg (
'diag_manager_mod::register_static_field',&
976 &
'The range is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
978 input_fields(field)%range = range_use
980 input_fields(field)%range_present = range_use(2) .gt. range_use(1)
982 input_fields(field)%range = (/ 1., 0. /)
983 input_fields(field)%range_present = .false.
986 IF (
PRESENT(interp_method) )
THEN
987 IF ( trim(interp_method) .NE.
'conserve_order1' .AND.&
988 & trim(interp_method) .NE.
'conserve_order2' .AND.&
989 & trim(interp_method) .NE.
'none' )
THEN
995 CALL error_mesg (
'diag_manager_mod::register_diag_field',&
996 &
'when registering module/output_field '//trim(module_name)//
'/'//&
997 & trim(field_name)//
', the optional argument interp_method = '//trim(interp_method)//&
998 &
', but it should be "conserve_order1", "conserve_order2", or "none"', fatal)
1000 input_fields(field)%interp_method = trim(interp_method)
1002 input_fields(field)%interp_method =
''
1006 num_axes =
SIZE(axes(:))
1007 input_fields(field)%axes(1:num_axes) = axes
1008 input_fields(field)%num_axes = num_axes
1012 IF ( axes(j) .LE. 0 )
THEN
1016 CALL error_mesg (
'diag_manager_mod::register_diag_field',
'module/output_field '//trim(module_name)//
'/'//&
1017 & trim(field_name)//
' has non-positive axis_id', fatal)
1019 siz(j) = get_axis_length(axes(j))
1024 input_fields(field)%size(j) = siz(j)
1031 DO j = 1, input_fields(field)%num_output_fields
1032 out_num = input_fields(field)%output_fields(j)
1034 IF ( output_fields(out_num)%pack>=4 .AND. .NOT.input_fields(field)%range_present )
THEN
1035 IF(
mpp_pe() .EQ. mpp_root_pe())
THEN
1039 CALL error_mesg (
'diag_manager_mod::register_diag_field ',
'output_field '//trim(field_name)// &
1040 ' has pack >=4, range is REQUIRED in register_diag_field', fatal)
1045 IF ( .NOT.dynamic1 ) output_fields(out_num)%n_diurnal_samples = 1
1049 file_num = output_fields(out_num)%output_file
1050 if (domain_type .eq. diag_axis_2ddomain)
then
1051 if (files(file_num)%use_domainUG)
then
1052 call error_mesg(
"diag_manager_mod::register_static_field_old", &
1053 "Diagnostics living on a structured grid" &
1054 //
" and an unstructured grid cannot exist" &
1055 //
" in the same file (" &
1056 //trim(files(file_num)%name)//
")", &
1058 elseif (.not. files(file_num)%use_domain2D)
then
1059 files(file_num)%use_domain2D = .true.
1062 if (files(file_num)%use_domain2D)
then
1063 call error_mesg(
"diag_manager_mod::register_static_field_old", &
1064 "Diagnostics living on a structured grid" &
1065 //
" and an unstructured grid cannot exist" &
1066 //
" in the same file (" &
1067 //trim(files(file_num)%name)//
")", &
1069 elseif (.not. files(file_num)%use_domainUG)
then
1070 files(file_num)%use_domainUG = .true.
1076 IF ( output_fields(out_num)%reduced_k_range )
THEN
1085 local_start(2) = output_fields(out_num)%output_grid%l_start_indx(2)
1086 local_end(2) = output_fields(out_num)%output_grid%l_end_indx(2)
1087 local_siz(2) = local_end(2) - local_start(2) + 1
1088 allocate(output_fields(out_num)%buffer(siz(1),local_siz(2),siz(3), &
1089 output_fields(out_num)%n_diurnal_samples))
1090 output_fields(out_num)%region_elements = siz(1)*local_siz(2)*siz(3)
1091 output_fields(out_num)%reduced_k_unstruct = .true.
1093 local_start(3) = output_fields(out_num)%output_grid%l_start_indx(3)
1094 local_end(3) = output_fields(out_num)%output_grid%l_end_indx(3)
1095 local_siz(3) = local_end(3) - local_start(3) + 1
1096 allocate(output_fields(out_num)%buffer(siz(1),siz(2),local_siz(3), &
1097 output_fields(out_num)%n_diurnal_samples))
1098 output_fields(out_num)%region_elements = siz(1)*siz(2)*local_siz(3)
1099 output_fields(out_num)%reduced_k_unstruct = .false.
1101 output_fields(out_num)%total_elements = siz(1)*siz(2)*siz(3)
1104 IF ( output_fields(out_num)%time_max )
THEN
1105 output_fields(out_num)%buffer = max_value
1106 ELSE IF ( output_fields(out_num)%time_min )
THEN
1107 output_fields(out_num)%buffer = min_value
1109 output_fields(out_num)%buffer = empty
1111 ELSE IF ( output_fields(out_num)%local_output )
THEN
1112 IF (
SIZE(axes(:)) .LE. 1 )
THEN
1114 CALL error_mesg (
'diag_manager_mod::register_diag_field',
'axes of '//trim(field_name)//&
1115 &
' must >= 2 for local output', fatal)
1118 IF ( output_fields(out_num)%need_compute )
THEN
1120 local_start(k) = output_fields(out_num)%output_grid%l_start_indx(k)
1121 local_end(k) = output_fields(out_num)%output_grid%l_end_indx(k)
1122 local_siz(k) = local_end(k) - local_start(k) +1
1124 ALLOCATE(output_fields(out_num)%buffer(local_siz(1), local_siz(2), local_siz(3),&
1125 & output_fields(out_num)%n_diurnal_samples))
1126 IF(output_fields(out_num)%time_max)
THEN
1127 output_fields(out_num)%buffer = max_value
1128 ELSE IF(output_fields(out_num)%time_min)
THEN
1129 output_fields(out_num)%buffer = min_value
1131 output_fields(out_num)%buffer = empty
1133 output_fields(out_num)%region_elements = local_siz(1)*local_siz(2)*local_siz(3)
1134 output_fields(out_num)%total_elements = siz(1)*siz(2)*siz(3)
1135 files(output_fields(out_num)%output_file)%local = .true.
1139 ALLOCATE(output_fields(out_num)%buffer(siz(1), siz(2), siz(3),&
1140 & output_fields(out_num)%n_diurnal_samples))
1141 IF(output_fields(out_num)%time_max)
THEN
1142 output_fields(out_num)%buffer = max_value
1143 ELSE IF(output_fields(out_num)%time_min)
THEN
1144 output_fields(out_num)%buffer = min_value
1146 output_fields(out_num)%buffer = empty
1148 output_fields(out_num)%total_elements = siz(1)*siz(2)*siz(3)
1152 output_fields(out_num)%static = .true.
1154 IF ( .NOT.dynamic1 .AND. output_fields(out_num)%time_ops )
THEN
1155 WRITE (msg,
'(a,"/",a)') trim(module_name), trim(field_name)
1156 IF (
mpp_pe() .EQ. mpp_root_pe() )
THEN
1163 CALL error_mesg (
'diag_manager_mod::register_static_field_old',&
1164 &
'module/field '//trim(msg)//
' is STATIC. Cannot perform time operations&
1165 & average, maximum, or minimum on static fields. Setting the time operation&
1166 & to "NONE" for this field.', warning)
1168 output_fields(out_num)%time_ops = .false.
1169 output_fields(out_num)%time_average = .false.
1170 output_fields(out_num)%time_method =
'point'
1175 output_fields(out_num)%num_axes = input_fields(field)%num_axes
1177 IF ( .NOT.output_fields(out_num)%local_output )
THEN
1178 output_fields(out_num)%axes(1:input_fields(field)%num_axes) =&
1179 & input_fields(field)%axes(1:input_fields(field)%num_axes)
1181 output_fields(out_num)%axes(1:input_fields(field)%num_axes) =&
1182 & output_fields(out_num)%output_grid%subaxes(1:input_fields(field)%num_axes)
1187 IF ( output_fields(out_num)%n_diurnal_samples > 1 )
THEN
1188 output_fields(out_num)%axes(output_fields(out_num)%num_axes+1) =&
1190 output_fields(out_num)%num_axes = output_fields(out_num)%num_axes+1
1193 IF ( output_fields(out_num)%reduced_k_range )
THEN
1197 output_fields(out_num)%axes(2) = output_fields(out_num)%output_grid%subaxes(2)
1199 output_fields(out_num)%axes(3) = output_fields(out_num)%output_grid%subaxes(3)
1205 output_fields(out_num)%Time_of_prev_field_data = time_zero
1209 IF ( len_trim(msg).GT.0 )
THEN
1210 CALL error_mesg (
'diag_manager_mod::register_static_field_old',&
1211 & trim(msg)//
' for module/field '//trim(module_name)//
'/'//trim(field_name),&
1216 IF (
PRESENT(realm) )
THEN
1217 CALL prepend_attribute(output_fields(out_num),
'modeling_realm', lowercase(trim(realm)))
1221 IF ( input_fields(field)%mask_variant )
THEN
1222 DO j = 1, input_fields(field)%num_output_fields
1223 out_num = input_fields(field)%output_fields(j)
1224 IF(output_fields(out_num)%time_average)
THEN
1230 if (output_fields(out_num)%reduced_k_range .and. &
1232 allocate(output_fields(out_num)%counter(siz(1),local_siz(2),siz(3), &
1233 output_fields(out_num)%n_diurnal_samples))
1235 allocate(output_fields(out_num)%counter(siz(1),siz(2),siz(3), &
1236 output_fields(out_num)%n_diurnal_samples))
1239 output_fields(out_num)%counter = 0.0
1250 CHARACTER(len=*),
INTENT(in) :: module_name
1251 CHARACTER(len=*),
INTENT(in) :: field_name
1256 if (use_modern_diag)
then
1257 get_diag_field_id = fms_diag_object%fms_get_diag_field_id_from_name(module_name, field_name)
1268 INTEGER,
INTENT(in) :: field
1270 INTEGER,
INTENT(out) :: out_field_id
1271 INTEGER,
INTENT(out) :: out_file_id
1273 INTEGER :: i, cm_ind, cm_file_num
1277 rel_file = rel_field%output_file
1285 DO i = 1, input_fields(field)%num_output_fields
1286 cm_ind = input_fields(field)%output_fields(i)
1287 cm_file_num = output_fields(cm_ind)%output_file
1289 IF ( cm_file_num.EQ.rel_file.AND.&
1290 & (( (output_fields(cm_ind)%time_ops.EQV.rel_field%time_ops) .AND.&
1291 & (output_fields(cm_ind)%next_output.EQ.rel_field%next_output) .AND.&
1292 & (output_fields(cm_ind)%last_output.EQ.rel_field%last_output) ).OR.&
1293 & (output_fields(cm_ind)%static.OR.rel_field%static) ) )
THEN
1295 out_field_id = cm_ind
1296 out_file_id = cm_file_num
1303 DO i = 1, input_fields(field)%num_output_fields
1304 cm_ind = input_fields(field)%output_fields(i)
1305 cm_file_num = output_fields(cm_ind)%output_file
1316 IF ( output_fields(cm_ind)%static.OR.rel_field%static )
THEN
1318 out_field_id = cm_ind
1319 out_file_id = cm_file_num
1329 INTEGER,
INTENT(in),
OPTIONAL :: area
1330 INTEGER,
INTENT(in),
OPTIONAL :: volume
1331 CHARACTER(len=*),
INTENT(out),
OPTIONAL :: err_msg
1333 INTEGER :: cm_ind, cm_file_num, file_num
1335 IF (
PRESENT(err_msg) )
THEN
1340 IF (
PRESENT(area) )
THEN
1341 IF ( area.LE.0 )
THEN
1343 &
'AREA field not in diag_table for field '//trim(input_fields(output_field%input_field)%module_name)//&
1344 &
'/'//trim(input_fields(output_field%input_field)%field_name), err_msg) )
RETURN
1348 IF (
PRESENT(volume) )
THEN
1349 IF ( volume.LE.0 )
THEN
1351 &
'VOLUME field not in diag_table for field '//trim(input_fields(output_field%input_field)%module_name)//&
1352 &
'/'//trim(input_fields(output_field%input_field)%field_name), err_msg) )
RETURN
1357 file_num = output_field%output_file
1360 IF (
PRESENT(area) )
THEN
1363 &
'area: '//trim(output_fields(cm_ind)%output_name))
1364 IF ( cm_file_num.NE.file_num )
THEN
1370 &
'AREA measures field "'//trim(input_fields(area)%module_name)//
'/'//&
1371 & trim(input_fields(area)%field_name)//&
1372 &
'" NOT in diag_table with correct output frequency for field '//&
1373 & trim(input_fields(output_field%input_field)%module_name)//&
1374 &
'/'//trim(input_fields(output_field%input_field)%field_name), err_msg) )
RETURN
1379 IF (
PRESENT(volume) )
THEN
1382 &
'volume: '//trim(output_fields(cm_ind)%output_name))
1383 IF ( cm_file_num.NE.file_num )
THEN
1389 &
'VOLUME measures field "'//trim(input_fields(volume)%module_name)//
'/'//&
1390 & trim(input_fields(volume)%field_name)//&
1391 &
'" NOT in diag_table with correct output frequency for field '//&
1392 & trim(input_fields(output_field%input_field)%module_name)//&
1393 &
'/'//trim(input_fields(output_field%input_field)%field_name), err_msg) )
RETURN
1404 INTEGER,
intent(in) :: file_num
1405 INTEGER,
intent(in) :: cm_file_num
1406 INTEGER,
intent(in) :: cm_ind
1408 INTEGER :: year, month, day, hour, minute, second
1410 CHARACTER(len=25) :: date_prefix
1411 CHARACTER(len=FMS_FILE_LEN) :: asso_file_name
1414 IF ( prepend_date )
THEN
1415 CALL get_date(diag_init_time, year, month, day, hour, minute, second)
1416 WRITE (date_prefix,
'(1I20.4, 2I2.2,".")') year, month, day
1417 date_prefix=adjustl(date_prefix)
1425 IF ( len_trim(files(cm_file_num)%name)+17 > len(asso_file_name) )
THEN
1426 CALL error_mesg (
'diag_manager_mod::add_associated_files',&
1427 &
'Length of asso_file_name is not long enough to hold the associated file name. '&
1428 & //
'Contact the developer', fatal)
1430 asso_file_name = trim(files(cm_file_num)%name)
1441 n = max(len_trim(asso_file_name),3)
1442 if (asso_file_name(n-2:n).NE.
'.nc') asso_file_name = trim(asso_file_name)//
'.nc'
1446 & trim(output_fields(cm_ind)%output_name)//
': '//&
1447 & trim(date_prefix)//trim(asso_file_name))
1452 INTEGER,
INTENT(in) :: diag_field_id
1453 CLASS(*),
INTENT(in) :: field
1454 TYPE(
time_type),
INTENT(in),
OPTIONAL :: time
1455 CHARACTER(len=*),
INTENT(out),
OPTIONAL :: err_msg
1457 CLASS(*),
allocatable :: field_out(:, :, :)
1460 IF ( diag_field_id <= 0 )
THEN
1467 TYPE IS (real(kind=r4_kind))
1468 allocate(real(r4_kind) :: field_out(1,1,1))
1469 select type(field_out)
1470 type is (real(r4_kind))
1471 field_out(1, 1, 1) = field
1473 call error_mesg(
'diag_manager_mod::send_data_0d', &
1474 &
'Error allocating field out as real(r4_kind)', fatal)
1476 TYPE IS (real(kind=r8_kind))
1477 allocate(real(r8_kind) :: field_out(1,1,1))
1478 select type(field_out)
1479 type is (real(r8_kind))
1480 field_out(1, 1, 1) = field
1482 call error_mesg(
'diag_manager_mod::send_data_0d', &
1483 &
'Error allocating field out as real(r8_kind)', fatal)
1486 CALL error_mesg (
'diag_manager_mod::send_data_0d',&
1487 &
'The field is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
1494 LOGICAL FUNCTION send_data_1d(diag_field_id, field, time, is_in, mask, rmask, ie_in, weight, err_msg)
1495 INTEGER,
INTENT(in) :: diag_field_id
1496 CLASS(*),
DIMENSION(:),
INTENT(in) :: field
1497 CLASS(*),
INTENT(in),
OPTIONAL :: weight
1498 CLASS(*),
INTENT(in),
DIMENSION(:),
OPTIONAL :: rmask
1499 TYPE (
time_type),
INTENT(in),
OPTIONAL :: time
1500 INTEGER,
INTENT(in),
OPTIONAL :: is_in, ie_in
1501 LOGICAL,
INTENT(in),
DIMENSION(:),
OPTIONAL :: mask
1502 CHARACTER(len=*),
INTENT(out),
OPTIONAL :: err_msg
1504 CLASS(*),
ALLOCATABLE :: field_out(:,:,:)
1505 LOGICAL,
DIMENSION(SIZE(field(:)), 1, 1) :: mask_out
1508 IF ( diag_field_id <= 0 )
THEN
1516 TYPE IS (real(kind=r4_kind))
1517 allocate(real(r4_kind) :: field_out(
SIZE(field),1,1))
1518 select type(field_out)
1519 type is (real(r4_kind))
1520 field_out(:, 1, 1) = field
1522 call error_mesg(
'diag_manager_mod::send_data_1d', &
1523 &
'Error allocating field out as real(r4_kind)', fatal)
1525 TYPE IS (real(kind=r8_kind))
1526 allocate(real(r8_kind) :: field_out(
SIZE(field),1,1))
1527 select type(field_out)
1528 type is (real(r8_kind))
1529 field_out(:, 1, 1) = field
1531 call error_mesg(
'diag_manager_mod::send_data_1d', &
1532 &
'Error allocating field out as real(r8_kind)', fatal)
1535 CALL error_mesg (
'diag_manager_mod::send_data_1d',&
1536 &
'The field is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
1540 IF (
PRESENT(mask) )
THEN
1541 mask_out(:, 1, 1) = mask
1546 IF (
PRESENT(rmask) )
THEN
1548 TYPE IS (real(kind=r4_kind))
1549 WHERE (rmask < 0.5_r4_kind) mask_out(:, 1, 1) = .false.
1550 TYPE IS (real(kind=r8_kind))
1551 WHERE (rmask < 0.5_r8_kind) mask_out(:, 1, 1) = .false.
1553 CALL error_mesg (
'diag_manager_mod::send_data_1d',&
1554 &
'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
1558 IF (
PRESENT(mask) .OR.
PRESENT(rmask) )
THEN
1559 IF (
PRESENT(is_in) .OR.
PRESENT(ie_in) )
THEN
1561 & mask=mask_out, ie_in=ie_in, je_in=1, ke_in=1, weight=weight, err_msg=err_msg)
1564 & weight=weight, err_msg=err_msg)
1567 IF (
PRESENT(is_in) .OR.
PRESENT(ie_in) )
THEN
1569 & ie_in=ie_in, je_in=1, ke_in=1, weight=weight, err_msg=err_msg)
1578 & mask, rmask, ie_in, je_in, weight, err_msg)
1579 INTEGER,
INTENT(in) :: diag_field_id
1580 CLASS(*),
INTENT(in),
DIMENSION(:,:) :: field
1581 CLASS(*),
INTENT(in),
OPTIONAL :: weight
1582 TYPE (
time_type),
INTENT(in),
OPTIONAL :: time
1583 INTEGER,
INTENT(in),
OPTIONAL :: is_in, js_in, ie_in, je_in
1584 LOGICAL,
INTENT(in),
DIMENSION(:,:),
OPTIONAL :: mask
1585 CLASS(*),
INTENT(in),
DIMENSION(:,:),
OPTIONAL :: rmask
1586 CHARACTER(len=*),
INTENT(out),
OPTIONAL :: err_msg
1588 CLASS(*),
ALLOCATABLE :: field_out(:,:,:)
1589 LOGICAL,
DIMENSION(SIZE(field,1),SIZE(field,2),1) :: mask_out
1592 IF ( diag_field_id <= 0 )
THEN
1599 TYPE IS (real(kind=r4_kind))
1600 allocate(real(r4_kind) :: field_out(
SIZE(field,1),
SIZE(field,2),1))
1601 select type(field_out)
1602 type is (real(r4_kind))
1603 field_out(:, :, 1) = field
1605 call error_mesg(
'diag_manager_mod::send_data_2d', &
1606 &
'Error allocating field out as real(r4_kind)', fatal)
1608 TYPE IS (real(kind=r8_kind))
1609 allocate(real(r8_kind) :: field_out(
SIZE(field,1),
SIZE(field,2),1))
1610 select type(field_out)
1611 type is (real(r8_kind))
1612 field_out(:, :, 1) = field
1614 call error_mesg(
'diag_manager_mod::send_data_2d', &
1615 &
'Error allocating field out as real(r8_kind)', fatal)
1618 CALL error_mesg (
'diag_manager_mod::send_data_2d',&
1619 &
'The field is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
1623 IF (
PRESENT(mask) )
THEN
1624 mask_out(:, :, 1) = mask
1629 IF (
PRESENT(rmask) )
THEN
1631 TYPE IS (real(kind=r4_kind))
1632 WHERE ( rmask < 0.5_r4_kind ) mask_out(:, :, 1) = .false.
1633 TYPE IS (real(kind=r8_kind))
1634 WHERE ( rmask < 0.5_r8_kind ) mask_out(:, :, 1) = .false.
1636 CALL error_mesg (
'diag_manager_mod::send_data_2d',&
1637 &
'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
1641 IF (
PRESENT(mask) .OR.
PRESENT(rmask) )
THEN
1643 & mask=mask_out, ie_in=ie_in, je_in=je_in, ke_in=1, weight=weight, err_msg=err_msg)
1646 & ie_in=ie_in, je_in=je_in, ke_in=1, weight=weight, err_msg=err_msg)
1651 LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
1652 & mask, rmask, ie_in, je_in, ke_in, weight, err_msg)
1653 INTEGER,
INTENT(in) :: diag_field_id
1654 CLASS(*),
DIMENSION(:,:,:),
INTENT(in) :: field
1655 CLASS(*),
INTENT(in),
OPTIONAL :: weight
1656 TYPE (
time_type),
INTENT(in),
OPTIONAL :: time
1657 INTEGER,
INTENT(in),
OPTIONAL :: is_in, js_in, ks_in,ie_in,je_in, ke_in
1658 LOGICAL,
DIMENSION(:,:,:),
INTENT(in),
OPTIONAL :: mask
1659 CLASS(*),
DIMENSION(:,:,:),
INTENT(in),
OPTIONAL :: rmask
1660 CHARACTER(len=*),
INTENT(out),
OPTIONAL :: err_msg
1662 if (
present(mask) .and.
present(rmask))
then
1664 mask=mask, rmask=rmask, ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, &
1666 elseif (
present(rmask))
then
1668 rmask=rmask, ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, err_msg=err_msg)
1669 elseif (
present(mask))
then
1671 mask=mask, ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, err_msg=err_msg)
1674 ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, err_msg=err_msg)
1681 & mask, rmask, ie_in, je_in, ke_in, weight, err_msg)
1682 INTEGER,
INTENT(in) :: diag_field_id
1683 CLASS(*),
DIMENSION(:,:,:),
INTENT(in),
TARGET :: field
1684 CLASS(*),
INTENT(in),
OPTIONAL :: weight
1685 TYPE (
time_type),
INTENT(in),
OPTIONAL :: time
1686 INTEGER,
INTENT(in),
OPTIONAL :: is_in, js_in, ks_in,ie_in,je_in, ke_in
1687 LOGICAL,
DIMENSION(:,:,:),
INTENT(in),
OPTIONAL,
target :: mask
1688 CLASS(*),
DIMENSION(:,:,:),
INTENT(in),
OPTIONAL,
target :: rmask
1689 CHARACTER(len=*),
INTENT(out),
OPTIONAL :: err_msg
1693 INTEGER :: pow_value
1695 INTEGER :: i, out_num, file_num, n1, n2, n3, number_of_outputs, ii,f1,f2,f3,f4
1696 INTEGER :: freq, units, is, js, ks, ie, je, ke, i1, j1,k1, j, k
1697 INTEGER,
DIMENSION(3) :: l_start
1698 INTEGER,
DIMENSION(3) :: l_end
1708 INTEGER :: numthreads
1709 INTEGER :: active_omp_level
1710 #if defined(_OPENMP)
1711 INTEGER :: omp_get_num_threads
1712 INTEGER :: omp_get_level
1714 LOGICAL :: average, phys_window, need_compute
1715 LOGICAL :: reduced_k_range, local_output
1716 LOGICAL :: time_max, time_min, time_rms, time_sum
1717 LOGICAL :: missvalue_present
1718 LOGICAL,
ALLOCATABLE,
DIMENSION(:,:,:) :: oor_mask
1719 CHARACTER(len=256) :: err_msg_local
1720 CHARACTER(len=128) :: error_string, error_string1
1722 REAL,
ALLOCATABLE,
DIMENSION(:,:,:) :: field_out
1723 class(*),
allocatable,
dimension(:,:,:,:) :: field_remap
1724 logical,
allocatable,
dimension(:,:,:,:) :: mask_remap
1725 class(*),
allocatable,
dimension(:,:,:,:) :: rmask_remap
1726 REAL(kind=r4_kind),
POINTER,
DIMENSION(:,:,:) :: rmask_ptr_r4
1727 REAL(kind=r8_kind),
POINTER,
DIMENSION(:,:,:) :: rmask_ptr_r8
1731 LOGICAL :: mf_result
1733 REAL :: rmask_threshold
1735 character(len=:),
allocatable :: field_name
1738 IF ( diag_field_id <= 0 )
THEN
1745 IF (
PRESENT(err_msg) ) err_msg =
''
1746 IF ( .NOT.module_is_initialized )
THEN
1747 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d',
'diag_manager NOT initialized', err_msg) )
RETURN
1760 ALLOCATE(field_out(
SIZE(field,1),
SIZE(field,2),
SIZE(field,3)), stat=status)
1761 IF ( status .NE. 0 )
THEN
1762 WRITE (err_msg_local, fmt=
'("Unable to allocate field_out(",I5,",",I5,",",I5,"). (STAT: ",I5,")")')&
1763 &
SIZE(field,1),
SIZE(field,2),
SIZE(field,3), status
1764 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
RETURN
1767 TYPE IS (real(kind=r4_kind))
1769 TYPE IS (real(kind=r8_kind))
1770 field_out = real(field)
1772 CALL error_mesg (
'diag_manager_mod::send_data_3d',&
1773 &
'The field is not one of the supported types (real(kind=4) or real(kind=8)). '//&
1774 &
'If using an integer, please set use_modern_diag=.t. in the diag_manager_nml.', fatal)
1777 modern_if:
iF (use_modern_diag)
then
1778 field_name = fms_diag_object%fms_get_field_name_from_id(diag_field_id)
1779 call copy_3d_to_4d(field, field_remap, trim(field_name)//
"'s data")
1780 if (
present(rmask))
call copy_3d_to_4d(rmask, rmask_remap, trim(field_name)//
"'s mask")
1781 if (
present(mask))
then
1782 allocate(mask_remap(1:
size(mask,1), 1:
size(mask,2), 1:
size(mask,3), 1))
1783 mask_remap(:,:,:,1) = mask
1785 call fms_diag_object%fms_diag_accept_data(diag_field_id, field_remap, mask_remap, rmask_remap, &
1786 time, is_in, js_in, ks_in, ie_in, je_in, ke_in, weight, &
1788 deallocate (field_remap)
1789 if (
allocated(mask_remap))
deallocate(mask_remap)
1790 if (
allocated(rmask_remap))
deallocate(rmask_remap)
1793 ALLOCATE(oor_mask(
SIZE(field,1),
SIZE(field,2),
SIZE(field,3)), stat=status)
1794 IF ( status .NE. 0 )
THEN
1795 WRITE (err_msg_local, fmt=
'("Unable to allocate oor_mask(",I5,",",I5,",",I5,"). (STAT: ",I5,")")')&
1796 &
SIZE(field,1),
SIZE(field,2),
SIZE(field,3), status
1797 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
RETURN
1800 IF (
PRESENT(mask) )
THEN
1806 rmask_ptr_r4 => null()
1807 rmask_ptr_r8 => null()
1808 IF (
PRESENT(rmask) )
THEN
1810 TYPE IS (real(kind=r4_kind))
1811 WHERE ( rmask < 0.5_r4_kind ) oor_mask = .false.
1812 rmask_threshold = 0.5_r4_kind
1813 rmask_ptr_r4 => rmask
1814 TYPE IS (real(kind=r8_kind))
1815 WHERE ( rmask < 0.5_r8_kind ) oor_mask = .false.
1816 rmask_threshold = 0.5_r8_kind
1817 rmask_ptr_r8 => rmask
1819 CALL error_mesg (
'diag_manager_mod::send_data_3d',&
1820 &
'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
1835 IF (
PRESENT(ie_in) )
THEN
1836 IF ( .NOT.
PRESENT(is_in) )
THEN
1837 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d',
'ie_in present without is_in', err_msg) )
THEN
1838 DEALLOCATE(field_out)
1839 DEALLOCATE(oor_mask)
1843 IF (
PRESENT(js_in) .AND. .NOT.
PRESENT(je_in) )
THEN
1845 &
'is_in and ie_in present, but js_in present without je_in', err_msg) )
THEN
1846 DEALLOCATE(field_out)
1847 DEALLOCATE(oor_mask)
1852 IF (
PRESENT(je_in) )
THEN
1853 IF ( .NOT.
PRESENT(js_in) )
THEN
1854 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d',
'je_in present without js_in', err_msg) )
THEN
1855 DEALLOCATE(field_out)
1856 DEALLOCATE(oor_mask)
1860 IF (
PRESENT(is_in) .AND. .NOT.
PRESENT(ie_in) )
THEN
1862 &
'js_in and je_in present, but is_in present without ie_in', err_msg))
THEN
1863 DEALLOCATE(field_out)
1864 DEALLOCATE(oor_mask)
1874 IF (
PRESENT(is_in) ) is = is_in
1875 IF (
PRESENT(js_in) ) js = js_in
1876 IF (
PRESENT(ks_in) ) ks = ks_in
1883 IF (
PRESENT(ie_in) ) ie = ie_in
1884 IF (
PRESENT(je_in) ) je = je_in
1885 IF (
PRESENT(ke_in) ) ke = ke_in
1886 twohi = n1-(ie-is+1)
1887 IF ( mod(twohi,2) /= 0 )
THEN
1888 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d',
'non-symmetric halos in first dimension', &
1890 DEALLOCATE(field_out)
1891 DEALLOCATE(oor_mask)
1895 twohj = n2-(je-js+1)
1896 IF ( mod(twohj,2) /= 0 )
THEN
1897 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d',
'non-symmetric halos in second dimension', &
1899 DEALLOCATE(field_out)
1900 DEALLOCATE(oor_mask)
1909 IF (
PRESENT(ie_in) .AND.
PRESENT(je_in) )
THEN
1923 IF (
PRESENT(weight) )
THEN
1924 SELECT TYPE (weight)
1925 TYPE IS (real(kind=r4_kind))
1927 TYPE IS (real(kind=r8_kind))
1928 weight1 = real(weight)
1930 CALL error_mesg (
'diag_manager_mod::send_data_3d',&
1931 &
'The weight is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
1938 missvalue_present = input_fields(diag_field_id)%missing_value_present
1939 IF ( missvalue_present ) missvalue = input_fields(diag_field_id)%missing_value
1941 number_of_outputs = input_fields(diag_field_id)%num_output_fields
1943 input_fields(diag_field_id)%numthreads = 1
1945 #if defined(_OPENMP)
1946 input_fields(diag_field_id)%numthreads = omp_get_num_threads()
1947 input_fields(diag_field_id)%active_omp_level = omp_get_level()
1949 numthreads = input_fields(diag_field_id)%numthreads
1950 active_omp_level = input_fields(diag_field_id)%active_omp_level
1953 if(
present(time)) input_fields(diag_field_id)%time = time
1956 IF ( input_fields(diag_field_id)%range_present )
THEN
1957 IF ( issue_oor_warnings .OR. oor_warnings_fatal )
THEN
1958 WRITE (error_string,
'("[",ES14.5E3,",",ES14.5E3,"]")')&
1959 & input_fields(diag_field_id)%range(1:2)
1960 WRITE (error_string1,
'("(Min: ",ES14.5E3,", Max: ",ES14.5E3, ")")')&
1961 & minval(field_out(f1:f2,f3:f4,ks:ke),mask=oor_mask(f1:f2,f3:f4,ks:ke)),&
1962 & maxval(field_out(f1:f2,f3:f4,ks:ke),mask=oor_mask(f1:f2,f3:f4,ks:ke))
1963 IF ( missvalue_present )
THEN
1964 IF ( any(oor_mask(f1:f2,f3:f4,ks:ke) .AND.&
1965 & ((field_out(f1:f2,f3:f4,ks:ke) < input_fields(diag_field_id)%range(1) .OR.&
1966 & field_out(f1:f2,f3:f4,ks:ke) > input_fields(diag_field_id)%range(2)).AND.&
1967 & field_out(f1:f2,f3:f4,ks:ke) .NE. missvalue)) )
THEN
1973 CALL error_mesg(
'diag_manager_mod::send_data_3d',&
1975 &trim(input_fields(diag_field_id)%module_name)//
' in field '//&
1976 &trim(input_fields(diag_field_id)%field_name)//
' '&
1977 &//trim(error_string1)//&
1978 &
' is outside the range '//trim(error_string)//
',&
1979 & and not equal to the missing value.',&
1983 IF ( any(oor_mask(f1:f2,f3:f4,ks:ke) .AND.&
1984 & (field_out(f1:f2,f3:f4,ks:ke) < input_fields(diag_field_id)%range(1) .OR.&
1985 & field_out(f1:f2,f3:f4,ks:ke) > input_fields(diag_field_id)%range(2))) )
THEN
1990 CALL error_mesg(
'diag_manager_mod::send_data_3d',&
1992 &trim(input_fields(diag_field_id)%module_name)//
' in field '//&
1993 &trim(input_fields(diag_field_id)%field_name)//
' '&
1994 &//trim(error_string1)//&
1995 &
' is outside the range '//trim(error_string)//
'.',&
2003 num_out_fields:
DO ii = 1, number_of_outputs
2005 out_num = input_fields(diag_field_id)%output_fields(ii)
2008 local_output = output_fields(out_num)%local_output
2010 need_compute = output_fields(out_num)%need_compute
2012 reduced_k_range = output_fields(out_num)%reduced_k_range
2015 IF ( local_output .AND. (.NOT.need_compute) ) cycle
2018 file_num = output_fields(out_num)%output_file
2019 IF(file_num == max_files) cycle
2021 freq = files(file_num)%output_freq
2022 units = files(file_num)%output_units
2024 average = output_fields(out_num)%time_average
2027 time_rms = output_fields(out_num)%time_rms
2029 pow_value = output_fields(out_num)%pow_value
2031 time_max = output_fields(out_num)%time_max
2032 time_min = output_fields(out_num)%time_min
2034 time_sum = output_fields(out_num)%time_sum
2035 IF ( output_fields(out_num)%total_elements >
SIZE(field_out(f1:f2,f3:f4,ks:ke)) )
THEN
2036 output_fields(out_num)%phys_window = .true.
2038 output_fields(out_num)%phys_window = .false.
2040 phys_window = output_fields(out_num)%phys_window
2041 IF ( need_compute )
THEN
2042 l_start = output_fields(out_num)%output_grid%l_start_indx
2043 l_end = output_fields(out_num)%output_grid%l_end_indx
2048 IF (
PRESENT(time) )
THEN
2049 CALL get_time(time,second,day,tick)
2051 & * output_fields(out_num)%n_diurnal_samples/seconds_per_day) + 1
2055 IF ( reduced_k_range )
THEN
2058 if (output_fields(out_num)%reduced_k_unstruct)
then
2059 f3 = output_fields(out_num)%output_grid%l_start_indx(2)
2060 f4 = output_fields(out_num)%output_grid%l_end_indx(2)
2064 l_start(3) = output_fields(out_num)%output_grid%l_start_indx(3)
2065 l_end(3) = output_fields(out_num)%output_grid%l_end_indx(3)
2072 IF ( freq == every_time .AND. .NOT.output_fields(out_num)%static )
THEN
2073 IF (
PRESENT(time))
THEN
2074 IF ( numthreads .ne. 1 .or. active_omp_level .gt. 1)
THEN
2078 IF ( time > output_fields(out_num)%last_output )
THEN
2079 output_fields(out_num)%next_output = time
2085 IF ( output_fields(out_num)%next_output == output_fields(out_num)%last_output )
THEN
2086 output_fields(out_num)%next_output = time
2089 ELSE IF ( output_fields(out_num)%next_output == output_fields(out_num)%last_output )
THEN
2090 WRITE (error_string,
'(a,"/",a)')&
2091 & trim(input_fields(diag_field_id)%module_name),&
2092 & trim(output_fields(out_num)%output_name)
2093 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d',
'module/output_field '//trim(error_string)//&
2094 &
', time must be present when output frequency = EVERY_TIME', err_msg))
THEN
2095 DEALLOCATE(field_out)
2096 DEALLOCATE(oor_mask)
2101 IF ( .NOT.output_fields(out_num)%static .AND. .NOT.
PRESENT(time) )
THEN
2102 WRITE (error_string,
'(a,"/",a)')&
2103 & trim(input_fields(diag_field_id)%module_name), &
2104 & trim(output_fields(out_num)%output_name)
2105 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d',
'module/output_field '//trim(error_string)//&
2106 &
', time must be present for nonstatic field', err_msg))
THEN
2107 DEALLOCATE(field_out)
2108 DEALLOCATE(oor_mask)
2116 IF ( (numthreads == 1) .AND. (active_omp_level.LE.1) )
then
2117 IF ( .NOT.output_fields(out_num)%static .AND. freq /= end_of_run )
THEN
2118 IF ( time > output_fields(out_num)%next_output )
THEN
2120 IF ( time > output_fields(out_num)%next_next_output .AND. freq > 0 )
THEN
2121 IF (
mpp_pe() .EQ. mpp_root_pe() )
THEN
2122 WRITE (error_string,
'(a,"/",a)')&
2123 & trim(input_fields(diag_field_id)%module_name), &
2124 & trim(output_fields(out_num)%output_name)
2125 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d',
'module/output_field '//&
2126 & trim(error_string)//
' is skipped one time level in output data', err_msg))
THEN
2127 DEALLOCATE(field_out)
2128 DEALLOCATE(oor_mask)
2134 status =
writing_field(out_num, .false., error_string, time)
2135 IF(status == -1)
THEN
2136 IF (
mpp_pe() .EQ. mpp_root_pe() )
THEN
2137 IF(
fms_error_handler(
'diag_manager_mod::send_data_3d',
'module/output_field '//trim(error_string)&
2138 & //
', write EMPTY buffer', err_msg))
THEN
2139 DEALLOCATE(field_out)
2140 DEALLOCATE(oor_mask)
2150 if (
present(time))
then
2152 if (output_fields(out_num)%last_output > time) cycle
2155 IF ( .NOT.output_fields(out_num)%static .AND. .NOT.need_compute .AND. debug_diag_manager )
THEN
2157 IF ( err_msg_local /=
'' )
THEN
2158 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
2159 DEALLOCATE(field_out)
2160 DEALLOCATE(oor_mask)
2166 IF (use_refactored_send)
THEN
2167 ALLOCATE( ofield_index_cfg )
2168 CALL ofield_index_cfg%initialize( is, js, ks, ie, je, ke, &
2169 & hi, hj, f1, f2, f3, f4)
2171 ALLOCATE( ofield_cfg )
2172 CALL ofield_cfg%initialize( input_fields(diag_field_id), output_fields(out_num),
PRESENT(mask), freq)
2176 mf_result =
fieldbuff_update(ofield_cfg, ofield_index_cfg, field_out, sample, &
2177 & output_fields(out_num)%buffer, output_fields(out_num)%counter ,output_fields(out_num)%buff_bounds,&
2178 & output_fields(out_num)%count_0d(sample), output_fields(out_num)%num_elements(sample), &
2179 & mask, weight1 ,missvalue, &
2180 & input_fields(diag_field_id)%numthreads, input_fields(diag_field_id)%active_omp_level,&
2181 & input_fields(diag_field_id)%issued_mask_ignore_warning, &
2182 & l_start, l_end, err_msg, err_msg_local )
2183 IF (mf_result .eqv. .false.)
THEN
2184 DEALLOCATE(ofield_index_cfg)
2185 DEALLOCATE(ofield_cfg)
2186 DEALLOCATE(field_out)
2187 DEALLOCATE(oor_mask)
2192 & output_fields(out_num)%buffer, output_fields(out_num)%buff_bounds , &
2193 & output_fields(out_num)%count_0d(sample), &
2194 & mask, missvalue, l_start, l_end, err_msg, err_msg_local)
2195 IF (mf_result .eqv. .false.)
THEN
2196 DEALLOCATE(ofield_index_cfg)
2197 DEALLOCATE(ofield_cfg)
2198 DEALLOCATE(field_out)
2199 DEALLOCATE(oor_mask)
2204 IF ( output_fields(out_num)%static .AND. .NOT.need_compute .AND. debug_diag_manager )
THEN
2206 IF ( err_msg_local /=
'' )
THEN
2207 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg))
THEN
2208 DEALLOCATE(field_out)
2209 DEALLOCATE(oor_mask)
2236 IF(
ALLOCATED(ofield_index_cfg))
THEN
2237 DEALLOCATE(ofield_index_cfg)
2239 IF(
ALLOCATED(ofield_cfg))
THEN
2240 DEALLOCATE(ofield_cfg)
2247 IF ( input_fields(diag_field_id)%mask_variant )
THEN
2248 IF ( need_compute )
THEN
2249 WRITE (error_string,
'(a,"/",a)') &
2250 & trim(input_fields(diag_field_id)%module_name), &
2251 & trim(output_fields(out_num)%output_name)
2252 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d',
'module/output_field '//trim(error_string)//&
2253 &
', regional output NOT supported with mask_variant', err_msg))
THEN
2254 DEALLOCATE(field_out)
2255 DEALLOCATE(oor_mask)
2262 IF (
PRESENT(mask) )
THEN
2263 IF ( missvalue_present )
THEN
2264 IF ( debug_diag_manager )
THEN
2265 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
2267 IF ( err_msg_local /=
'' )
THEN
2268 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
2269 DEALLOCATE(field_out)
2270 DEALLOCATE(oor_mask)
2275 IF( numthreads>1 .AND. phys_window )
then
2276 IF ( reduced_k_range )
THEN
2281 IF ( mask(i-is+1+hi, j-js+1+hj, k) )
THEN
2282 IF ( pow_value /= 1 )
THEN
2283 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2284 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2285 & (field_out(i-is+1+hi, j-js+1+hj, k) * weight1)**(pow_value)
2287 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2288 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2289 & field_out(i-is+1+hi, j-js+1+hj, k) * weight1
2291 output_fields(out_num)%counter(i-hi,j-hj,k1,sample) =&
2292 & output_fields(out_num)%counter(i-hi,j-hj,k1,sample) + weight1
2301 IF ( mask(i-is+1+hi, j-js+1+hj, k) )
THEN
2302 IF ( pow_value /= 1 )
THEN
2303 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2304 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2305 & (field_out(i-is+1+hi,j-js+1+hj,k)*weight1)**(pow_value)
2307 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2308 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2309 & field_out(i-is+1+hi,j-js+1+hj,k)*weight1
2311 output_fields(out_num)%counter(i-hi,j-hj,k,sample) =&
2312 &output_fields(out_num)%counter(i-hi,j-hj,k,sample) + weight1
2320 IF ( reduced_k_range )
THEN
2325 IF ( mask(i-is+1+hi, j-js+1+hj, k) )
THEN
2326 IF ( pow_value /= 1 )
THEN
2327 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2328 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2329 & (field_out(i-is+1+hi, j-js+1+hj, k) * weight1)**(pow_value)
2331 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2332 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2333 & field_out(i-is+1+hi, j-js+1+hj, k) * weight1
2335 output_fields(out_num)%counter(i-hi,j-hj,k1,sample) =&
2336 & output_fields(out_num)%counter(i-hi,j-hj,k1,sample) + weight1
2345 IF ( mask(i-is+1+hi, j-js+1+hj, k) )
THEN
2346 IF ( pow_value /= 1 )
THEN
2347 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2348 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2349 & (field_out(i-is+1+hi,j-js+1+hj,k)*weight1)**(pow_value)
2351 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2352 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2353 & field_out(i-is+1+hi,j-js+1+hj,k)*weight1
2355 output_fields(out_num)%counter(i-hi,j-hj,k,sample) =&
2356 &output_fields(out_num)%counter(i-hi,j-hj,k,sample) + weight1
2365 WRITE (error_string,
'(a,"/",a)')&
2366 & trim(input_fields(diag_field_id)%module_name), &
2367 & trim(output_fields(out_num)%output_name)
2368 IF(
fms_error_handler(
'diag_manager_mod::send_data_3d',
'module/output_field '//trim(error_string)//&
2369 &
', variable mask but no missing value defined', err_msg))
THEN
2370 DEALLOCATE(field_out)
2371 DEALLOCATE(oor_mask)
2376 WRITE (error_string,
'(a,"/",a)')&
2377 & trim(input_fields(diag_field_id)%module_name), &
2378 & trim(output_fields(out_num)%output_name)
2379 IF(
fms_error_handler(
'diag_manager_mod::send_data_3d',
'module/output_field '//trim(error_string)//&
2380 &
', variable mask but no mask given', err_msg))
THEN
2381 DEALLOCATE(field_out)
2382 DEALLOCATE(oor_mask)
2387 IF (
PRESENT(mask) )
THEN
2388 IF ( missvalue_present )
THEN
2389 IF ( need_compute )
THEN
2390 IF (numthreads>1 .AND. phys_window)
then
2391 DO k = l_start(3), l_end(3)
2395 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2396 & j <= l_end(2)+hj )
THEN
2397 i1 = i-l_start(1)-hi+1
2398 j1= j-l_start(2)-hj+1
2399 IF ( mask(i-is+1+hi, j-js+1+hj, k) )
THEN
2400 IF ( pow_value /= 1 )
THEN
2401 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2402 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2403 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2405 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2406 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2407 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2410 output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
2418 DO k = l_start(3), l_end(3)
2422 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2423 & j <= l_end(2)+hj )
THEN
2424 i1 = i-l_start(1)-hi+1
2425 j1= j-l_start(2)-hj+1
2426 IF ( mask(i-is+1+hi, j-js+1+hj, k) )
THEN
2427 IF ( pow_value /= 1 )
THEN
2428 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2429 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2430 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2432 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2433 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2434 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2437 output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
2448 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2449 & j <= l_end(2)+hj )
THEN
2450 output_fields(out_num)%num_elements(sample) = &
2451 output_fields(out_num)%num_elements(sample) + l_end(3) - l_start(3) + 1
2456 ELSE IF ( reduced_k_range )
THEN
2457 IF (numthreads>1 .AND. phys_window)
then
2462 IF ( mask(i-is+1+hi,j-js+1+hj,k) )
THEN
2463 IF ( pow_value /= 1 )
THEN
2464 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2465 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2466 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2468 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2469 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2470 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2473 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue
2484 IF ( mask(i-is+1+hi,j-js+1+hj,k) )
THEN
2485 IF ( pow_value /= 1 )
THEN
2486 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2487 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2488 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2490 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2491 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2492 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2495 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue
2503 IF ( debug_diag_manager )
THEN
2504 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
2506 IF ( err_msg_local /=
'' )
THEN
2507 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
2508 DEALLOCATE(field_out)
2509 DEALLOCATE(oor_mask)
2514 IF (numthreads>1 .AND. phys_window)
then
2518 IF ( mask(i-is+1+hi,j-js+1+hj,k) )
THEN
2519 IF ( pow_value /= 1 )
THEN
2520 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2521 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2522 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2524 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2525 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2526 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2529 output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue
2539 IF ( mask(i-is+1+hi,j-js+1+hj,k) )
THEN
2540 IF ( pow_value /= 1 )
THEN
2541 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2542 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2543 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2545 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2546 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2547 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2550 output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue
2559 IF ( need_compute .AND. .NOT.phys_window )
THEN
2560 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))) ) &
2561 & output_fields(out_num)%count_0d(sample) =&
2562 & output_fields(out_num)%count_0d(sample) + weight1
2564 IF ( any(mask(f1:f2,f3:f4,ks:ke)) ) output_fields(out_num)%count_0d(sample) =&
2565 & output_fields(out_num)%count_0d(sample)+weight1
2570 IF ( (.NOT.all(mask(f1:f2,f3:f4,ks:ke)) .AND.
mpp_pe() .EQ. mpp_root_pe()).AND.&
2571 & .NOT.input_fields(diag_field_id)%issued_mask_ignore_warning )
THEN
2576 CALL error_mesg(
'diag_manager_mod::send_data_3d',&
2577 &
'Mask will be ignored since missing values were not specified for field '//&
2578 & trim(input_fields(diag_field_id)%field_name)//
' in module '//&
2579 & trim(input_fields(diag_field_id)%module_name), warning)
2580 input_fields(diag_field_id)%issued_mask_ignore_warning = .true.
2582 IF ( need_compute )
THEN
2583 IF (numthreads>1 .AND. phys_window)
then
2586 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2587 & j <= l_end(2)+hj )
THEN
2588 i1 = i-l_start(1)-hi+1
2589 j1 = j-l_start(2)-hj+1
2590 IF ( pow_value /= 1 )
THEN
2591 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2592 & output_fields(out_num)%buffer(i1,j1,:,sample)+ &
2593 & (field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value)
2595 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2596 & output_fields(out_num)%buffer(i1,j1,:,sample)+ &
2597 & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
2606 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2607 & j <= l_end(2)+hj )
THEN
2608 i1 = i-l_start(1)-hi+1
2609 j1 = j-l_start(2)-hj+1
2610 IF ( pow_value /= 1 )
THEN
2611 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2612 & output_fields(out_num)%buffer(i1,j1,:,sample)+ &
2613 & (field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value)
2615 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2616 & output_fields(out_num)%buffer(i1,j1,:,sample)+ &
2617 & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
2627 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2628 & j <= l_end(2)+hj )
THEN
2629 output_fields(out_num)%num_elements(sample)=&
2630 & output_fields(out_num)%num_elements(sample)+l_end(3)-l_start(3)+1
2636 ELSE IF ( reduced_k_range )
THEN
2637 IF (numthreads>1 .AND. phys_window)
then
2640 IF ( pow_value /= 1 )
THEN
2641 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2642 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) +&
2643 & (field_out(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value)
2645 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2646 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) +&
2647 & field_out(f1:f2,f3:f4,ksr:ker)*weight1
2653 IF ( pow_value /= 1 )
THEN
2654 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2655 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) +&
2656 & (field_out(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value)
2658 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2659 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) +&
2660 & field_out(f1:f2,f3:f4,ksr:ker)*weight1
2665 IF ( debug_diag_manager )
THEN
2666 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
2668 IF ( err_msg_local /=
'')
THEN
2669 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
2670 DEALLOCATE(field_out)
2671 DEALLOCATE(oor_mask)
2676 IF (numthreads>1 .AND. phys_window)
then
2677 IF ( pow_value /= 1 )
THEN
2678 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
2679 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
2680 & (field_out(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value)
2682 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
2683 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
2684 & field_out(f1:f2,f3:f4,ks:ke)*weight1
2688 IF ( pow_value /= 1 )
THEN
2689 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
2690 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
2691 & (field_out(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value)
2693 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
2694 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
2695 & field_out(f1:f2,f3:f4,ks:ke)*weight1
2701 IF ( .NOT.phys_window ) output_fields(out_num)%count_0d(sample) =&
2702 & output_fields(out_num)%count_0d(sample) + weight1
2706 IF ( missvalue_present )
THEN
2707 IF ( need_compute )
THEN
2708 if( numthreads>1 .AND. phys_window )
then
2709 DO k = l_start(3), l_end(3)
2710 k1 = k - l_start(3) + 1
2713 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2714 & j <= l_end(2)+hj)
THEN
2715 i1 = i-l_start(1)-hi+1
2716 j1= j-l_start(2)-hj+1
2717 IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue )
THEN
2718 IF ( pow_value /= 1 )
THEN
2719 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2720 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2721 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2723 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2724 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2725 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2728 output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
2736 DO k = l_start(3), l_end(3)
2737 k1 = k - l_start(3) + 1
2740 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2741 & j <= l_end(2)+hj)
THEN
2742 i1 = i-l_start(1)-hi+1
2743 j1= j-l_start(2)-hj+1
2744 IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue )
THEN
2745 IF ( pow_value /= 1 )
THEN
2746 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2747 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2748 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2750 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2751 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2752 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2755 output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
2766 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2767 & j <= l_end(2)+hj)
THEN
2768 output_fields(out_num)%num_elements(sample) =&
2769 & output_fields(out_num)%num_elements(sample) + l_end(3) - l_start(3) + 1
2773 IF ( .NOT.phys_window )
THEN
2774 outer0:
DO k = l_start(3), l_end(3)
2775 DO j=l_start(2)+hj, l_end(2)+hj
2776 DO i=l_start(1)+hi, l_end(1)+hi
2777 IF ( field_out(i,j,k) /= missvalue )
THEN
2778 output_fields(out_num)%count_0d(sample) = output_fields(out_num)%count_0d(sample)&
2787 ELSE IF ( reduced_k_range )
THEN
2788 if( numthreads>1 .AND. phys_window )
then
2795 IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue )
THEN
2796 IF ( pow_value /= 1 )
THEN
2797 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2798 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2799 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2801 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2802 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2803 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2806 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) = missvalue
2819 IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue )
THEN
2820 IF ( pow_value /= 1 )
THEN
2821 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2822 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2823 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2825 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2826 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2827 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2830 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) = missvalue
2838 outer3:
DO k = ksr, ker
2842 IF ( field_out(i,j,k) /= missvalue )
THEN
2843 output_fields(out_num)%count_0d(sample) = output_fields(out_num)%count_0d(sample) &
2852 IF ( debug_diag_manager )
THEN
2853 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
2855 IF ( err_msg_local /=
'' )
THEN
2856 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
2857 DEALLOCATE(field_out)
2858 DEALLOCATE(oor_mask)
2863 IF( numthreads > 1 .AND. phys_window )
then
2867 IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue )
THEN
2868 IF ( pow_value /= 1 )
THEN
2869 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2870 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2871 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2873 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2874 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2875 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2878 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) = missvalue
2888 IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue )
THEN
2889 IF ( pow_value /= 1 )
THEN
2890 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2891 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2892 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2894 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2895 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2896 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2899 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) = missvalue
2910 IF ( field_out(i,j,k) /= missvalue )
THEN
2911 output_fields(out_num)%count_0d(sample) = output_fields(out_num)%count_0d(sample) &
2921 IF ( need_compute )
THEN
2922 IF( numthreads > 1 .AND. phys_window )
then
2925 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2926 & j <= l_end(2)+hj )
THEN
2927 i1 = i-l_start(1)-hi+1
2928 j1= j-l_start(2)-hj+1
2929 IF ( pow_value /= 1 )
THEN
2930 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2931 & output_fields(out_num)%buffer(i1,j1,:,sample) +&
2932 & (field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value)
2934 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2935 & output_fields(out_num)%buffer(i1,j1,:,sample) +&
2936 & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
2945 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2946 & j <= l_end(2)+hj )
THEN
2947 i1 = i-l_start(1)-hi+1
2948 j1= j-l_start(2)-hj+1
2949 IF ( pow_value /= 1 )
THEN
2950 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2951 & output_fields(out_num)%buffer(i1,j1,:,sample) +&
2952 & (field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value)
2954 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2955 & output_fields(out_num)%buffer(i1,j1,:,sample) +&
2956 & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
2967 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2968 & j <= l_end(2)+hj )
THEN
2969 output_fields(out_num)%num_elements(sample) =&
2970 & output_fields(out_num)%num_elements(sample)+l_end(3)-l_start(3)+1
2976 ELSE IF ( reduced_k_range )
THEN
2979 IF( numthreads > 1 .AND. phys_window )
then
2980 IF ( pow_value /= 1 )
THEN
2981 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2982 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
2983 & (field_out(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value)
2985 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2986 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
2987 & field_out(f1:f2,f3:f4,ksr:ker)*weight1
2991 IF ( pow_value /= 1 )
THEN
2992 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2993 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
2994 & (field_out(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value)
2996 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2997 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
2998 & field_out(f1:f2,f3:f4,ksr:ker)*weight1
3003 IF ( debug_diag_manager )
THEN
3004 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3006 IF ( err_msg_local /=
'' )
THEN
3007 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3008 DEALLOCATE(field_out)
3009 DEALLOCATE(oor_mask)
3014 IF( numthreads > 1 .AND. phys_window )
then
3015 IF ( pow_value /= 1 )
THEN
3016 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
3017 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
3018 & (field_out(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value)
3020 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
3021 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
3022 & field_out(f1:f2,f3:f4,ks:ke)*weight1
3026 IF ( pow_value /= 1 )
THEN
3027 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
3028 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
3029 & (field_out(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value)
3031 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
3032 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
3033 & field_out(f1:f2,f3:f4,ks:ke)*weight1
3039 IF ( .NOT.phys_window ) output_fields(out_num)%count_0d(sample) =&
3040 & output_fields(out_num)%count_0d(sample) + weight1
3046 IF ( .NOT.need_compute .AND. .NOT.reduced_k_range )&
3047 & output_fields(out_num)%num_elements(sample) =&
3048 & output_fields(out_num)%num_elements(sample) + (ie-is+1)*(je-js+1)*(ke-ks+1)
3049 IF ( reduced_k_range ) &
3050 & output_fields(out_num)%num_elements(sample) = output_fields(out_num)%num_elements(sample) +&
3051 & (ie-is+1)*(je-js+1)*(ker-ksr+1)
3054 ELSE IF ( time_max )
THEN
3055 IF (
PRESENT(mask) )
THEN
3056 IF ( need_compute )
THEN
3057 DO k = l_start(3), l_end(3)
3058 k1 = k - l_start(3) + 1
3061 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
3062 & j <= l_end(2)+hj )
THEN
3063 i1 = i-l_start(1)-hi+1
3064 j1= j-l_start(2)-hj+1
3065 IF ( mask(i-is+1+hi,j-js+1+hj,k) .AND. field_out(i-is+1+hi,j-js+1+hj,k)>&
3066 & output_fields(out_num)%buffer(i1,j1,k1,sample) )
THEN
3067 output_fields(out_num)%buffer(i1,j1,k1,sample) = field_out(i-is+1+hi,j-js+1+hj,k)
3074 ELSE IF ( reduced_k_range )
THEN
3077 WHERE ( mask(f1:f2,f3:f4,ksr:ker) .AND. field_out(f1:f2,f3:f4,ksr:ker) >&
3078 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) )&
3079 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker)
3081 IF ( debug_diag_manager )
THEN
3082 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3084 IF ( err_msg_local /=
'' )
THEN
3085 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3086 DEALLOCATE(field_out)
3087 DEALLOCATE(oor_mask)
3092 WHERE ( mask(f1:f2,f3:f4,ks:ke) .AND. field_out(f1:f2,f3:f4,ks:ke)>&
3093 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) )&
3094 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke)
3097 IF ( need_compute )
THEN
3098 DO k = l_start(3), l_end(3)
3099 k1 = k - l_start(3) + 1
3102 IF(l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
3103 & j <= l_end(2)+hj )
THEN
3104 i1 = i-l_start(1)-hi+1
3105 j1 = j-l_start(2)-hj+1
3106 IF ( field_out(i-is+1+hi,j-js+1+hj,k)>output_fields(out_num)%buffer(i1,j1,k1,sample) )
THEN
3107 output_fields(out_num)%buffer(i1,j1,k1,sample) = field_out(i-is+1+hi,j-js+1+hj,k)
3114 ELSE IF ( reduced_k_range )
THEN
3117 WHERE ( field_out(f1:f2,f3:f4,ksr:ker) >&
3118 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) ) &
3119 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker)
3121 IF ( debug_diag_manager )
THEN
3122 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3124 IF ( err_msg_local /=
'' )
THEN
3125 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3126 DEALLOCATE(field_out)
3127 DEALLOCATE(oor_mask)
3132 WHERE ( field_out(f1:f2,f3:f4,ks:ke) >&
3133 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) ) &
3134 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke)
3137 output_fields(out_num)%count_0d(sample) = 1
3138 ELSE IF ( time_min )
THEN
3139 IF (
PRESENT(mask) )
THEN
3140 IF ( need_compute )
THEN
3141 DO k = l_start(3), l_end(3)
3142 k1 = k - l_start(3) + 1
3145 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
3146 & j <= l_end(2)+hj )
THEN
3147 i1 = i-l_start(1)-hi+1
3148 j1 = j-l_start(2)-hj+1
3149 IF ( mask(i-is+1+hi,j-js+1+hj,k) .AND. field_out(i-is+1+hi,j-js+1+hj,k) <&
3150 & output_fields(out_num)%buffer(i1,j1,k1,sample) )
THEN
3151 output_fields(out_num)%buffer(i1,j1,k1,sample) = field_out(i-is+1+hi,j-js+1+hj,k)
3158 ELSE IF ( reduced_k_range )
THEN
3161 WHERE ( mask(f1:f2,f3:f4,ksr:ker) .AND. field_out(f1:f2,f3:f4,ksr:ker) <&
3162 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) ) &
3163 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker)
3165 IF ( debug_diag_manager )
THEN
3166 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3168 IF ( err_msg_local /=
'' )
THEN
3169 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3170 DEALLOCATE(field_out)
3171 DEALLOCATE(oor_mask)
3176 WHERE ( mask(f1:f2,f3:f4,ks:ke) .AND. field_out(f1:f2,f3:f4,ks:ke) <&
3177 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) ) &
3178 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke)
3181 IF ( need_compute )
THEN
3182 DO k = l_start(3), l_end(3)
3183 k1 = k - l_start(3) + 1
3186 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
3187 i1 = i-l_start(1)-hi+1
3188 j1= j-l_start(2)-hj+1
3189 IF ( field_out(i-is+1+hi,j-js+1+hj,k) <&
3190 & output_fields(out_num)%buffer(i1,j1,k1,sample) )
THEN
3191 output_fields(out_num)%buffer(i1,j1,k1,sample) = field_out(i-is+1+hi,j-js+1+hj,k)
3198 ELSE IF ( reduced_k_range )
THEN
3201 WHERE ( field_out(f1:f2,f3:f4,ksr:ker) <&
3202 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) ) &
3203 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker)
3205 IF ( debug_diag_manager )
THEN
3206 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3208 IF ( err_msg_local /=
'' )
THEN
3209 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3210 DEALLOCATE(field_out)
3211 DEALLOCATE(oor_mask)
3216 WHERE ( field_out(f1:f2,f3:f4,ks:ke) <&
3217 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) )&
3218 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke)
3221 output_fields(out_num)%count_0d(sample) = 1
3222 ELSE IF ( time_sum )
THEN
3223 IF (
PRESENT(mask) )
THEN
3224 IF ( need_compute )
THEN
3225 DO k = l_start(3), l_end(3)
3226 k1 = k - l_start(3) + 1
3229 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
3230 & j <= l_end(2)+hj )
THEN
3231 i1 = i-l_start(1)-hi+1
3232 j1 = j-l_start(2)-hj+1
3233 IF ( mask(i-is+1+hi,j-js+1+hj,k) )
THEN
3234 output_fields(out_num)%buffer(i1,j1,k1,sample) = &
3235 output_fields(out_num)%buffer(i1,j1,k1,sample) + &
3236 field_out(i-is+1+hi,j-js+1+hj,k)
3243 ELSE IF ( reduced_k_range )
THEN
3246 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = &
3247 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
3248 & field_out(f1:f2,f3:f4,ksr:ker)
3250 IF ( debug_diag_manager )
THEN
3251 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3253 IF ( err_msg_local /=
'' )
THEN
3254 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3255 DEALLOCATE(field_out)
3256 DEALLOCATE(oor_mask)
3261 WHERE ( mask(f1:f2,f3:f4,ks:ke) ) &
3262 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = &
3263 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) + &
3264 & field_out(f1:f2,f3:f4,ks:ke)
3267 IF ( need_compute )
THEN
3268 DO k = l_start(3), l_end(3)
3269 k1 = k - l_start(3) + 1
3272 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
3273 i1 = i-l_start(1)-hi+1
3274 j1= j-l_start(2)-hj+1
3275 output_fields(out_num)%buffer(i1,j1,k1,sample) = &
3276 & output_fields(out_num)%buffer(i1,j1,k1,sample) + &
3277 & field_out(i-is+1+hi,j-js+1+hj,k)
3282 ELSE IF ( reduced_k_range )
THEN
3285 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = &
3286 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
3287 & field_out(f1:f2,f3:f4,ksr:ker)
3289 IF ( debug_diag_manager )
THEN
3290 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3292 IF ( err_msg_local /=
'' )
THEN
3293 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3294 DEALLOCATE(field_out)
3295 DEALLOCATE(oor_mask)
3300 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = &
3301 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) + &
3302 & field_out(f1:f2,f3:f4,ks:ke)
3305 output_fields(out_num)%count_0d(sample) = 1
3307 output_fields(out_num)%count_0d(sample) = 1
3308 IF ( need_compute )
THEN
3311 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
3312 i1 = i-l_start(1)-hi+1
3313 j1 = j-l_start(2)-hj+1
3314 output_fields(out_num)%buffer(i1,j1,:,sample) =&
3315 & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))
3320 ELSE IF ( reduced_k_range )
THEN
3323 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker)
3325 IF ( debug_diag_manager )
THEN
3326 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3328 IF ( err_msg_local /=
'' )
THEN
3329 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3330 DEALLOCATE(field_out)
3331 DEALLOCATE(oor_mask)
3336 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke)
3339 IF (
PRESENT(mask) .AND. missvalue_present )
THEN
3340 IF ( need_compute )
THEN
3341 DO k = l_start(3), l_end(3)
3342 k1 = k - l_start(3) + 1
3345 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
3346 & j <= l_end(2)+hj )
THEN
3347 i1 = i-l_start(1)-hi+1
3348 j1 = j-l_start(2)-hj+1
3349 IF ( .NOT.mask(i-is+1+hi,j-js+1+hj,k) )&
3350 & output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
3355 ELSE IF ( reduced_k_range )
THEN
3362 IF ( .NOT.mask(i-is+1+hi,j-js+1+hj,k) ) &
3363 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue
3371 IF ( .NOT.mask(i-is+1+hi,j-js+1+hj,k) )&
3372 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue
3380 IF ( output_fields(out_num)%static .AND. .NOT.need_compute .AND. debug_diag_manager )
THEN
3382 IF ( err_msg_local /=
'' )
THEN
3383 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg))
THEN
3384 DEALLOCATE(field_out)
3385 DEALLOCATE(oor_mask)
3394 IF (
PRESENT(rmask) .AND. missvalue_present )
THEN
3395 IF ( need_compute )
THEN
3397 TYPE IS (real(kind=r4_kind))
3398 DO k = l_start(3), l_end(3)
3399 k1 = k - l_start(3) + 1
3402 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND.&
3403 & j <= l_end(2)+hj )
THEN
3404 i1 = i-l_start(1)-hi+1
3405 j1 = j-l_start(2)-hj+1
3406 IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r4_kind ) &
3407 & output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
3412 TYPE IS (real(kind=r8_kind))
3413 DO k = l_start(3), l_end(3)
3414 k1 = k - l_start(3) + 1
3417 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND.&
3418 & j <= l_end(2)+hj )
THEN
3419 i1 = i-l_start(1)-hi+1
3420 j1 = j-l_start(2)-hj+1
3421 IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r8_kind ) &
3422 & output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
3428 CALL error_mesg (
'diag_manager_mod::send_data_3d',&
3429 &
'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
3431 ELSE IF ( reduced_k_range )
THEN
3435 TYPE IS (real(kind=r4_kind))
3440 IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r4_kind ) &
3441 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue
3445 TYPE IS (real(kind=r8_kind))
3450 IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r8_kind ) &
3451 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue
3456 CALL error_mesg (
'diag_manager_mod::send_data_3d',&
3457 &
'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
3461 TYPE IS (real(kind=r4_kind))
3465 IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r4_kind ) &
3466 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue
3470 TYPE IS (real(kind=r8_kind))
3474 IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r8_kind ) &
3475 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue
3480 CALL error_mesg (
'diag_manager_mod::send_data_3d',&
3481 &
'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
3486 END DO num_out_fields
3488 DEALLOCATE(field_out)
3489 DEALLOCATE(oor_mask)
3495 LOGICAL FUNCTION send_data_4d(diag_field_id, field, time, is_in, js_in, ks_in, &
3496 & mask, rmask, ie_in, je_in, ke_in, weight, err_msg)
3497 INTEGER,
INTENT(in) :: diag_field_id
3498 CLASS(*),
INTENT(in) :: field(:,:,:,:)
3499 CLASS(*),
INTENT(in),
OPTIONAL :: weight
3500 TYPE (
time_type),
INTENT(in),
OPTIONAL :: time
3501 INTEGER,
INTENT(in),
OPTIONAL :: is_in
3502 INTEGER,
INTENT(in),
OPTIONAL :: js_in
3503 INTEGER,
INTENT(in),
OPTIONAL :: ks_in
3504 INTEGER,
INTENT(in),
OPTIONAL :: ie_in
3505 INTEGER,
INTENT(in),
OPTIONAL :: je_in
3506 INTEGER,
INTENT(in),
OPTIONAL :: ke_in
3507 LOGICAL,
INTENT(in),
OPTIONAL :: mask(:,:,:,:)
3508 CLASS(*),
INTENT(in),
OPTIONAL :: rmask(:,:,:,:)
3509 CHARACTER(len=*),
INTENT(out),
OPTIONAL :: err_msg
3512 class(*),
allocatable :: rmask_local(:,:,:,:)
3513 logical,
allocatable :: mask_local(:,:,:,:)
3516 IF ( diag_field_id <= 0 )
THEN
3521 if (.not. use_modern_diag) &
3522 call mpp_error(fatal,
"Send_data_4d is only supported when diag_manager_nml::use_modern_diag=.true.")
3525 if (
present(mask)) mask_local = mask
3526 if (
present(rmask)) rmask_local = rmask
3528 call fms_diag_object%fms_diag_accept_data(diag_field_id, field, mask_local, rmask_local, &
3529 time, is_in, js_in, ks_in, ie_in, je_in, ke_in, weight, &
3533 if (
present(err_msg))
then
3534 if (err_msg .ne.
"")
then
3541 if (
allocated(rmask_local))
deallocate(rmask_local)
3542 if (
allocated(mask_local))
deallocate(mask_local)
3547 INTEGER,
INTENT(in) :: id
3548 REAL,
INTENT(in) :: field(:,:)
3549 REAL,
INTENT(in) :: area (:,:)
3551 LOGICAL,
INTENT(in),
OPTIONAL :: mask (:,:)
3553 REAL,
DIMENSION(SIZE(field,1)) :: out(size(field,1))
3567 INTEGER,
INTENT(in) :: diag_field_id
3568 REAL,
DIMENSION(:,:),
INTENT(in) :: x
3569 REAL,
DIMENSION(:,:),
INTENT(in) :: area
3570 LOGICAL,
DIMENSION(:,:),
INTENT(in) :: mask
3571 REAL,
DIMENSION(:),
INTENT(out) :: out
3574 REAL,
DIMENSION(SIZE(x,1)) :: s
3575 REAL :: local_missing_value
3579 IF ( diag_field_id <= 0 )
THEN
3583 CALL error_mesg(
'diag_manager_mod::average_tiles1d',&
3584 &
"diag_field_id less than 0. Contact developers.", fatal)
3588 IF ( input_fields(diag_field_id)%missing_value_present )
THEN
3589 local_missing_value = input_fields(diag_field_id)%missing_value
3591 local_missing_value = 0.0
3598 DO it = 1,
SIZE(area,dim=2)
3599 WHERE ( mask(:,it) )
3600 out(:) = out(:) + x(:,it)*area(:,it)
3601 s(:) = s(:) + area(:,it)
3606 out(:) = out(:)/s(:)
3608 out(:) = local_missing_value
3614 INTEGER,
INTENT(in) :: id
3615 REAL,
INTENT(in) :: field(:,:,:)
3616 REAL,
INTENT(in) :: area (:,:,:)
3618 LOGICAL,
INTENT(in),
OPTIONAL :: mask (:,:,:)
3620 REAL,
DIMENSION(SIZE(field,1),SIZE(field,2)) :: out(size(field,1), size(field,2))
3634 INTEGER,
INTENT(in) :: id
3635 REAL,
DIMENSION(:,:,:,:),
INTENT(in) :: field
3636 REAL,
DIMENSION(:,:,:),
INTENT(in) :: area (:,:,:)
3639 LOGICAL,
DIMENSION(:,:,:),
INTENT(in),
OPTIONAL :: mask
3641 REAL,
DIMENSION(SIZE(field,1),SIZE(field,2),SIZE(field,4)) :: out
3642 LOGICAL,
DIMENSION(SIZE(field,1),SIZE(field,2),SIZE(field,4)) :: mask3
3651 DO it=1,
SIZE(field,4)
3652 CALL average_tiles(id, field(:,:,:,it), area, mask, out(:,:,it) )
3655 mask3(:,:,1) = any(mask,dim=3)
3656 DO it = 2,
SIZE(field,4)
3657 mask3(:,:,it) = mask3(:,:,1)
3665 INTEGER,
INTENT(in) :: diag_field_id
3666 REAL,
DIMENSION(:,:,:),
INTENT(in) :: x
3667 REAL,
DIMENSION(:,:,:),
INTENT(in) :: area
3668 LOGICAL,
DIMENSION(:,:,:),
INTENT(in) :: mask
3669 REAL,
DIMENSION(:,:),
INTENT(out) :: out
3672 REAL,
DIMENSION(SIZE(x,1),SIZE(x,2)) :: s
3673 REAL :: local_missing_value
3677 IF ( diag_field_id <= 0 )
THEN
3681 CALL error_mesg(
'diag_manager_mod::average_tiles',&
3682 &
"diag_field_id less than 0. Contact developers.", fatal)
3686 IF ( input_fields(diag_field_id)%missing_value_present )
THEN
3687 local_missing_value = input_fields(diag_field_id)%missing_value
3689 local_missing_value = 0.0
3696 DO it = 1,
SIZE(area,3)
3697 WHERE ( mask(:,:,it) )
3698 out(:,:) = out(:,:) + x(:,:,it)*area(:,:,it)
3699 s(:,:) = s(:,:) + area(:,:,it)
3703 WHERE ( s(:,:) > 0 )
3704 out(:,:) = out(:,:)/s(:,:)
3706 out(:,:) = local_missing_value
3712 INTEGER,
INTENT(in) :: out_num
3713 LOGICAL,
INTENT(in) :: at_diag_end
3714 CHARACTER(len=*),
INTENT(out) :: error_string
3719 LOGICAL :: time_max, time_min, reduced_k_range, missvalue_present
3720 LOGICAL :: average, time_rms, need_compute, phys_window
3721 INTEGER :: in_num, file_num, freq, units
3722 INTEGER :: b1,b2,b3,b4
3723 INTEGER :: i, j, k, m
3724 REAL :: missvalue, num
3727 need_compute = output_fields(out_num)%need_compute
3729 in_num = output_fields(out_num)%input_field
3730 IF ( input_fields(in_num)%static )
RETURN
3732 missvalue = input_fields(in_num)%missing_value
3733 missvalue_present = input_fields(in_num)%missing_value_present
3734 reduced_k_range = output_fields(out_num)%reduced_k_range
3735 phys_window = output_fields(out_num)%phys_window
3737 average = output_fields(out_num)%time_average
3740 time_rms = output_fields(out_num)%time_rms
3742 time_max = output_fields(out_num)%time_max
3743 time_min = output_fields(out_num)%time_min
3744 file_num = output_fields(out_num)%output_file
3745 freq = files(file_num)%output_freq
3746 units = files(file_num)%output_units
3750 b1=
SIZE(output_fields(out_num)%buffer,1)
3751 b2=
SIZE(output_fields(out_num)%buffer,2)
3752 b3=
SIZE(output_fields(out_num)%buffer,3)
3753 b4=
SIZE(output_fields(out_num)%buffer,4)
3754 IF ( input_fields(in_num)%mask_variant )
THEN
3759 IF ( output_fields(out_num)%counter(i,j,k,m) > 0. )
THEN
3760 output_fields(out_num)%buffer(i,j,k,m) = &
3761 & output_fields(out_num)%buffer(i,j,k,m)/output_fields(out_num)%counter(i,j,k,m)
3762 IF ( time_rms ) output_fields(out_num)%buffer(i,j,k,m) = &
3763 sqrt(output_fields(out_num)%buffer(i,j,k,m))
3765 output_fields(out_num)%buffer(i,j,k,m) = missvalue
3773 IF ( phys_window )
THEN
3774 IF ( need_compute .OR. reduced_k_range )
THEN
3775 num = real(output_fields(out_num)%num_elements(m)/output_fields(out_num)%region_elements)
3777 num = real(output_fields(out_num)%num_elements(m)/output_fields(out_num)%total_elements)
3780 num = output_fields(out_num)%count_0d(m)
3782 IF ( num > 0. )
THEN
3783 IF ( missvalue_present )
THEN
3787 IF ( output_fields(out_num)%buffer(i,j,k,m) /= missvalue )
THEN
3788 output_fields(out_num)%buffer(i,j,k,m) = output_fields(out_num)%buffer(i,j,k,m)/num
3789 IF ( time_rms ) output_fields(out_num)%buffer(i,j,k,m) =&
3790 & sqrt(output_fields(out_num)%buffer(i,j,k,m))
3796 output_fields(out_num)%buffer(:,:,:,m) = output_fields(out_num)%buffer(:,:,:,m)/num
3797 IF ( time_rms ) output_fields(out_num)%buffer(:,:,:,m) =&
3798 & sqrt(output_fields(out_num)%buffer(:,:,:,m))
3800 ELSE IF ( .NOT. at_diag_end )
THEN
3801 IF ( missvalue_present )
THEN
3802 IF(any(output_fields(out_num)%buffer /= missvalue))
THEN
3803 WRITE (error_string,
'(a,"/",a)')&
3804 & trim(input_fields(in_num)%module_name), &
3805 & trim(output_fields(out_num)%output_name)
3813 ELSE IF ( time_min .OR. time_max )
THEN
3814 IF ( missvalue_present )
THEN
3815 WHERE ( abs(output_fields(out_num)%buffer) == min_value )
3816 output_fields(out_num)%buffer = missvalue
3822 IF ( at_diag_end .AND. freq == end_of_run ) output_fields(out_num)%next_output = time
3824 IF ( (output_fields(out_num)%time_ops) .AND. (.NOT. mix_snapshot_average_fields) )
THEN
3825 middle_time = (output_fields(out_num)%last_output+output_fields(out_num)%next_output)/2
3826 if (trim(files(file_num)%filename_time_bounds) ==
"begin")
then
3827 filename_time = output_fields(out_num)%last_output
3828 elseif (trim(files(file_num)%filename_time_bounds) ==
"middle")
then
3829 filename_time = middle_time
3830 elseif (trim(files(file_num)%filename_time_bounds) ==
"end")
then
3831 filename_time = output_fields(out_num)%next_output
3834 CALL diag_data_out(file_num, out_num, output_fields(out_num)%buffer, middle_time, &
3835 & filename_time=filename_time)
3838 & output_fields(out_num)%buffer, output_fields(out_num)%next_output)
3842 IF ( at_diag_end )
RETURN
3845 output_fields(out_num)%last_output = output_fields(out_num)%next_output
3846 IF ( freq == end_of_run )
THEN
3847 output_fields(out_num)%next_output = time
3849 IF ( freq == every_time )
THEN
3850 output_fields(out_num)%next_output = time
3852 output_fields(out_num)%next_output = output_fields(out_num)%next_next_output
3853 output_fields(out_num)%next_next_output = &
3854 & diag_time_inc(output_fields(out_num)%next_next_output, freq, units)
3856 output_fields(out_num)%count_0d(:) = 0.0
3857 output_fields(out_num)%num_elements(:) = 0
3858 IF ( time_max )
THEN
3859 output_fields(out_num)%buffer = max_value
3860 ELSE IF ( time_min )
THEN
3861 output_fields(out_num)%buffer = min_value
3863 output_fields(out_num)%buffer = empty
3865 IF ( input_fields(in_num)%mask_variant .AND. average ) output_fields(out_num)%counter = 0.0
3869 SUBROUTINE diag_manager_set_time_end(Time_end_in)
3870 TYPE (
time_type),
INTENT(in) :: time_end_in
3872 time_end = time_end_in
3873 if (use_modern_diag)
then
3874 call fms_diag_object%set_time_end(time_end_in)
3877 END SUBROUTINE diag_manager_set_time_end
3892 integer :: file, j, freq, in_num, file_num, out_num
3894 DO file = 1, num_files
3895 freq = files(file)%output_freq
3897 DO j = 1, files(file)%num_fields
3898 out_num = files(file)%fields(j)
3899 in_num = output_fields(out_num)%input_field
3900 IF ( (input_fields(in_num)%numthreads == 1) .AND.&
3901 & (input_fields(in_num)%active_omp_level.LE.1) ) cycle
3902 file_num = output_fields(out_num)%output_file
3904 & output_fields(out_num)%buffer, time)
3913 TYPE (
time_type),
INTENT(in) :: time_step
3914 character(len=*),
INTENT(out),
optional :: err_msg
3917 integer :: file, j, out_num, in_num, freq, status
3918 logical :: local_output, need_compute
3919 CHARACTER(len=128) :: error_string
3921 IF ( time_end == time_zero )
THEN
3925 CALL error_mesg(
'diag_manager_mod::diag_send_complete',&
3926 &
"diag_manager_set_time_end must be called before diag_send_complete", fatal)
3929 if (use_modern_diag)
then
3930 call fms_diag_object%fms_diag_send_complete(time_step)
3934 DO file = 1, num_files
3935 freq = files(file)%output_freq
3936 DO j = 1, files(file)%num_fields
3937 out_num = files(file)%fields(j)
3938 in_num = output_fields(out_num)%input_field
3940 IF ( (input_fields(in_num)%numthreads == 1) .AND. (input_fields(in_num)%active_omp_level.LE.1) ) cycle
3941 IF ( output_fields(out_num)%static .OR. freq == end_of_run ) cycle
3942 time = input_fields(in_num)%time
3943 IF ( time >= time_end ) cycle
3946 local_output = output_fields(out_num)%local_output
3948 need_compute = output_fields(out_num)%need_compute
3950 IF ( local_output .AND. (.NOT.need_compute) ) cycle
3951 next_time = time + time_step
3953 IF ( next_time > output_fields(out_num)%next_output )
THEN
3955 IF ( next_time > output_fields(out_num)%next_next_output .AND. freq > 0 )
THEN
3956 IF (
mpp_pe() .EQ. mpp_root_pe() )
THEN
3957 WRITE (error_string,
'(a,"/",a)')&
3958 & trim(input_fields(in_num)%module_name), &
3959 & trim(output_fields(out_num)%output_name)
3961 &
'module/output_field '//trim(error_string)//&
3962 &
' is skipped one time level in output data', err_msg))
RETURN
3966 status =
writing_field(out_num, .false., error_string, next_time)
3967 IF ( status == -1 )
THEN
3968 IF (
mpp_pe() .EQ. mpp_root_pe() )
THEN
3969 IF(
fms_error_handler(
'diag_manager_mod::diag_send_complete',
'module/output_field '//&
3970 & trim(error_string)//
', write EMPTY buffer', err_msg))
RETURN
3986 IF ( do_diag_field_log )
THEN
3987 close (diag_log_unit)
3989 DO file = 1, num_files
3992 if (
allocated(fileobju))
deallocate(fileobju)
3993 if (
allocated(fileobj))
deallocate(fileobj)
3994 if (
allocated(fileobjnd))
deallocate(fileobjnd)
3997 if (use_modern_diag)
then
3998 call fms_diag_object%diag_end(time)
4004 INTEGER,
INTENT(in) :: file
4007 INTEGER :: j, i, input_num, freq, status
4008 INTEGER :: stdout_unit
4009 LOGICAL :: reduced_k_range, need_compute, local_output
4010 CHARACTER(len=128) :: message
4015 DO j = 1, files(file)%num_fields
4016 i = files(file)%fields(j)
4019 local_output = output_fields(i)%local_output
4021 need_compute = output_fields(i)%need_compute
4023 reduced_k_range = output_fields(i)%reduced_k_range
4026 IF ( local_output .AND. (.NOT. need_compute) ) cycle
4028 input_num = output_fields(i)%input_field
4029 IF ( input_fields(input_num)%static ) cycle
4030 IF ( .NOT.input_fields(input_num)%register ) cycle
4031 freq = files(file)%output_freq
4032 IF ( freq /= end_of_run .AND. files(file)%file_unit < 0 &
4033 & .AND. all(output_fields(i)%num_elements(:) == 0)&
4034 & .AND. all(output_fields(i)%count_0d(:) == 0) ) cycle
4037 IF ( time >= output_fields(i)%next_output .OR. freq == end_of_run )
THEN
4038 IF ( time >= output_fields(i)%next_next_output .AND. freq > 0 )
THEN
4039 WRITE (message,
'(a,"/",a)') trim(input_fields(input_num)%module_name), &
4040 & trim(output_fields(i)%output_name)
4045 IF (
mpp_pe() .EQ. mpp_root_pe() ) &
4046 &
CALL error_mesg(
'diag_manager_mod::closing_file',
'module/output_field ' //&
4047 & trim(message)//
', skip one time level, maybe send_data never called', warning)
4052 ELSEIF ( .NOT.output_fields(i)%written_once )
THEN
4057 CALL error_mesg(
'Potential error in diag_manager_end ',&
4058 & trim(output_fields(i)%output_name)//
' NOT available,'//&
4059 &
' check if output interval > runlength. Netcdf fill_values are written', note)
4060 output_fields(i)%buffer = fill_value
4061 CALL diag_data_out(file, i, output_fields(i)%buffer, time, .true.)
4068 IF ( write_bytes_in_file )
THEN
4069 CALL mpp_sum (files(file)%bytes_written)
4070 IF (
mpp_pe() == mpp_root_pe() )&
4071 &
WRITE (stdout_unit,
'(a,i12,a,a)')
'Diag_Manager: ',files(file)%bytes_written, &
4072 &
' bytes of data written to file ',trim(files(file)%name)
4079 INTEGER,
OPTIONAL,
INTENT(IN) :: diag_model_subset
4080 INTEGER,
DIMENSION(6),
OPTIONAL,
INTENT(IN) :: time_init
4081 CHARACTER(len=*),
INTENT(out),
OPTIONAL :: err_msg
4083 CHARACTER(len=*),
PARAMETER :: sep =
'|'
4085 INTEGER,
PARAMETER :: fltkind = r4_kind
4086 INTEGER,
PARAMETER :: dblkind = r8_kind
4087 INTEGER :: diag_subset_output
4089 INTEGER,
ALLOCATABLE,
DIMENSION(:) :: pelist
4090 INTEGER :: stdlog_unit, stdout_unit
4092 CHARACTER(len=256) :: err_msg_local
4094 namelist /diag_manager_nml/ append_pelist_name, mix_snapshot_average_fields, max_output_fields, &
4095 & max_input_fields, max_axes, do_diag_field_log, write_bytes_in_file, debug_diag_manager,&
4096 & max_num_axis_sets, max_files, use_cmor, issue_oor_warnings,&
4097 & oor_warnings_fatal, max_out_per_in_field, flush_nc_files, region_out_use_alt_value, max_field_attributes,&
4098 & max_file_attributes, max_axis_attributes, prepend_date, use_modern_diag, use_clock_average, &
4102 IF ( module_is_initialized )
RETURN
4105 IF (
PRESENT(err_msg) ) err_msg =
''
4110 call diag_data_init()
4113 pack_size =
SIZE(transfer(0.0_dblkind, (/0.0, 0.0, 0.0, 0.0/)))
4114 IF (pack_size .EQ. 1)
then
4115 pack_size_str =
"double"
4116 else if (pack_size .EQ. 2)
then
4117 pack_size_str =
"float"
4119 IF (
fms_error_handler(
'diag_manager_mod::diag_manager_init',
'unknown pack_size. Must be 1, or 2.', &
4124 min_value = huge(0.0_fltkind)
4125 max_value = -min_value
4136 time_end = time_zero
4137 diag_subset_output = diag_all
4138 IF (
PRESENT(diag_model_subset) )
THEN
4139 IF ( diag_model_subset >= diag_other .AND. diag_model_subset <= diag_all )
THEN
4140 diag_subset_output = diag_model_subset
4142 IF (
fms_error_handler(
'diag_manager_mod::diag_manager_init',
'invalid value of diag_model_subset', &
4147 READ (input_nml_file, nml=diag_manager_nml, iostat=mystat)
4150 IF (
check_nml_error(iostat=mystat, nml_name=
'DIAG_MANAGER_NML') < 0 )
THEN
4151 IF (
mpp_pe() == mpp_root_pe() )
THEN
4152 CALL error_mesg(
'diag_manager_mod::diag_manager_init', &
4153 &
'DIAG_MANAGER_NML not found in input nml file. Using defaults.', warning)
4157 IF (.not. use_modern_diag .and. use_clock_average) &
4158 call mpp_error(fatal,
"diag_manager_mod: You cannot set use_modern_diag=.false. and &
4159 & use_clock_average=.true. in diag_manager_nml")
4161 IF (
mpp_pe() == mpp_root_pe() )
THEN
4162 WRITE (stdlog_unit, diag_manager_nml)
4166 IF ( use_cmor )
THEN
4168 WRITE (err_msg_local,
'(ES8.1E2)') cmor_missing_value
4169 CALL error_mesg(
'diag_manager_mod::diag_manager_init',
'Using CMOR missing value ('//trim(err_msg_local)// &
4174 IF ( oor_warnings_fatal )
THEN
4176 CALL error_mesg(
'diag_manager_mod::diag_manager_init',
'Out &
4177 &of Range warnings are fatal.', note)
4178 ELSEIF ( .NOT.issue_oor_warnings )
THEN
4179 CALL error_mesg(
'diag_manager_mod::diag_manager_init',
'Out &
4180 &of Range warnings will be ignored.', note)
4183 IF ( mix_snapshot_average_fields )
THEN
4184 IF ( .not. use_modern_diag )
THEN
4185 CALL error_mesg(
'diag_manager_mod::diag_manager_init',
'Setting diag_manager_nml variable '//&
4186 &
'mix_snapshot_average_fields = .TRUE. will cause ERRORS in the time coordinates '//&
4187 &
'of all time averaged fields. Strongly recommend setting mix_snapshot_average_fields '//&
4188 &
'= .FALSE.', note)
4190 CALL error_mesg(
'diag_manager_mod::diag_manager_init',
'mix_snapshot_average_fields = .TRUE. is not '//&
4191 &
'supported if use_modern_diag = .TRUE. Please set mix_snapshot_average_fields '//&
4192 &
'to .FALSE. and put instantaneous and averaged fields in separate files!', fatal)
4195 ALLOCATE(output_fields(max_output_fields))
4196 ALLOCATE(input_fields(max_input_fields))
4197 DO j = 1, max_input_fields
4198 ALLOCATE(input_fields(j)%output_fields(max_out_per_in_field))
4201 ALLOCATE(files(max_files))
4202 ALLOCATE(fileobju(max_files))
4203 ALLOCATE(fileobj(max_files))
4204 ALLOCATE(fileobjnd(max_files))
4212 IF (
PRESENT(time_init) )
THEN
4213 diag_init_time =
set_date(time_init(1), time_init(2), time_init(3), time_init(4),&
4214 & time_init(5), time_init(6))
4216 diag_init_time = get_base_time()
4217 IF ( prepend_date .EQV. .true. )
THEN
4218 CALL error_mesg(
'diag_manager_mod::diag_manager_init',&
4219 &
'prepend_date only supported when diag_manager_init is called with time_init present.', note)
4220 prepend_date = .false.
4224 if (use_modern_diag)
then
4225 CALL error_mesg(
'diag_manager_mod::diag_manager_init',&
4226 &
'You are using the yaml version of the diag table', note)
4227 CALL fms_diag_object%init(diag_subset_output, time_init)
4229 if (.not. use_modern_diag)
then
4230 CALL error_mesg(
'diag_manager_mod::diag_manager_init',&
4231 &
'You are using the legacy version of the diag table', note)
4232 CALL parse_diag_table(diag_subset=diag_subset_output, istat=mystat, err_msg=err_msg_local)
4233 IF ( mystat /= 0 )
THEN
4235 &
'Error parsing diag_table. '//trim(err_msg_local), err_msg) )
RETURN
4239 files(:)%bytes_written = 0
4242 IF ( do_diag_field_log.AND.
mpp_pe().EQ.mpp_root_pe() )
THEN
4243 open(newunit=diag_log_unit, file=
'diag_field_log.out.'//
string(
mpp_pe()), action=
'WRITE')
4244 WRITE (diag_log_unit,
'(777a)') &
4252 module_is_initialized = .true.
4254 if(.not. use_modern_diag) null_axis_id = diag_axis_init(
'scalar_axis', (/0./),
'none',
'N',
'none')
4261 INTEGER,
INTENT(out) :: year, month, day, hour, minute, second
4264 IF (.NOT.module_is_initialized)
CALL error_mesg (
'diag_manager_mod::get_base_date', &
4265 &
'module has not been initialized', fatal)
4266 year = get_base_year()
4267 month = get_base_month()
4268 day = get_base_day()
4269 hour = get_base_hour()
4270 minute = get_base_minute()
4271 second = get_base_second()
4281 TYPE(
time_type),
INTENT(in) :: next_model_time
4282 INTEGER,
INTENT(in) :: diag_field_id
4284 INTEGER :: i, out_num
4287 IF ( diag_field_id < 0 )
RETURN
4288 DO i = 1, input_fields(diag_field_id)%num_output_fields
4290 out_num = input_fields(diag_field_id)%output_fields(i)
4291 IF ( .NOT.output_fields(out_num)%static )
THEN
4292 IF ( next_model_time > output_fields(out_num)%next_output )
need_data=.true.
4296 IF ( output_fields(out_num)%time_average)
need_data = .true.
4308 INTEGER,
INTENT(in) :: n_samples
4310 REAL :: center_data (n_samples)
4311 REAL :: edges (n_samples+1)
4320 CHARACTER(32) :: name
4321 CHARACTER(128) :: units
4324 WRITE (units,11)
'hours', year, month, day, hour, minute, second
4325 11
FORMAT(a,
' since ',i4.4,
'-',i2.2,
'-',i2.2,
' ',i2.2,
':',i2.2,
':',i2.2)
4329 center_data(i) = 24.0*(real(i)-0.5)/n_samples
4330 edges(i+1) = 24.0* real(i)/n_samples
4335 WRITE (name,
'(a,i2.2)')
'time_of_day_edges_', n_samples
4336 edges_id = get_axis_num(name,
'diurnal')
4337 IF ( edges_id <= 0 )
THEN
4338 edges_id = diag_axis_init(name,edges,units,
'N',
'time of day edges', set_name=
'diurnal')
4343 WRITE (name,
'(a,i2.2)')
'time_of_day_', n_samples
4346 init_diurnal_axis = diag_axis_init(name, center_data, units,
'N',
'time of day', &
4347 set_name=
'diurnal', edges=edges_id)
4352 INTEGER,
INTENT(in) :: diag_field_id
4353 CHARACTER(len=*),
INTENT(in) :: name
4354 INTEGER,
INTENT(in) ::
type
4355 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: cval
4356 INTEGER,
DIMENSION(:),
INTENT(in),
OPTIONAL :: ival
4357 REAL,
DIMENSION(:),
INTENT(in),
OPTIONAL :: rval
4359 INTEGER :: istat, length, i, j, this_attribute, out_field
4361 IF ( .NOT.first_send_data_call )
THEN
4367 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',
'Attempting to add attribute "'&
4368 &//trim(name)//
'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//
'/'&
4369 &//trim(input_fields(diag_field_id)%field_name)//
'" after first send_data call. Too late.', fatal)
4373 IF ( diag_field_id .LE. 0 )
THEN
4376 DO j=1,input_fields(diag_field_id)%num_output_fields
4377 out_field = input_fields(diag_field_id)%output_fields(j)
4384 DO i=1, output_fields(out_field)%num_attributes
4385 IF ( trim(output_fields(out_field)%attributes(i)%name) .EQ. trim(name) )
THEN
4391 IF ( this_attribute.NE.0 .AND. (type.EQ.nf90_int .OR. type.EQ.nf90_float) )
THEN
4396 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',&
4397 &
'Attribute "'//trim(name)//
'" already defined for module/input_field "'&
4398 &//trim(input_fields(diag_field_id)%module_name)//
'/'&
4399 &//trim(input_fields(diag_field_id)%field_name)//
'". Contact the developers.', fatal)
4400 ELSE IF ( this_attribute.NE.0 .AND. type.EQ.nf90_char .AND. debug_diag_manager )
THEN
4405 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',&
4406 &
'Attribute "'//trim(name)//
'" already defined for module/input_field "'&
4407 &//trim(input_fields(diag_field_id)%module_name)//
'/'&
4408 &//trim(input_fields(diag_field_id)%field_name)//
'". Prepending.', note)
4409 ELSE IF ( this_attribute.EQ.0 )
THEN
4412 this_attribute = output_fields(out_field)%num_attributes + 1
4414 IF ( this_attribute .GT. max_field_attributes )
THEN
4420 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',&
4421 &
'Number of attributes exceeds max_field_attributes for attribute "'&
4422 &//trim(name)//
'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//
'/'&
4423 &//trim(input_fields(diag_field_id)%field_name)&
4424 &//
'". Increase diag_manager_nml:max_field_attributes.', fatal)
4426 output_fields(out_field)%num_attributes = this_attribute
4428 output_fields(out_field)%attributes(this_attribute)%name = name
4429 output_fields(out_field)%attributes(this_attribute)%type =
type
4431 output_fields(out_field)%attributes(this_attribute)%catt =
''
4437 IF ( .NOT.
PRESENT(ival) )
THEN
4443 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',&
4444 &
'Attribute type claims INTEGER, but ival not present for attribute "'&
4445 &//trim(name)//
'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//
'/'&
4446 &//trim(input_fields(diag_field_id)%field_name)//
'". Contact then developers.', fatal)
4450 ALLOCATE(output_fields(out_field)%attributes(this_attribute)%iatt(length), stat=istat)
4451 IF ( istat.NE.0 )
THEN
4455 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',
'Unable to allocate iatt for attribute "'&
4456 &//trim(name)//
'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//
'/'&
4457 &//trim(input_fields(diag_field_id)%field_name)//
'"', fatal)
4460 output_fields(out_field)%attributes(this_attribute)%len = length
4461 output_fields(out_field)%attributes(this_attribute)%iatt = ival
4463 IF ( .NOT.
PRESENT(rval) )
THEN
4469 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',&
4470 &
'Attribute type claims REAL, but rval not present for attribute "'&
4471 &//trim(name)//
'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//
'/'&
4472 &//trim(input_fields(diag_field_id)%field_name)//
'". Contact the developers.', fatal)
4476 ALLOCATE(output_fields(out_field)%attributes(this_attribute)%fatt(length), stat=istat)
4477 IF ( istat.NE.0 )
THEN
4481 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',
'Unable to allocate fatt for attribute "'&
4482 &//trim(name)//
'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//
'/'&
4483 &//trim(input_fields(diag_field_id)%field_name)//
'"', fatal)
4486 output_fields(out_field)%attributes(this_attribute)%len = length
4487 output_fields(out_field)%attributes(this_attribute)%fatt = rval
4489 IF ( .NOT.
PRESENT(cval) )
THEN
4495 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',&
4496 &
'Attribute type claims CHARACTER, but cval not present for attribute "'&
4497 &//trim(name)//
'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//
'/'&
4498 &//trim(input_fields(diag_field_id)%field_name)//
'". Contact the developers.', fatal)
4506 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',
'Unknown attribute type for attribute "'&
4507 &//trim(name)//
'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//
'/'&
4508 &//trim(input_fields(diag_field_id)%field_name)//
'". Contact the developers.', fatal)
4516 INTEGER,
INTENT(in) :: diag_field_id
4517 CHARACTER(len=*),
INTENT(in) :: att_name
4518 class(*),
INTENT(in) :: att_value
4520 if (use_modern_diag)
then
4521 select type(att_value)
4522 type is (real(kind=r4_kind))
4523 call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, (/att_value /))
4524 type is (real(kind=r8_kind))
4525 call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, (/att_value /))
4526 type is (
integer(kind=i4_kind))
4527 call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, (/att_value /))
4528 type is (
character(len=*))
4529 call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, (/att_value /))
4531 call mpp_error(fatal,
"Diag_field_add_attribute 0d:: unsupported type. The acceptable types "//&
4532 "are float, double, integer, and string")
4535 select type(att_value)
4536 type is (real(kind=r4_kind))
4538 type is (real(kind=r8_kind))
4540 type is (
integer(kind=i4_kind))
4542 type is (
character(len=*))
4545 call mpp_error(fatal,
"Diag_field_add_attribute 0d:: unsupported type. The acceptable types "//&
4546 "are float, double, integer, and string")
4554 INTEGER,
INTENT(in) :: diag_field_id
4555 CHARACTER(len=*),
INTENT(in) :: att_name
4556 class(*),
INTENT(in) :: att_value(:)
4558 if (use_modern_diag)
then
4559 call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, att_value)
4561 select type(att_value)
4562 type is (real(kind=r4_kind))
4564 type is (real(kind=r8_kind))
4566 type is (
integer(kind=i4_kind))
4569 call mpp_error(fatal,
"Diag_field_add_attribute 1d:: unsupported type. The acceptable types "//&
4570 "are float, double, and integer")
4581 INTEGER,
INTENT(in) :: diag_field_id
4582 INTEGER,
INTENT(in),
OPTIONAL :: area
4583 INTEGER,
INTENT(in),
OPTIONAL :: volume
4587 IF ( diag_field_id.GT.0 )
THEN
4588 IF ( .NOT.
PRESENT(area) .AND. .NOT.
present(volume) )
THEN
4589 CALL error_mesg(
'diag_manager_mod::diag_field_add_cell_measures', &
4590 &
'either area or volume arguments must be present', fatal )
4593 if (use_modern_diag)
then
4594 call fms_diag_object%fms_diag_field_add_cell_measures(diag_field_id, area, volume)
4598 DO j=1, input_fields(diag_field_id)%num_output_fields
4599 ind = input_fields(diag_field_id)%output_fields(j)
4607 class(*),
intent(in) :: data_in(:,:,:)
4608 character(len=*),
intent(in) :: field_name
4609 class(*),
allocatable,
intent(out) :: data_out(:,:,:,:)
4612 select type(data_in)
4613 type is (real(kind=r8_kind))
4614 allocate(real(kind=r8_kind) :: data_out(1:
size(data_in,1), 1:
size(data_in,2), 1:
size(data_in,3), 1))
4615 select type (data_out)
4616 type is (real(kind=r8_kind))
4617 data_out(:,:,:,1) = data_in
4619 call mpp_error(fatal,
"The copy of "//trim(field_name)//&
4620 " was not allocated to the correct type (r8_kind). This shouldn't have happened")
4622 type is (real(kind=r4_kind))
4623 allocate(real(kind=r4_kind) :: data_out(1:
size(data_in,1), 1:
size(data_in,2), 1:
size(data_in,3), 1))
4624 select type (data_out)
4625 type is (real(kind=r4_kind))
4626 data_out(:,:,:,1) = data_in
4628 call mpp_error(fatal,
"The copy of "//trim(field_name)//&
4629 " was not allocated to the correct type (r4_kind). This shouldn't have happened")
4632 call mpp_error(fatal,
"The data for "//trim(field_name)//&
4633 &
" is not a valid type. Currently only r4 and r8 are supported")
4637 END MODULE diag_manager_mod
integer(i4_kind) function, public axis_compatible_check(id, varname)
Checks if the axes are compatible.
integer function, public get_axis_length(id)
Return the length of the axis.
integer function, public get_axis_num(axis_name, set_name)
Returns index into axis table corresponding to a given axis name.
type(domain2d) function, public get_domain2d(ids)
Return the 2D domain for the axis IDs given.
integer function, public get_tile_count(ids)
Return the tile count for the axis.
subroutine, public get_diag_axis_name(id, axis_name)
Return the short name of the axis.
integer(i4_kind), parameter, public diag_axis_2ddomain
For unstructured grid support.
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.
integer(i4_kind), parameter, public diag_axis_ugdomain
For unstructured grid support.
Add an arbitrary attribute and value to the diagnostic axis.
integer max_output_fields
Maximum number of output fields. Increase via diag_manager_nml.
real fill_value
Fill value used. Value will be NF90_FILL_REAL if using the netCDF module, otherwise will be 9....
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 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 max_axis_attributes
Maximum number of user definable attributes per axis.
character(len=6) pack_size_str
Pack size as a string to be used in fms2_io register call set to "double" or "float".
logical use_modern_diag
Namelist flag to use the modernized diag_manager code.
type(time_type) function get_base_time()
gets the module variable base_time
integer max_axes
Maximum number of independent axes.
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 use_clock_average
.TRUE. if the averaging of variable is done based on the clock For example, if doing daily averages a...
logical issue_oor_warnings
Issue warnings if the output field has values outside the given range for a variable.
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.
subroutine diag_data_init()
Initialize and write the version number of this file to the log file.
integer function get_base_month()
gets the module variable base_month
logical module_is_initialized
Indicate if diag_manager has been initialized.
logical oor_warnings_fatal
Cause a fatal error if the output field has a value outside the given range for a variable.
integer function get_base_second()
gets the module variable base_second
logical use_refactored_send
Namelist flag to use refactored send_data math funcitons.
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 hold the output field description.
subroutine, public diag_grid_init(domain, glo_lat, glo_lon, aglo_lat, aglo_lon)
Send the global grid to the diag_manager_mod for regional output.
subroutine, public diag_grid_end()
Unallocate the diag_global_grid variable.
logical function, public need_data(diag_field_id, next_model_time)
Determine whether data is needed for the current model time step.
logical function get_related_field(field, rel_field, out_field_id, out_file_id)
Finds the corresponding related output field and file for a given input field.
logical function send_data_2d(diag_field_id, field, time, is_in, js_in, mask, rmask, ie_in, je_in, weight, err_msg)
integer function register_diag_field_scalar(module_name, field_name, init_time, long_name, units, missing_value, range, standard_name, do_not_log, err_msg, area, volume, realm, multiple_send_data)
Registers a scalar field.
integer function, public register_static_field(module_name, field_name, axes, long_name, units, missing_value, range, mask_variant, standard_name, DYNAMIC, do_not_log, interp_method, tile_count, area, volume, realm)
Return field index for subsequent call to send_data.
subroutine copy_3d_to_4d(data_in, data_out, field_name)
Copies a 3d buffer to a 4d buffer.
logical function send_data_4d(diag_field_id, field, time, is_in, js_in, ks_in, mask, rmask, ie_in, je_in, ke_in, weight, err_msg)
Updates the output buffer for a field based on the data for current time step.
subroutine diag_field_attribute_init(diag_field_id, name, type, cval, ival, rval)
logical function send_tile_averaged_data3d(id, field, area, time, mask)
integer function register_diag_field_array(module_name, field_name, axes, init_time, long_name, units, missing_value, range, mask_variant, standard_name, verbose, do_not_log, err_msg, interp_method, tile_count, area, volume, realm, multiple_send_data)
Registers an array field.
integer function register_diag_field_scalar_old(module_name, field_name, init_time, long_name, units, missing_value, range, standard_name, do_not_log, err_msg, area, volume, realm)
Registers a scalar field.
integer function register_static_field_old(module_name, field_name, axes, long_name, units, missing_value, range, mask_variant, standard_name, DYNAMIC, do_not_log, interp_method, tile_count, area, volume, realm)
Return field index for subsequent call to send_data.
subroutine closing_file(file, time)
Replaces diag_manager_end; close just one file: files(file)
subroutine, public diag_field_add_cell_measures(diag_field_id, area, volume)
Add the cell_measures attribute to a diag out field.
subroutine init_field_cell_measures(output_field, area, volume, err_msg)
If needed, add cell_measures and associated_file attribute to out field/file.
integer function register_diag_field_array_old(module_name, field_name, axes, init_time, long_name, units, missing_value, range, mask_variant, standard_name, verbose, do_not_log, err_msg, interp_method, tile_count, area, volume, realm)
Registers an array field.
subroutine, public diag_send_complete_instant(time)
The subroutine 'diag_send_complete_instant' allows the user to save diagnostic data on variable inter...
subroutine average_tiles(diag_field_id, x, area, mask, out)
Calculates tile average of a field.
logical function send_data_0d(diag_field_id, field, time, err_msg)
subroutine add_associated_files(file_num, cm_file_num, cm_ind)
Add to the associated files attribute.
integer function writing_field(out_num, at_diag_end, error_string, time)
subroutine, public diag_manager_init(diag_model_subset, time_init, err_msg)
Initialize Diagnostics Manager.
integer function, public get_diag_field_id(module_name, field_name)
Return the diagnostic field ID of a given variable.
subroutine, public get_base_date(year, month, day, hour, minute, second)
Return base date for diagnostics.
logical function send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, mask, rmask, ie_in, je_in, ke_in, weight, err_msg)
subroutine average_tiles1d(diag_field_id, x, area, mask, out)
Calculates average for a field with the given area and land mask.
logical function diag_send_data(diag_field_id, field, time, is_in, js_in, ks_in, mask, rmask, ie_in, je_in, ke_in, weight, err_msg)
subroutine diag_field_add_attribute_0d(diag_field_id, att_name, att_value)
Add a scalr attribute to the diag field corresponding to a given id.
logical function send_tile_averaged_data1d(id, field, area, time, mask)
logical function send_data_1d(diag_field_id, field, time, is_in, mask, rmask, ie_in, weight, err_msg)
subroutine, public diag_manager_end(time)
Flushes diagnostic buffers where necessary. Close diagnostics files. A warning will be issued here if...
logical function send_tile_averaged_data2d(id, field, area, time, mask)
integer function init_diurnal_axis(n_samples)
Finds or initializes a diurnal time axis and returns its' ID.
subroutine diag_field_add_attribute_1d(diag_field_id, att_name, att_value)
Add an 1D array attribute to the diag field corresponding to a given id.
subroutine, public diag_send_complete(time_step, err_msg)
Saves diagnostic data for the given time value.
Add a attribute to the output field.
Register a diagnostic field for a given module.
Send data over to output fields.
Send tile-averaged data over to output fields.
subroutine, public get_diag_global_att(gAtt)
Return the global attribute type.
subroutine, public set_diag_global_att(component, gridType, tileName)
Set the global attribute type.
subroutine, public parse_diag_table(diag_subset, istat, err_msg)
Parse the diag_table in preparation for diagnostic output.
subroutine, public get_subfield_size(axes, outnum)
Get the size, start, and end indices for output fields.
subroutine, public init_input_field(module_name, field_name, tile_count)
Initialize the input field.
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.
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.
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 get_subfield_vert_size(axes, outnum)
Get size, start and end indices for output fields.
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, public diag_util_init()
Write the version number of this file to the log 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...
Allocates the atttype in out_file.
Prepend a value to a string attribute in the output field or output file.
Interface fieldbuff_copy_fieldvals updates elements of the field output buffer with copies of corresp...
Interface fieldbuff_copy_missvals updates elements of the field output buffer with the missvalue inpu...
Interface fieldbuff_update updates elements of field output buffer based on input field data and math...
Class fmsDiagOutfield_type (along with class ms_diag_outfield_index_type ) contain information used i...
Class fms_diag_outfield_index_type which (along with class fmsDiagOutfield_type) encapsulate related ...
integer function, public check_nml_error(IOSTAT, NML_NAME)
Checks the iostat argument that is returned after reading a namelist and determines if the error code...
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....
character(:) function, allocatable, public string(v, fmt)
Converts a number or a Boolean value to a string.
integer function stdout()
This function returns the current standard fortran unit numbers for output.
integer function stdlog()
This function returns the current standard fortran unit numbers for log messages. Log messages,...
integer function mpp_npes()
Returns processor count for current pelist.
integer function mpp_pe()
Returns processor ID.
integer function, public get_ticks_per_second()
Returns the number of ticks per second.
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...
Given an input date in year, month, days, etc., creates a time_type that represents this time interva...
Given some number of seconds and days, returns the corresponding time_type.
Type to represent amounts of time. Implemented as seconds and days to allow for larger intervals.
Get the current pelist. The two flavors of this subroutine differ in the type of their comm/commID ar...