145 MODULE diag_manager_mod
214 &
OPERATOR(<),
OPERATOR(==),
OPERATOR(/=),
OPERATOR(/),
OPERATOR(+),
ASSIGNMENT(=),
get_date, &
218 USE mpp_mod,
ONLY: input_nml_file,
mpp_error
231 & end_of_run, diag_seconds, diag_minutes, diag_hours, diag_days, diag_months, diag_years,
num_files,&
235 & output_fields, time_zero, append_pelist_name, mix_snapshot_average_fields,&
236 & first_send_data_call, do_diag_field_log, write_bytes_in_file, debug_diag_manager,&
248 use fms_diag_object_mod,
only:fms_diag_object
250 USE constants_mod,
ONLY: seconds_per_day
254 USE fms_string_utils_mod,
ONLY:
string
256 USE netcdf,
ONLY: nf90_int, nf90_float, nf90_char
269 &
need_data, diag_all, diag_ocean, diag_other, get_date_dif, diag_seconds,&
273 PUBLIC :: center, north, east
279 PUBLIC :: diag_field_not_found
283 #include<file_version.h>
285 type(time_type) :: Time_end
388 & long_name, units, missing_value, range, standard_name, do_not_log, err_msg,&
389 & area, volume, realm, multiple_send_data)
390 CHARACTER(len=*),
INTENT(in) :: module_name
391 CHARACTER(len=*),
INTENT(in) :: field_name
392 TYPE(
time_type),
OPTIONAL,
INTENT(in) :: init_time
393 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: long_name
394 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: units
395 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: standard_name
396 CLASS(*),
OPTIONAL,
INTENT(in) :: missing_value
397 CLASS(*),
OPTIONAL,
INTENT(in) :: range(:)
398 LOGICAL,
OPTIONAL,
INTENT(in) :: do_not_log
399 CHARACTER(len=*),
OPTIONAL,
INTENT(out):: err_msg
400 INTEGER,
OPTIONAL,
INTENT(in) :: area
401 INTEGER,
OPTIONAL,
INTENT(in) :: volume
402 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: realm
403 LOGICAL,
OPTIONAL,
INTENT(in) :: multiple_send_data
407 IF (
PRESENT(range) )
THEN
408 IF (
SIZE(range) .NE. 2 )
THEN
410 CALL error_mesg (
'diag_manager_mod::register_diag_field',
'extent of range should be 2', fatal)
413 if (use_modern_diag)
then
414 if( do_diag_field_log)
then
415 if (
PRESENT(do_not_log) )
THEN
416 if(.not. do_not_log)
call log_diag_field_info(module_name, field_name, (/null_axis_id/), long_name,&
417 & units, missing_value, range, dynamic=.true.)
420 & missing_value, range, dynamic=.true.)
424 & module_name, field_name, init_time, long_name=long_name, units=units, &
425 & missing_value=missing_value, var_range=range, standard_name=standard_name, &
426 & do_not_log=do_not_log, err_msg=err_msg, area=area, volume=volume, realm=realm, &
427 multiple_send_data=multiple_send_data)
430 & long_name=long_name, units=units, missing_value=missing_value, range=range, standard_name=standard_name, &
431 & do_not_log=do_not_log, err_msg=err_msg, area=area, volume=volume, realm=realm)
438 & long_name, units, missing_value, range, mask_variant, standard_name, verbose,&
439 & do_not_log, err_msg, interp_method, tile_count, area, volume, realm, multiple_send_data)
440 CHARACTER(len=*),
INTENT(in) :: module_name
441 CHARACTER(len=*),
INTENT(in) :: field_name
442 INTEGER,
INTENT(in) :: axes(:)
443 TYPE(
time_type),
OPTIONAL,
INTENT(in) :: init_time
444 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: long_name
445 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: units
446 CLASS(*),
OPTIONAL,
INTENT(in) :: missing_value
447 CLASS(*),
OPTIONAL,
INTENT(in) :: range(:)
448 LOGICAL,
OPTIONAL,
INTENT(in) :: mask_variant
449 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: standard_name
450 LOGICAL,
OPTIONAL,
INTENT(in) :: verbose
451 LOGICAL,
OPTIONAL,
INTENT(in) :: do_not_log
452 CHARACTER(len=*),
OPTIONAL,
INTENT(out):: err_msg
453 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: interp_method
457 INTEGER,
OPTIONAL,
INTENT(in) :: tile_count
458 INTEGER,
OPTIONAL,
INTENT(in) :: area
459 INTEGER,
OPTIONAL,
INTENT(in) :: volume
460 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: realm
461 LOGICAL,
OPTIONAL,
INTENT(in) :: multiple_send_data
464 if (use_modern_diag)
then
465 if( do_diag_field_log)
then
466 if (
PRESENT(do_not_log) )
THEN
468 & units, missing_value, range, dynamic=.true.)
471 & missing_value, range, dynamic=.true.)
475 & module_name, field_name, axes, init_time, long_name=long_name, &
476 & units=units, missing_value=missing_value, var_range=range, mask_variant=mask_variant, &
477 & standard_name=standard_name, verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
478 & interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm, &
479 multiple_send_data=multiple_send_data)
482 & long_name=long_name, units=units, missing_value=missing_value, range=range, mask_variant=mask_variant, &
483 & standard_name=standard_name, verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
484 & interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm)
491 & missing_value, range, mask_variant, standard_name, DYNAMIC, do_not_log, interp_method,&
492 & tile_count, area, volume, realm)
493 CHARACTER(len=*),
INTENT(in) :: module_name
494 CHARACTER(len=*),
INTENT(in) :: field_name
495 INTEGER,
DIMENSION(:),
INTENT(in) :: axes
496 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: long_name
497 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: units
498 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: standard_name
499 CLASS(*),
OPTIONAL,
INTENT(in) :: missing_value
500 CLASS(*),
DIMENSION(:),
OPTIONAL,
INTENT(in) :: range
501 LOGICAL,
OPTIONAL,
INTENT(in) :: mask_variant
502 LOGICAL,
OPTIONAL,
INTENT(in) :: dynamic
503 LOGICAL,
OPTIONAL,
INTENT(in) :: do_not_log
504 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: interp_method
508 INTEGER,
OPTIONAL,
INTENT(in) :: tile_count
509 INTEGER,
OPTIONAL,
INTENT(in) :: area
511 INTEGER,
OPTIONAL,
INTENT(in) :: volume
513 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: realm
517 IF ( .NOT.module_is_initialized )
THEN
519 CALL error_mesg (
'diag_manager_mod::register_static_field',
'diag_manager has NOT been initialized', fatal)
522 if (use_modern_diag)
then
523 if( do_diag_field_log)
then
524 if (
PRESENT(do_not_log) )
THEN
526 & units, missing_value, range, dynamic=.false.)
529 & missing_value, range, dynamic=.false.)
533 & long_name=long_name, units=units, missing_value=missing_value, range=range, mask_variant=mask_variant, &
534 & standard_name=standard_name, dynamic=dynamic, do_not_log=do_not_log, interp_method=interp_method,&
535 & tile_count=tile_count, area=area, volume=volume, realm=realm)
538 & long_name=long_name, units=units, missing_value=missing_value, range=range, mask_variant=mask_variant, &
539 & standard_name=standard_name, dynamic=dynamic, do_not_log=do_not_log, interp_method=interp_method,&
540 & tile_count=tile_count, area=area, volume=volume, realm=realm)
547 & long_name, units, missing_value, range, standard_name, do_not_log, err_msg,&
548 & area, volume, realm)
549 CHARACTER(len=*),
INTENT(in) :: module_name
550 CHARACTER(len=*),
INTENT(in) :: field_name
551 TYPE(
time_type),
OPTIONAL,
INTENT(in) :: init_time
552 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: long_name
553 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: units
554 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: standard_name
555 CLASS(*),
OPTIONAL,
INTENT(in) :: missing_value
556 CLASS(*),
OPTIONAL,
INTENT(in) :: range(:)
557 LOGICAL,
OPTIONAL,
INTENT(in) :: do_not_log
558 CHARACTER(len=*),
OPTIONAL,
INTENT(out):: err_msg
559 INTEGER,
OPTIONAL,
INTENT(in) :: area
560 INTEGER,
OPTIONAL,
INTENT(in) :: volume
561 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: realm
563 IF (
PRESENT(err_msg) ) err_msg =
''
565 IF (
PRESENT(init_time) )
THEN
567 & (/null_axis_id/), init_time,long_name, units, missing_value, range, &
568 & standard_name=standard_name, do_not_log=do_not_log, err_msg=err_msg,&
569 & area=area, volume=volume, realm=realm)
572 & (/null_axis_id/),long_name, units, missing_value, range,&
573 & standard_name=standard_name, do_not_log=do_not_log, realm=realm)
580 & long_name, units, missing_value, range, mask_variant, standard_name, verbose,&
581 & do_not_log, err_msg, interp_method, tile_count, area, volume, realm)
582 CHARACTER(len=*),
INTENT(in) :: module_name, field_name
583 INTEGER,
INTENT(in) :: axes(:)
585 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: long_name, units, standard_name
586 CLASS(*),
OPTIONAL,
INTENT(in) :: missing_value
587 CLASS(*),
DIMENSION(:),
OPTIONAL,
INTENT(in) :: range
588 LOGICAL,
OPTIONAL,
INTENT(in) :: mask_variant,verbose
589 LOGICAL,
OPTIONAL,
INTENT(in) :: do_not_log
590 CHARACTER(len=*),
OPTIONAL,
INTENT(out):: err_msg
591 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: interp_method
595 INTEGER,
OPTIONAL,
INTENT(in) :: tile_count
596 INTEGER,
OPTIONAL,
INTENT(in) :: area
597 INTEGER,
OPTIONAL,
INTENT(in) :: volume
598 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: realm
600 INTEGER :: field, j, ind, file_num, freq
601 INTEGER :: output_units
602 INTEGER :: stdout_unit
603 LOGICAL :: mask_variant1, verbose1
604 CHARACTER(len=128) :: msg
610 IF (
PRESENT(mask_variant) )
THEN
611 mask_variant1 = mask_variant
613 mask_variant1 = .false.
616 IF (
PRESENT(verbose) )
THEN
622 IF (
PRESENT(err_msg) ) err_msg =
''
625 IF (
PRESENT(range) )
THEN
626 IF (
SIZE(range) .NE. 2 )
THEN
628 CALL error_mesg (
'diag_manager_mod::register_diag_field',
'extent of range should be 2', fatal)
634 & long_name, units, missing_value, range, mask_variant1, standard_name=standard_name,&
635 & dynamic=.true., do_not_log=do_not_log, interp_method=interp_method, tile_count=tile_count, realm=realm)
637 IF ( .NOT.first_send_data_call )
THEN
642 IF (
mpp_pe() == mpp_root_pe() ) &
643 &
CALL error_mesg (
'diag_manager_mod::register_diag_field',
'module/output_field '&
644 &//trim(module_name)//
'/'// trim(field_name)//&
645 &
' registered AFTER first send_data call, TOO LATE', warning)
652 IF ( debug_diag_manager .OR. verbose1 )
THEN
653 IF (
mpp_pe() == mpp_root_pe() ) &
654 &
CALL error_mesg (
'diag_manager_mod::register_diag_field',
'module/output_field '&
655 &//trim(module_name)//
'/'// trim(field_name)//
' NOT found in diag_table',&
664 IF (
PRESENT(volume).AND.
PRESENT(area) )
THEN
665 IF ( area.EQ.volume )
THEN
666 IF (
PRESENT(err_msg))
THEN
667 err_msg =
'diag_manager_mod::register_diag_field: module/output_field '&
668 &//trim(module_name)//
'/'// trim(field_name)//
' AREA and VOLUME CANNOT be the same variable.&
669 & Contact the developers.'
673 CALL error_mesg (
'diag_manager_mod::register_diag_field',
'module/output_field '&
674 &//trim(module_name)//
'/'// trim(field_name)//
' AREA and VOLUME CANNOT be the same variable.&
675 & Contact the developers.',&
682 IF (
PRESENT(area) )
THEN
684 IF (
PRESENT(err_msg))
THEN
685 err_msg =
'diag_manager_mod::register_diag_field: module/output_field '&
686 &//trim(module_name)//
'/'// trim(field_name)//
' AREA measures field NOT found in diag_table.&
687 & Contact the model liaison.'
691 CALL error_mesg (
'diag_manager_mod::register_diag_field',
'module/output_field '&
692 &//trim(module_name)//
'/'// trim(field_name)//
' AREA measures field NOT found in diag_table.&
693 & Contact the model liaison.',&
698 IF (
PRESENT(volume) )
THEN
699 IF ( volume < 0 )
THEN
700 IF (
PRESENT(err_msg))
THEN
701 err_msg =
'diag_manager_mod::register_diag_field: module/output_field '&
702 &//trim(module_name)//
'/'// trim(field_name)//
' VOLUME measures field NOT found in diag_table.&
703 & Contact the model liaison.'
707 CALL error_mesg (
'diag_manager_mod::register_diag_field',
'module/output_field '&
708 &//trim(module_name)//
'/'// trim(field_name)//
' VOLUME measures field NOT found in diag_table.&
709 & Contact the model liaison.',&
715 IF (
PRESENT(standard_name) ) input_fields(field)%standard_name = standard_name
717 DO j = 1, input_fields(field)%num_output_fields
718 ind = input_fields(field)%output_fields(j)
719 output_fields(ind)%static = .false.
722 file_num = output_fields(ind)%output_file
723 IF ( file_num == max_files ) cycle
724 IF ( output_fields(ind)%local_output )
THEN
725 IF ( output_fields(ind)%need_compute)
THEN
726 files(file_num)%local = .true.
734 IF ( msg /=
'' )
THEN
735 IF (
fms_error_handler(
'diag_manager_mod::register_diag_field', trim(msg), err_msg) )
RETURN
738 freq = files(file_num)%output_freq
740 output_units = files(file_num)%output_units
741 output_fields(ind)%last_output = diag_file_init_time
742 output_fields(ind)%next_output = diag_time_inc(diag_file_init_time, freq, output_units, err_msg=msg)
743 IF ( msg /=
'' )
THEN
745 &
' file='//trim(files(file_num)%name)//
': '//trim(msg),err_msg))
RETURN
747 output_fields(ind)%next_next_output = &
748 & diag_time_inc(output_fields(ind)%next_output, freq, output_units, err_msg=msg)
749 IF ( msg /=
'' )
THEN
751 &
' file='//trim(files(file_num)%name)//
': '//trim(msg),err_msg) )
RETURN
753 IF ( debug_diag_manager .AND.
mpp_pe() == mpp_root_pe() .AND. output_fields(ind)%local_output )
THEN
754 WRITE (msg,
'(" lon(",F5.1,", ",F5.1,"), lat(",F5.1,", ",F5.1,"), dep(",F5.1,", ",F5.1,")")') &
755 & output_fields(ind)%output_grid%start(1),output_fields(ind)%output_grid%end(1),&
756 & output_fields(ind)%output_grid%start(2),output_fields(ind)%output_grid%end(2),&
757 & output_fields(ind)%output_grid%start(3),output_fields(ind)%output_grid%end(3)
758 WRITE(stdout_unit,* )
'module/output_field '//trim(module_name)//
'/'//trim(field_name)// &
759 &
' will be output in region:'//trim(msg)
764 IF ( len_trim(err_msg).GT.0 )
THEN
765 CALL error_mesg (
'diag_manager_mod::register_diag_field',&
766 & trim(err_msg)//
' for module/field '//trim(module_name)//
'/'//trim(field_name),&
777 & missing_value, range, mask_variant, standard_name, DYNAMIC, do_not_log, interp_method,&
778 & tile_count, area, volume, realm)
779 CHARACTER(len=*),
INTENT(in) :: module_name, field_name
780 INTEGER,
DIMENSION(:),
INTENT(in) :: axes
781 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: long_name, units, standard_name
782 CLASS(*),
OPTIONAL,
INTENT(in) :: missing_value
783 CLASS(*),
DIMENSION(:),
OPTIONAL,
INTENT(in) :: range
784 LOGICAL,
OPTIONAL,
INTENT(in) :: mask_variant
785 LOGICAL,
OPTIONAL,
INTENT(in) :: dynamic
786 LOGICAL,
OPTIONAL,
INTENT(in) :: do_not_log
787 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: interp_method
791 INTEGER,
OPTIONAL,
INTENT(in) :: tile_count
792 INTEGER,
OPTIONAL,
INTENT(in) :: area
793 INTEGER,
OPTIONAL,
INTENT(in) :: volume
794 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: realm
796 REAL :: missing_value_use
797 REAL,
DIMENSION(2) :: range_use
798 INTEGER :: field, num_axes, j, out_num, k
799 INTEGER,
DIMENSION(3) :: siz, local_siz, local_start, local_end
800 INTEGER :: tile, file_num
801 LOGICAL :: mask_variant1, dynamic1, allow_log
802 CHARACTER(len=128) :: msg
803 INTEGER :: domain_type, i
804 character(len=256) :: axis_name
807 IF ( .NOT.module_is_initialized )
THEN
809 CALL error_mesg (
'diag_manager_mod::register_static_field_old',
'diag_manager has NOT been initialized', fatal)
813 IF (
PRESENT(missing_value) )
THEN
815 missing_value_use = cmor_missing_value
817 SELECT TYPE (missing_value)
818 TYPE IS (real(kind=r4_kind))
819 missing_value_use = missing_value
820 TYPE IS (real(kind=r8_kind))
821 missing_value_use = real(missing_value)
823 CALL error_mesg (
'diag_manager_mod::register_static_field',&
824 &
'The missing_value is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
829 IF (
PRESENT(mask_variant) )
THEN
830 mask_variant1 = mask_variant
832 mask_variant1 = .false.
835 IF (
PRESENT(dynamic) )
THEN
841 IF (
PRESENT(tile_count) )
THEN
847 IF (
PRESENT(do_not_log) )
THEN
848 allow_log = .NOT.do_not_log
854 IF (
PRESENT(range) )
THEN
855 IF (
SIZE(range) .NE. 2 )
THEN
857 CALL error_mesg (
'diag_manager_mod::register_static_field',
'extent of range should be 2', fatal)
863 IF ( do_diag_field_log.AND.allow_log )
THEN
865 & long_name, units, missing_value=missing_value, range=range, &
875 domain_type = axis_compatible_check(axes,field_name)
878 IF ( .NOT.input_fields(field)%register )
THEN
883 CALL error_mesg (
'diag_manager_mod::register_diag_field',
'module/output_field '//trim(module_name)//
'/'//&
884 & trim(field_name)//
' is not registered for tile_count = 1, should not register for tile_count > 1',&
890 DO j = 1, input_fields(field)%num_output_fields
891 out_num = input_fields(field)%output_fields(j)
892 file_num = output_fields(out_num)%output_file
893 IF(input_fields(field)%local)
THEN
894 CALL init_output_field(module_name, field_name,output_fields(out_num)%output_name,&
895 & files(file_num)%name,output_fields(out_num)%time_method, output_fields(out_num)%pack,&
896 & tile, input_fields(field)%local_coord)
898 CALL init_output_field(module_name, field_name,output_fields(out_num)%output_name,&
899 & files(file_num)%name,output_fields(out_num)%time_method, output_fields(out_num)%pack, tile)
909 input_fields(field)%static = .true.
911 IF ( input_fields(field)%register .AND.
mpp_pe() == mpp_root_pe() )
THEN
916 CALL error_mesg (
'diag_manager_mod::register_diag_field',
'module/output_field '//trim(module_name)//
'/'//&
917 & trim(field_name)//
' ALREADY registered, should not register twice', fatal)
921 IF (
PRESENT(volume).AND.
PRESENT(area) )
THEN
922 IF ( area.EQ.volume )
THEN
923 CALL error_mesg (
'diag_manager_mod::register_static_field_old',
'module/output_field '&
924 &//trim(module_name)//
'/'// trim(field_name)//
' AREA and VOLUME CANNOT be the same variable.&
925 & Contact the developers.',&
931 IF (
PRESENT(area) )
THEN
933 CALL error_mesg (
'diag_manager_mod::register_static_field_old',
'module/output_field '&
934 &//trim(module_name)//
'/'// trim(field_name)//
' AREA measures field NOT found in diag_table.&
935 & Contact the model liaison.n',&
939 IF (
PRESENT(volume) )
THEN
940 IF ( volume < 0 )
THEN
941 CALL error_mesg (
'diag_manager_mod::register_static_field_old',
'module/output_field '&
942 &//trim(module_name)//
'/'// trim(field_name)//
' VOLUME measures field NOT found in diag_table&
943 & Contact the model liaison.',&
949 input_fields(field)%register = .true.
951 input_fields(field)%mask_variant = mask_variant1
953 input_fields(field)%issued_mask_ignore_warning = .false.
956 IF (
PRESENT(long_name) )
THEN
957 input_fields(field)%long_name = trim(long_name)
959 input_fields(field)%long_name = input_fields(field)%field_name
962 IF (
PRESENT(standard_name) ) input_fields(field)%standard_name = standard_name
964 IF (
PRESENT(units) )
THEN
965 input_fields(field)%units = trim(units)
967 input_fields(field)%units =
'none'
970 IF (
PRESENT(missing_value) )
THEN
971 input_fields(field)%missing_value = missing_value_use
972 input_fields(field)%missing_value_present = .true.
974 input_fields(field)%missing_value_present = .false.
977 IF (
PRESENT(range) )
THEN
979 TYPE IS (real(kind=r4_kind))
981 TYPE IS (real(kind=r8_kind))
982 range_use = real(range)
984 CALL error_mesg (
'diag_manager_mod::register_static_field',&
985 &
'The range is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
987 input_fields(field)%range = range_use
989 input_fields(field)%range_present = range_use(2) .gt. range_use(1)
991 input_fields(field)%range = (/ 1., 0. /)
992 input_fields(field)%range_present = .false.
995 IF (
PRESENT(interp_method) )
THEN
996 IF ( trim(interp_method) .NE.
'conserve_order1' .AND.&
997 & trim(interp_method) .NE.
'conserve_order2' .AND.&
998 & trim(interp_method) .NE.
'none' )
THEN
1004 CALL error_mesg (
'diag_manager_mod::register_diag_field',&
1005 &
'when registering module/output_field '//trim(module_name)//
'/'//&
1006 & trim(field_name)//
', the optional argument interp_method = '//trim(interp_method)//&
1007 &
', but it should be "conserve_order1", "conserve_order2", or "none"', fatal)
1009 input_fields(field)%interp_method = trim(interp_method)
1011 input_fields(field)%interp_method =
''
1015 num_axes =
SIZE(axes(:))
1016 input_fields(field)%axes(1:num_axes) = axes
1017 input_fields(field)%num_axes = num_axes
1021 IF ( axes(j) .LE. 0 )
THEN
1025 CALL error_mesg (
'diag_manager_mod::register_diag_field',
'module/output_field '//trim(module_name)//
'/'//&
1026 & trim(field_name)//
' has non-positive axis_id', fatal)
1028 siz(j) = get_axis_length(axes(j))
1033 input_fields(field)%size(j) = siz(j)
1040 DO j = 1, input_fields(field)%num_output_fields
1041 out_num = input_fields(field)%output_fields(j)
1043 IF ( output_fields(out_num)%pack>=4 .AND. .NOT.input_fields(field)%range_present )
THEN
1044 IF(
mpp_pe() .EQ. mpp_root_pe())
THEN
1048 CALL error_mesg (
'diag_manager_mod::register_diag_field ',
'output_field '//trim(field_name)// &
1049 ' has pack >=4, range is REQUIRED in register_diag_field', fatal)
1054 IF ( .NOT.dynamic1 ) output_fields(out_num)%n_diurnal_samples = 1
1058 file_num = output_fields(out_num)%output_file
1059 if (domain_type .eq. diag_axis_2ddomain)
then
1060 if (files(file_num)%use_domainUG)
then
1061 call error_mesg(
"diag_manager_mod::register_static_field_old", &
1062 "Diagnostics living on a structured grid" &
1063 //
" and an unstructured grid cannot exist" &
1064 //
" in the same file (" &
1065 //trim(files(file_num)%name)//
")", &
1067 elseif (.not. files(file_num)%use_domain2D)
then
1068 files(file_num)%use_domain2D = .true.
1071 if (files(file_num)%use_domain2D)
then
1072 call error_mesg(
"diag_manager_mod::register_static_field_old", &
1073 "Diagnostics living on a structured grid" &
1074 //
" and an unstructured grid cannot exist" &
1075 //
" in the same file (" &
1076 //trim(files(file_num)%name)//
")", &
1078 elseif (.not. files(file_num)%use_domainUG)
then
1079 files(file_num)%use_domainUG = .true.
1085 IF ( output_fields(out_num)%reduced_k_range )
THEN
1094 local_start(2) = output_fields(out_num)%output_grid%l_start_indx(2)
1095 local_end(2) = output_fields(out_num)%output_grid%l_end_indx(2)
1096 local_siz(2) = local_end(2) - local_start(2) + 1
1097 allocate(output_fields(out_num)%buffer(siz(1),local_siz(2),siz(3), &
1098 output_fields(out_num)%n_diurnal_samples))
1099 output_fields(out_num)%region_elements = siz(1)*local_siz(2)*siz(3)
1100 output_fields(out_num)%reduced_k_unstruct = .true.
1102 local_start(3) = output_fields(out_num)%output_grid%l_start_indx(3)
1103 local_end(3) = output_fields(out_num)%output_grid%l_end_indx(3)
1104 local_siz(3) = local_end(3) - local_start(3) + 1
1105 allocate(output_fields(out_num)%buffer(siz(1),siz(2),local_siz(3), &
1106 output_fields(out_num)%n_diurnal_samples))
1107 output_fields(out_num)%region_elements = siz(1)*siz(2)*local_siz(3)
1108 output_fields(out_num)%reduced_k_unstruct = .false.
1110 output_fields(out_num)%total_elements = siz(1)*siz(2)*siz(3)
1113 IF ( output_fields(out_num)%time_max )
THEN
1114 output_fields(out_num)%buffer = max_value
1115 ELSE IF ( output_fields(out_num)%time_min )
THEN
1116 output_fields(out_num)%buffer = min_value
1118 output_fields(out_num)%buffer = empty
1120 ELSE IF ( output_fields(out_num)%local_output )
THEN
1121 IF (
SIZE(axes(:)) .LE. 1 )
THEN
1123 CALL error_mesg (
'diag_manager_mod::register_diag_field',
'axes of '//trim(field_name)//&
1124 &
' must >= 2 for local output', fatal)
1127 IF ( output_fields(out_num)%need_compute )
THEN
1129 local_start(k) = output_fields(out_num)%output_grid%l_start_indx(k)
1130 local_end(k) = output_fields(out_num)%output_grid%l_end_indx(k)
1131 local_siz(k) = local_end(k) - local_start(k) +1
1133 ALLOCATE(output_fields(out_num)%buffer(local_siz(1), local_siz(2), local_siz(3),&
1134 & output_fields(out_num)%n_diurnal_samples))
1135 IF(output_fields(out_num)%time_max)
THEN
1136 output_fields(out_num)%buffer = max_value
1137 ELSE IF(output_fields(out_num)%time_min)
THEN
1138 output_fields(out_num)%buffer = min_value
1140 output_fields(out_num)%buffer = empty
1142 output_fields(out_num)%region_elements = local_siz(1)*local_siz(2)*local_siz(3)
1143 output_fields(out_num)%total_elements = siz(1)*siz(2)*siz(3)
1144 files(output_fields(out_num)%output_file)%local = .true.
1148 ALLOCATE(output_fields(out_num)%buffer(siz(1), siz(2), siz(3),&
1149 & output_fields(out_num)%n_diurnal_samples))
1150 IF(output_fields(out_num)%time_max)
THEN
1151 output_fields(out_num)%buffer = max_value
1152 ELSE IF(output_fields(out_num)%time_min)
THEN
1153 output_fields(out_num)%buffer = min_value
1155 output_fields(out_num)%buffer = empty
1157 output_fields(out_num)%total_elements = siz(1)*siz(2)*siz(3)
1161 output_fields(out_num)%static = .true.
1163 IF ( .NOT.dynamic1 .AND. output_fields(out_num)%time_ops )
THEN
1164 WRITE (msg,
'(a,"/",a)') trim(module_name), trim(field_name)
1165 IF (
mpp_pe() .EQ. mpp_root_pe() )
THEN
1172 CALL error_mesg (
'diag_manager_mod::register_static_field_old',&
1173 &
'module/field '//trim(msg)//
' is STATIC. Cannot perform time operations&
1174 & average, maximum, or minimum on static fields. Setting the time operation&
1175 & to "NONE" for this field.', warning)
1177 output_fields(out_num)%time_ops = .false.
1178 output_fields(out_num)%time_average = .false.
1179 output_fields(out_num)%time_method =
'point'
1184 output_fields(out_num)%num_axes = input_fields(field)%num_axes
1186 IF ( .NOT.output_fields(out_num)%local_output )
THEN
1187 output_fields(out_num)%axes(1:input_fields(field)%num_axes) =&
1188 & input_fields(field)%axes(1:input_fields(field)%num_axes)
1190 output_fields(out_num)%axes(1:input_fields(field)%num_axes) =&
1191 & output_fields(out_num)%output_grid%subaxes(1:input_fields(field)%num_axes)
1196 IF ( output_fields(out_num)%n_diurnal_samples > 1 )
THEN
1197 output_fields(out_num)%axes(output_fields(out_num)%num_axes+1) =&
1199 output_fields(out_num)%num_axes = output_fields(out_num)%num_axes+1
1202 IF ( output_fields(out_num)%reduced_k_range )
THEN
1206 output_fields(out_num)%axes(2) = output_fields(out_num)%output_grid%subaxes(2)
1208 output_fields(out_num)%axes(3) = output_fields(out_num)%output_grid%subaxes(3)
1214 output_fields(out_num)%Time_of_prev_field_data = time_zero
1218 IF ( len_trim(msg).GT.0 )
THEN
1219 CALL error_mesg (
'diag_manager_mod::register_static_field_old',&
1220 & trim(msg)//
' for module/field '//trim(module_name)//
'/'//trim(field_name),&
1225 IF (
PRESENT(realm) )
THEN
1226 CALL prepend_attribute(output_fields(out_num),
'modeling_realm', lowercase(trim(realm)))
1230 IF ( input_fields(field)%mask_variant )
THEN
1231 DO j = 1, input_fields(field)%num_output_fields
1232 out_num = input_fields(field)%output_fields(j)
1233 IF(output_fields(out_num)%time_average)
THEN
1239 if (output_fields(out_num)%reduced_k_range .and. &
1241 allocate(output_fields(out_num)%counter(siz(1),local_siz(2),siz(3), &
1242 output_fields(out_num)%n_diurnal_samples))
1244 allocate(output_fields(out_num)%counter(siz(1),siz(2),siz(3), &
1245 output_fields(out_num)%n_diurnal_samples))
1248 output_fields(out_num)%counter = 0.0
1259 CHARACTER(len=*),
INTENT(in) :: module_name
1260 CHARACTER(len=*),
INTENT(in) :: field_name
1265 if (use_modern_diag)
then
1266 get_diag_field_id = fms_diag_object%fms_get_diag_field_id_from_name(module_name, field_name)
1277 INTEGER,
INTENT(in) :: field
1279 INTEGER,
INTENT(out) :: out_field_id
1280 INTEGER,
INTENT(out) :: out_file_id
1282 INTEGER :: i, cm_ind, cm_file_num
1286 rel_file = rel_field%output_file
1294 DO i = 1, input_fields(field)%num_output_fields
1295 cm_ind = input_fields(field)%output_fields(i)
1296 cm_file_num = output_fields(cm_ind)%output_file
1298 IF ( cm_file_num.EQ.rel_file.AND.&
1299 & (( (output_fields(cm_ind)%time_ops.EQV.rel_field%time_ops) .AND.&
1300 & (output_fields(cm_ind)%next_output.EQ.rel_field%next_output) .AND.&
1301 & (output_fields(cm_ind)%last_output.EQ.rel_field%last_output) ).OR.&
1302 & (output_fields(cm_ind)%static.OR.rel_field%static) ) )
THEN
1304 out_field_id = cm_ind
1305 out_file_id = cm_file_num
1312 DO i = 1, input_fields(field)%num_output_fields
1313 cm_ind = input_fields(field)%output_fields(i)
1314 cm_file_num = output_fields(cm_ind)%output_file
1325 IF ( output_fields(cm_ind)%static.OR.rel_field%static )
THEN
1327 out_field_id = cm_ind
1328 out_file_id = cm_file_num
1338 INTEGER,
INTENT(in),
OPTIONAL :: area
1339 INTEGER,
INTENT(in),
OPTIONAL :: volume
1340 CHARACTER(len=*),
INTENT(out),
OPTIONAL :: err_msg
1342 INTEGER :: cm_ind, cm_file_num, file_num
1344 IF (
PRESENT(err_msg) )
THEN
1349 IF (
PRESENT(area) )
THEN
1350 IF ( area.LE.0 )
THEN
1352 &
'AREA field not in diag_table for field '//trim(input_fields(output_field%input_field)%module_name)//&
1353 &
'/'//trim(input_fields(output_field%input_field)%field_name), err_msg) )
RETURN
1357 IF (
PRESENT(volume) )
THEN
1358 IF ( volume.LE.0 )
THEN
1360 &
'VOLUME field not in diag_table for field '//trim(input_fields(output_field%input_field)%module_name)//&
1361 &
'/'//trim(input_fields(output_field%input_field)%field_name), err_msg) )
RETURN
1366 file_num = output_field%output_file
1369 IF (
PRESENT(area) )
THEN
1372 &
'area: '//trim(output_fields(cm_ind)%output_name))
1373 IF ( cm_file_num.NE.file_num )
THEN
1379 &
'AREA measures field "'//trim(input_fields(area)%module_name)//
'/'//&
1380 & trim(input_fields(area)%field_name)//&
1381 &
'" NOT in diag_table with correct output frequency for field '//&
1382 & trim(input_fields(output_field%input_field)%module_name)//&
1383 &
'/'//trim(input_fields(output_field%input_field)%field_name), err_msg) )
RETURN
1388 IF (
PRESENT(volume) )
THEN
1391 &
'volume: '//trim(output_fields(cm_ind)%output_name))
1392 IF ( cm_file_num.NE.file_num )
THEN
1398 &
'VOLUME measures field "'//trim(input_fields(volume)%module_name)//
'/'//&
1399 & trim(input_fields(volume)%field_name)//&
1400 &
'" NOT in diag_table with correct output frequency for field '//&
1401 & trim(input_fields(output_field%input_field)%module_name)//&
1402 &
'/'//trim(input_fields(output_field%input_field)%field_name), err_msg) )
RETURN
1413 INTEGER,
intent(in) :: file_num
1414 INTEGER,
intent(in) :: cm_file_num
1415 INTEGER,
intent(in) :: cm_ind
1417 INTEGER :: year, month, day, hour, minute, second
1419 CHARACTER(len=25) :: date_prefix
1420 CHARACTER(len=FMS_FILE_LEN) :: asso_file_name
1423 IF ( prepend_date )
THEN
1424 CALL get_date(diag_init_time, year, month, day, hour, minute, second)
1425 WRITE (date_prefix,
'(1I20.4, 2I2.2,".")') year, month, day
1426 date_prefix=adjustl(date_prefix)
1434 IF ( len_trim(files(cm_file_num)%name)+17 > len(asso_file_name) )
THEN
1435 CALL error_mesg (
'diag_manager_mod::add_associated_files',&
1436 &
'Length of asso_file_name is not long enough to hold the associated file name. '&
1437 & //
'Contact the developer', fatal)
1439 asso_file_name = trim(files(cm_file_num)%name)
1450 n = max(len_trim(asso_file_name),3)
1451 if (asso_file_name(n-2:n).NE.
'.nc') asso_file_name = trim(asso_file_name)//
'.nc'
1455 & trim(output_fields(cm_ind)%output_name)//
': '//&
1456 & trim(date_prefix)//trim(asso_file_name))
1461 INTEGER,
INTENT(in) :: diag_field_id
1462 CLASS(*),
INTENT(in) :: field
1463 TYPE(
time_type),
INTENT(in),
OPTIONAL :: time
1464 CHARACTER(len=*),
INTENT(out),
OPTIONAL :: err_msg
1466 CLASS(*),
allocatable :: field_out(:, :, :)
1469 IF ( diag_field_id <= 0 )
THEN
1476 TYPE IS (real(kind=r4_kind))
1477 allocate(real(r4_kind) :: field_out(1,1,1))
1478 select type(field_out)
1479 type is (real(r4_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(r4_kind)', fatal)
1485 TYPE IS (real(kind=r8_kind))
1486 allocate(real(r8_kind) :: field_out(1,1,1))
1487 select type(field_out)
1488 type is (real(r8_kind))
1489 field_out(1, 1, 1) = field
1491 call error_mesg(
'diag_manager_mod::send_data_0d', &
1492 &
'Error allocating field out as real(r8_kind)', fatal)
1495 CALL error_mesg (
'diag_manager_mod::send_data_0d',&
1496 &
'The field is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
1503 LOGICAL FUNCTION send_data_1d(diag_field_id, field, time, is_in, mask, rmask, ie_in, weight, err_msg)
1504 INTEGER,
INTENT(in) :: diag_field_id
1505 CLASS(*),
DIMENSION(:),
INTENT(in) :: field
1506 CLASS(*),
INTENT(in),
OPTIONAL :: weight
1507 CLASS(*),
INTENT(in),
DIMENSION(:),
OPTIONAL :: rmask
1508 TYPE (
time_type),
INTENT(in),
OPTIONAL :: time
1509 INTEGER,
INTENT(in),
OPTIONAL :: is_in, ie_in
1510 LOGICAL,
INTENT(in),
DIMENSION(:),
OPTIONAL :: mask
1511 CHARACTER(len=*),
INTENT(out),
OPTIONAL :: err_msg
1513 CLASS(*),
ALLOCATABLE :: field_out(:,:,:)
1514 LOGICAL,
DIMENSION(SIZE(field(:)), 1, 1) :: mask_out
1517 IF ( diag_field_id <= 0 )
THEN
1525 TYPE IS (real(kind=r4_kind))
1526 allocate(real(r4_kind) :: field_out(
SIZE(field),1,1))
1527 select type(field_out)
1528 type is (real(r4_kind))
1529 field_out(:, 1, 1) = field
1531 call error_mesg(
'diag_manager_mod::send_data_1d', &
1532 &
'Error allocating field out as real(r4_kind)', fatal)
1534 TYPE IS (real(kind=r8_kind))
1535 allocate(real(r8_kind) :: field_out(
SIZE(field),1,1))
1536 select type(field_out)
1537 type is (real(r8_kind))
1538 field_out(:, 1, 1) = field
1540 call error_mesg(
'diag_manager_mod::send_data_1d', &
1541 &
'Error allocating field out as real(r8_kind)', fatal)
1544 CALL error_mesg (
'diag_manager_mod::send_data_1d',&
1545 &
'The field is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
1549 IF (
PRESENT(mask) )
THEN
1550 mask_out(:, 1, 1) = mask
1555 IF (
PRESENT(rmask) )
THEN
1557 TYPE IS (real(kind=r4_kind))
1558 WHERE (rmask < 0.5_r4_kind) mask_out(:, 1, 1) = .false.
1559 TYPE IS (real(kind=r8_kind))
1560 WHERE (rmask < 0.5_r8_kind) mask_out(:, 1, 1) = .false.
1562 CALL error_mesg (
'diag_manager_mod::send_data_1d',&
1563 &
'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
1567 IF (
PRESENT(mask) .OR.
PRESENT(rmask) )
THEN
1568 IF (
PRESENT(is_in) .OR.
PRESENT(ie_in) )
THEN
1570 & mask=mask_out, ie_in=ie_in, je_in=1, ke_in=1, weight=weight, err_msg=err_msg)
1573 & weight=weight, err_msg=err_msg)
1576 IF (
PRESENT(is_in) .OR.
PRESENT(ie_in) )
THEN
1578 & ie_in=ie_in, je_in=1, ke_in=1, weight=weight, err_msg=err_msg)
1587 & mask, rmask, ie_in, je_in, weight, err_msg)
1588 INTEGER,
INTENT(in) :: diag_field_id
1589 CLASS(*),
INTENT(in),
DIMENSION(:,:) :: field
1590 CLASS(*),
INTENT(in),
OPTIONAL :: weight
1591 TYPE (
time_type),
INTENT(in),
OPTIONAL :: time
1592 INTEGER,
INTENT(in),
OPTIONAL :: is_in, js_in, ie_in, je_in
1593 LOGICAL,
INTENT(in),
DIMENSION(:,:),
OPTIONAL :: mask
1594 CLASS(*),
INTENT(in),
DIMENSION(:,:),
OPTIONAL :: rmask
1595 CHARACTER(len=*),
INTENT(out),
OPTIONAL :: err_msg
1597 CLASS(*),
ALLOCATABLE :: field_out(:,:,:)
1598 LOGICAL,
DIMENSION(SIZE(field,1),SIZE(field,2),1) :: mask_out
1601 IF ( diag_field_id <= 0 )
THEN
1608 TYPE IS (real(kind=r4_kind))
1609 allocate(real(r4_kind) :: field_out(
SIZE(field,1),
SIZE(field,2),1))
1610 select type(field_out)
1611 type is (real(r4_kind))
1612 field_out(:, :, 1) = field
1614 call error_mesg(
'diag_manager_mod::send_data_2d', &
1615 &
'Error allocating field out as real(r4_kind)', fatal)
1617 TYPE IS (real(kind=r8_kind))
1618 allocate(real(r8_kind) :: field_out(
SIZE(field,1),
SIZE(field,2),1))
1619 select type(field_out)
1620 type is (real(r8_kind))
1621 field_out(:, :, 1) = field
1623 call error_mesg(
'diag_manager_mod::send_data_2d', &
1624 &
'Error allocating field out as real(r8_kind)', fatal)
1627 CALL error_mesg (
'diag_manager_mod::send_data_2d',&
1628 &
'The field is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
1632 IF (
PRESENT(mask) )
THEN
1633 mask_out(:, :, 1) = mask
1638 IF (
PRESENT(rmask) )
THEN
1640 TYPE IS (real(kind=r4_kind))
1641 WHERE ( rmask < 0.5_r4_kind ) mask_out(:, :, 1) = .false.
1642 TYPE IS (real(kind=r8_kind))
1643 WHERE ( rmask < 0.5_r8_kind ) mask_out(:, :, 1) = .false.
1645 CALL error_mesg (
'diag_manager_mod::send_data_2d',&
1646 &
'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
1650 IF (
PRESENT(mask) .OR.
PRESENT(rmask) )
THEN
1652 & mask=mask_out, ie_in=ie_in, je_in=je_in, ke_in=1, weight=weight, err_msg=err_msg)
1655 & ie_in=ie_in, je_in=je_in, ke_in=1, weight=weight, err_msg=err_msg)
1660 LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
1661 & mask, rmask, ie_in, je_in, ke_in, weight, err_msg)
1662 INTEGER,
INTENT(in) :: diag_field_id
1663 CLASS(*),
DIMENSION(:,:,:),
INTENT(in) :: field
1664 CLASS(*),
INTENT(in),
OPTIONAL :: weight
1665 TYPE (
time_type),
INTENT(in),
OPTIONAL :: time
1666 INTEGER,
INTENT(in),
OPTIONAL :: is_in, js_in, ks_in,ie_in,je_in, ke_in
1667 LOGICAL,
DIMENSION(:,:,:),
INTENT(in),
OPTIONAL :: mask
1668 CLASS(*),
DIMENSION(:,:,:),
INTENT(in),
OPTIONAL :: rmask
1669 CHARACTER(len=*),
INTENT(out),
OPTIONAL :: err_msg
1671 if (
present(mask) .and.
present(rmask))
then
1673 mask=mask, rmask=rmask, ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, &
1675 elseif (
present(rmask))
then
1677 rmask=rmask, ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, err_msg=err_msg)
1678 elseif (
present(mask))
then
1680 mask=mask, ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, err_msg=err_msg)
1683 ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, err_msg=err_msg)
1690 & mask, rmask, ie_in, je_in, ke_in, weight, err_msg)
1691 INTEGER,
INTENT(in) :: diag_field_id
1692 CLASS(*),
DIMENSION(:,:,:),
INTENT(in),
TARGET :: field
1693 CLASS(*),
INTENT(in),
OPTIONAL :: weight
1694 TYPE (
time_type),
INTENT(in),
OPTIONAL :: time
1695 INTEGER,
INTENT(in),
OPTIONAL :: is_in, js_in, ks_in,ie_in,je_in, ke_in
1696 LOGICAL,
DIMENSION(:,:,:),
INTENT(in),
OPTIONAL,
target :: mask
1697 CLASS(*),
DIMENSION(:,:,:),
INTENT(in),
OPTIONAL,
target :: rmask
1698 CHARACTER(len=*),
INTENT(out),
OPTIONAL :: err_msg
1702 INTEGER :: pow_value
1704 INTEGER :: i, out_num, file_num, n1, n2, n3, number_of_outputs, ii,f1,f2,f3,f4
1705 INTEGER :: freq, units, is, js, ks, ie, je, ke, i1, j1,k1, j, k
1706 INTEGER,
DIMENSION(3) :: l_start
1707 INTEGER,
DIMENSION(3) :: l_end
1717 INTEGER :: numthreads
1718 INTEGER :: active_omp_level
1719 #if defined(_OPENMP)
1720 INTEGER :: omp_get_num_threads
1721 INTEGER :: omp_get_level
1723 LOGICAL :: average, phys_window, need_compute
1724 LOGICAL :: reduced_k_range, local_output
1725 LOGICAL :: time_max, time_min, time_rms, time_sum
1726 LOGICAL :: missvalue_present
1727 LOGICAL,
ALLOCATABLE,
DIMENSION(:,:,:) :: oor_mask
1728 CHARACTER(len=256) :: err_msg_local
1729 CHARACTER(len=128) :: error_string, error_string1
1731 REAL,
ALLOCATABLE,
DIMENSION(:,:,:) :: field_out
1732 class(*),
allocatable,
dimension(:,:,:,:) :: field_remap
1733 logical,
allocatable,
dimension(:,:,:,:) :: mask_remap
1734 class(*),
allocatable,
dimension(:,:,:,:) :: rmask_remap
1735 REAL(kind=r4_kind),
POINTER,
DIMENSION(:,:,:) :: rmask_ptr_r4
1736 REAL(kind=r8_kind),
POINTER,
DIMENSION(:,:,:) :: rmask_ptr_r8
1740 LOGICAL :: mf_result
1742 REAL :: rmask_threshold
1744 character(len=:),
allocatable :: field_name
1747 IF ( diag_field_id <= 0 )
THEN
1754 IF (
PRESENT(err_msg) ) err_msg =
''
1755 IF ( .NOT.module_is_initialized )
THEN
1756 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d',
'diag_manager NOT initialized', err_msg) )
RETURN
1769 ALLOCATE(field_out(
SIZE(field,1),
SIZE(field,2),
SIZE(field,3)), stat=status)
1770 IF ( status .NE. 0 )
THEN
1771 WRITE (err_msg_local, fmt=
'("Unable to allocate field_out(",I5,",",I5,",",I5,"). (STAT: ",I5,")")')&
1772 &
SIZE(field,1),
SIZE(field,2),
SIZE(field,3), status
1773 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
RETURN
1776 TYPE IS (real(kind=r4_kind))
1778 TYPE IS (real(kind=r8_kind))
1779 field_out = real(field)
1781 CALL error_mesg (
'diag_manager_mod::send_data_3d',&
1782 &
'The field is not one of the supported types (real(kind=4) or real(kind=8)). '//&
1783 &
'If using an integer, please set use_modern_diag=.t. in the diag_manager_nml.', fatal)
1786 modern_if:
iF (use_modern_diag)
then
1787 field_name = fms_diag_object%fms_get_field_name_from_id(diag_field_id)
1788 call copy_3d_to_4d(field, field_remap, trim(field_name)//
"'s data")
1789 if (
present(rmask))
call copy_3d_to_4d(rmask, rmask_remap, trim(field_name)//
"'s mask")
1790 if (
present(mask))
then
1791 allocate(mask_remap(1:
size(mask,1), 1:
size(mask,2), 1:
size(mask,3), 1))
1792 mask_remap(:,:,:,1) = mask
1794 call fms_diag_object%fms_diag_accept_data(diag_field_id, field_remap, mask_remap, rmask_remap, &
1795 time, is_in, js_in, ks_in, ie_in, je_in, ke_in, weight, &
1797 deallocate (field_remap)
1798 if (
allocated(mask_remap))
deallocate(mask_remap)
1799 if (
allocated(rmask_remap))
deallocate(rmask_remap)
1802 ALLOCATE(oor_mask(
SIZE(field,1),
SIZE(field,2),
SIZE(field,3)), stat=status)
1803 IF ( status .NE. 0 )
THEN
1804 WRITE (err_msg_local, fmt=
'("Unable to allocate oor_mask(",I5,",",I5,",",I5,"). (STAT: ",I5,")")')&
1805 &
SIZE(field,1),
SIZE(field,2),
SIZE(field,3), status
1806 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
RETURN
1809 IF (
PRESENT(mask) )
THEN
1815 rmask_ptr_r4 => null()
1816 rmask_ptr_r8 => null()
1817 IF (
PRESENT(rmask) )
THEN
1819 TYPE IS (real(kind=r4_kind))
1820 WHERE ( rmask < 0.5_r4_kind ) oor_mask = .false.
1821 rmask_threshold = 0.5_r4_kind
1822 rmask_ptr_r4 => rmask
1823 TYPE IS (real(kind=r8_kind))
1824 WHERE ( rmask < 0.5_r8_kind ) oor_mask = .false.
1825 rmask_threshold = 0.5_r8_kind
1826 rmask_ptr_r8 => rmask
1828 CALL error_mesg (
'diag_manager_mod::send_data_3d',&
1829 &
'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
1844 IF (
PRESENT(ie_in) )
THEN
1845 IF ( .NOT.
PRESENT(is_in) )
THEN
1846 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d',
'ie_in present without is_in', err_msg) )
THEN
1847 DEALLOCATE(field_out)
1848 DEALLOCATE(oor_mask)
1852 IF (
PRESENT(js_in) .AND. .NOT.
PRESENT(je_in) )
THEN
1854 &
'is_in and ie_in present, but js_in present without je_in', err_msg) )
THEN
1855 DEALLOCATE(field_out)
1856 DEALLOCATE(oor_mask)
1861 IF (
PRESENT(je_in) )
THEN
1862 IF ( .NOT.
PRESENT(js_in) )
THEN
1863 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d',
'je_in present without js_in', err_msg) )
THEN
1864 DEALLOCATE(field_out)
1865 DEALLOCATE(oor_mask)
1869 IF (
PRESENT(is_in) .AND. .NOT.
PRESENT(ie_in) )
THEN
1871 &
'js_in and je_in present, but is_in present without ie_in', err_msg))
THEN
1872 DEALLOCATE(field_out)
1873 DEALLOCATE(oor_mask)
1883 IF (
PRESENT(is_in) ) is = is_in
1884 IF (
PRESENT(js_in) ) js = js_in
1885 IF (
PRESENT(ks_in) ) ks = ks_in
1892 IF (
PRESENT(ie_in) ) ie = ie_in
1893 IF (
PRESENT(je_in) ) je = je_in
1894 IF (
PRESENT(ke_in) ) ke = ke_in
1895 twohi = n1-(ie-is+1)
1896 IF ( mod(twohi,2) /= 0 )
THEN
1897 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d',
'non-symmetric halos in first dimension', &
1899 DEALLOCATE(field_out)
1900 DEALLOCATE(oor_mask)
1904 twohj = n2-(je-js+1)
1905 IF ( mod(twohj,2) /= 0 )
THEN
1906 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d',
'non-symmetric halos in second dimension', &
1908 DEALLOCATE(field_out)
1909 DEALLOCATE(oor_mask)
1918 IF (
PRESENT(ie_in) .AND.
PRESENT(je_in) )
THEN
1932 IF (
PRESENT(weight) )
THEN
1933 SELECT TYPE (weight)
1934 TYPE IS (real(kind=r4_kind))
1936 TYPE IS (real(kind=r8_kind))
1937 weight1 = real(weight)
1939 CALL error_mesg (
'diag_manager_mod::send_data_3d',&
1940 &
'The weight is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
1947 missvalue_present = input_fields(diag_field_id)%missing_value_present
1948 IF ( missvalue_present ) missvalue = input_fields(diag_field_id)%missing_value
1950 number_of_outputs = input_fields(diag_field_id)%num_output_fields
1952 input_fields(diag_field_id)%numthreads = 1
1954 #if defined(_OPENMP)
1955 input_fields(diag_field_id)%numthreads = omp_get_num_threads()
1956 input_fields(diag_field_id)%active_omp_level = omp_get_level()
1958 numthreads = input_fields(diag_field_id)%numthreads
1959 active_omp_level = input_fields(diag_field_id)%active_omp_level
1962 if(
present(time)) input_fields(diag_field_id)%time = time
1965 IF ( input_fields(diag_field_id)%range_present )
THEN
1966 IF ( issue_oor_warnings .OR. oor_warnings_fatal )
THEN
1967 WRITE (error_string,
'("[",ES14.5E3,",",ES14.5E3,"]")')&
1968 & input_fields(diag_field_id)%range(1:2)
1969 WRITE (error_string1,
'("(Min: ",ES14.5E3,", Max: ",ES14.5E3, ")")')&
1970 & minval(field_out(f1:f2,f3:f4,ks:ke),mask=oor_mask(f1:f2,f3:f4,ks:ke)),&
1971 & maxval(field_out(f1:f2,f3:f4,ks:ke),mask=oor_mask(f1:f2,f3:f4,ks:ke))
1972 IF ( missvalue_present )
THEN
1973 IF ( any(oor_mask(f1:f2,f3:f4,ks:ke) .AND.&
1974 & ((field_out(f1:f2,f3:f4,ks:ke) < input_fields(diag_field_id)%range(1) .OR.&
1975 & field_out(f1:f2,f3:f4,ks:ke) > input_fields(diag_field_id)%range(2)).AND.&
1976 & field_out(f1:f2,f3:f4,ks:ke) .NE. missvalue)) )
THEN
1982 CALL error_mesg(
'diag_manager_mod::send_data_3d',&
1984 &trim(input_fields(diag_field_id)%module_name)//
' in field '//&
1985 &trim(input_fields(diag_field_id)%field_name)//
' '&
1986 &//trim(error_string1)//&
1987 &
' is outside the range '//trim(error_string)//
',&
1988 & and not equal to the missing value.',&
1992 IF ( any(oor_mask(f1:f2,f3:f4,ks:ke) .AND.&
1993 & (field_out(f1:f2,f3:f4,ks:ke) < input_fields(diag_field_id)%range(1) .OR.&
1994 & field_out(f1:f2,f3:f4,ks:ke) > input_fields(diag_field_id)%range(2))) )
THEN
1999 CALL error_mesg(
'diag_manager_mod::send_data_3d',&
2001 &trim(input_fields(diag_field_id)%module_name)//
' in field '//&
2002 &trim(input_fields(diag_field_id)%field_name)//
' '&
2003 &//trim(error_string1)//&
2004 &
' is outside the range '//trim(error_string)//
'.',&
2012 num_out_fields:
DO ii = 1, number_of_outputs
2014 out_num = input_fields(diag_field_id)%output_fields(ii)
2017 local_output = output_fields(out_num)%local_output
2019 need_compute = output_fields(out_num)%need_compute
2021 reduced_k_range = output_fields(out_num)%reduced_k_range
2024 IF ( local_output .AND. (.NOT.need_compute) ) cycle
2027 file_num = output_fields(out_num)%output_file
2028 IF(file_num == max_files) cycle
2030 freq = files(file_num)%output_freq
2031 units = files(file_num)%output_units
2033 average = output_fields(out_num)%time_average
2036 time_rms = output_fields(out_num)%time_rms
2038 pow_value = output_fields(out_num)%pow_value
2040 time_max = output_fields(out_num)%time_max
2041 time_min = output_fields(out_num)%time_min
2043 time_sum = output_fields(out_num)%time_sum
2044 IF ( output_fields(out_num)%total_elements >
SIZE(field_out(f1:f2,f3:f4,ks:ke)) )
THEN
2045 output_fields(out_num)%phys_window = .true.
2047 output_fields(out_num)%phys_window = .false.
2049 phys_window = output_fields(out_num)%phys_window
2050 IF ( need_compute )
THEN
2051 l_start = output_fields(out_num)%output_grid%l_start_indx
2052 l_end = output_fields(out_num)%output_grid%l_end_indx
2057 IF (
PRESENT(time) )
THEN
2058 CALL get_time(time,second,day,tick)
2060 & * output_fields(out_num)%n_diurnal_samples/seconds_per_day) + 1
2064 IF ( reduced_k_range )
THEN
2067 if (output_fields(out_num)%reduced_k_unstruct)
then
2068 f3 = output_fields(out_num)%output_grid%l_start_indx(2)
2069 f4 = output_fields(out_num)%output_grid%l_end_indx(2)
2073 l_start(3) = output_fields(out_num)%output_grid%l_start_indx(3)
2074 l_end(3) = output_fields(out_num)%output_grid%l_end_indx(3)
2081 IF ( freq == every_time .AND. .NOT.output_fields(out_num)%static )
THEN
2082 IF (
PRESENT(time))
THEN
2083 IF ( numthreads .ne. 1 .or. active_omp_level .gt. 1)
THEN
2087 IF ( time > output_fields(out_num)%last_output )
THEN
2088 output_fields(out_num)%next_output = time
2094 IF ( output_fields(out_num)%next_output == output_fields(out_num)%last_output )
THEN
2095 output_fields(out_num)%next_output = time
2098 ELSE IF ( output_fields(out_num)%next_output == output_fields(out_num)%last_output )
THEN
2099 WRITE (error_string,
'(a,"/",a)')&
2100 & trim(input_fields(diag_field_id)%module_name),&
2101 & trim(output_fields(out_num)%output_name)
2102 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d',
'module/output_field '//trim(error_string)//&
2103 &
', time must be present when output frequency = EVERY_TIME', err_msg))
THEN
2104 DEALLOCATE(field_out)
2105 DEALLOCATE(oor_mask)
2110 IF ( .NOT.output_fields(out_num)%static .AND. .NOT.
PRESENT(time) )
THEN
2111 WRITE (error_string,
'(a,"/",a)')&
2112 & trim(input_fields(diag_field_id)%module_name), &
2113 & trim(output_fields(out_num)%output_name)
2114 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d',
'module/output_field '//trim(error_string)//&
2115 &
', time must be present for nonstatic field', err_msg))
THEN
2116 DEALLOCATE(field_out)
2117 DEALLOCATE(oor_mask)
2125 IF ( (numthreads == 1) .AND. (active_omp_level.LE.1) )
then
2126 IF ( .NOT.output_fields(out_num)%static .AND. freq /= end_of_run )
THEN
2127 IF ( time > output_fields(out_num)%next_output )
THEN
2129 IF ( time > output_fields(out_num)%next_next_output .AND. freq > 0 )
THEN
2130 IF (
mpp_pe() .EQ. mpp_root_pe() )
THEN
2131 WRITE (error_string,
'(a,"/",a)')&
2132 & trim(input_fields(diag_field_id)%module_name), &
2133 & trim(output_fields(out_num)%output_name)
2134 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d',
'module/output_field '//&
2135 & trim(error_string)//
' is skipped one time level in output data', err_msg))
THEN
2136 DEALLOCATE(field_out)
2137 DEALLOCATE(oor_mask)
2143 status =
writing_field(out_num, .false., error_string, time)
2144 IF(status == -1)
THEN
2145 IF (
mpp_pe() .EQ. mpp_root_pe() )
THEN
2146 IF(
fms_error_handler(
'diag_manager_mod::send_data_3d',
'module/output_field '//trim(error_string)&
2147 & //
', write EMPTY buffer', err_msg))
THEN
2148 DEALLOCATE(field_out)
2149 DEALLOCATE(oor_mask)
2159 if (
present(time))
then
2161 if (output_fields(out_num)%last_output > time) cycle
2164 IF ( .NOT.output_fields(out_num)%static .AND. .NOT.need_compute .AND. debug_diag_manager )
THEN
2166 IF ( err_msg_local /=
'' )
THEN
2167 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
2168 DEALLOCATE(field_out)
2169 DEALLOCATE(oor_mask)
2175 IF (use_refactored_send)
THEN
2176 ALLOCATE( ofield_index_cfg )
2177 CALL ofield_index_cfg%initialize( is, js, ks, ie, je, ke, &
2178 & hi, hj, f1, f2, f3, f4)
2180 ALLOCATE( ofield_cfg )
2181 CALL ofield_cfg%initialize( input_fields(diag_field_id), output_fields(out_num),
PRESENT(mask), freq)
2185 mf_result =
fieldbuff_update(ofield_cfg, ofield_index_cfg, field_out, sample, &
2186 & output_fields(out_num)%buffer, output_fields(out_num)%counter ,output_fields(out_num)%buff_bounds,&
2187 & output_fields(out_num)%count_0d(sample), output_fields(out_num)%num_elements(sample), &
2188 & mask, weight1 ,missvalue, &
2189 & input_fields(diag_field_id)%numthreads, input_fields(diag_field_id)%active_omp_level,&
2190 & input_fields(diag_field_id)%issued_mask_ignore_warning, &
2191 & l_start, l_end, err_msg, err_msg_local )
2192 IF (mf_result .eqv. .false.)
THEN
2193 DEALLOCATE(ofield_index_cfg)
2194 DEALLOCATE(ofield_cfg)
2195 DEALLOCATE(field_out)
2196 DEALLOCATE(oor_mask)
2201 & output_fields(out_num)%buffer, output_fields(out_num)%buff_bounds , &
2202 & output_fields(out_num)%count_0d(sample), &
2203 & mask, missvalue, l_start, l_end, err_msg, err_msg_local)
2204 IF (mf_result .eqv. .false.)
THEN
2205 DEALLOCATE(ofield_index_cfg)
2206 DEALLOCATE(ofield_cfg)
2207 DEALLOCATE(field_out)
2208 DEALLOCATE(oor_mask)
2213 IF ( output_fields(out_num)%static .AND. .NOT.need_compute .AND. debug_diag_manager )
THEN
2215 IF ( err_msg_local /=
'' )
THEN
2216 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg))
THEN
2217 DEALLOCATE(field_out)
2218 DEALLOCATE(oor_mask)
2245 IF(
ALLOCATED(ofield_index_cfg))
THEN
2246 DEALLOCATE(ofield_index_cfg)
2248 IF(
ALLOCATED(ofield_cfg))
THEN
2249 DEALLOCATE(ofield_cfg)
2256 IF ( input_fields(diag_field_id)%mask_variant )
THEN
2257 IF ( need_compute )
THEN
2258 WRITE (error_string,
'(a,"/",a)') &
2259 & trim(input_fields(diag_field_id)%module_name), &
2260 & trim(output_fields(out_num)%output_name)
2261 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d',
'module/output_field '//trim(error_string)//&
2262 &
', regional output NOT supported with mask_variant', err_msg))
THEN
2263 DEALLOCATE(field_out)
2264 DEALLOCATE(oor_mask)
2271 IF (
PRESENT(mask) )
THEN
2272 IF ( missvalue_present )
THEN
2273 IF ( debug_diag_manager )
THEN
2274 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
2276 IF ( err_msg_local /=
'' )
THEN
2277 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
2278 DEALLOCATE(field_out)
2279 DEALLOCATE(oor_mask)
2284 IF( numthreads>1 .AND. phys_window )
then
2285 IF ( reduced_k_range )
THEN
2290 IF ( mask(i-is+1+hi, j-js+1+hj, k) )
THEN
2291 IF ( pow_value /= 1 )
THEN
2292 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2293 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2294 & (field_out(i-is+1+hi, j-js+1+hj, k) * weight1)**(pow_value)
2296 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2297 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2298 & field_out(i-is+1+hi, j-js+1+hj, k) * weight1
2300 output_fields(out_num)%counter(i-hi,j-hj,k1,sample) =&
2301 & output_fields(out_num)%counter(i-hi,j-hj,k1,sample) + weight1
2310 IF ( mask(i-is+1+hi, j-js+1+hj, k) )
THEN
2311 IF ( pow_value /= 1 )
THEN
2312 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2313 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2314 & (field_out(i-is+1+hi,j-js+1+hj,k)*weight1)**(pow_value)
2316 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2317 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2318 & field_out(i-is+1+hi,j-js+1+hj,k)*weight1
2320 output_fields(out_num)%counter(i-hi,j-hj,k,sample) =&
2321 &output_fields(out_num)%counter(i-hi,j-hj,k,sample) + weight1
2329 IF ( reduced_k_range )
THEN
2334 IF ( mask(i-is+1+hi, j-js+1+hj, k) )
THEN
2335 IF ( pow_value /= 1 )
THEN
2336 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2337 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2338 & (field_out(i-is+1+hi, j-js+1+hj, k) * weight1)**(pow_value)
2340 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2341 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2342 & field_out(i-is+1+hi, j-js+1+hj, k) * weight1
2344 output_fields(out_num)%counter(i-hi,j-hj,k1,sample) =&
2345 & output_fields(out_num)%counter(i-hi,j-hj,k1,sample) + weight1
2354 IF ( mask(i-is+1+hi, j-js+1+hj, k) )
THEN
2355 IF ( pow_value /= 1 )
THEN
2356 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2357 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2358 & (field_out(i-is+1+hi,j-js+1+hj,k)*weight1)**(pow_value)
2360 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2361 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2362 & field_out(i-is+1+hi,j-js+1+hj,k)*weight1
2364 output_fields(out_num)%counter(i-hi,j-hj,k,sample) =&
2365 &output_fields(out_num)%counter(i-hi,j-hj,k,sample) + weight1
2374 WRITE (error_string,
'(a,"/",a)')&
2375 & trim(input_fields(diag_field_id)%module_name), &
2376 & trim(output_fields(out_num)%output_name)
2377 IF(
fms_error_handler(
'diag_manager_mod::send_data_3d',
'module/output_field '//trim(error_string)//&
2378 &
', variable mask but no missing value defined', err_msg))
THEN
2379 DEALLOCATE(field_out)
2380 DEALLOCATE(oor_mask)
2385 WRITE (error_string,
'(a,"/",a)')&
2386 & trim(input_fields(diag_field_id)%module_name), &
2387 & trim(output_fields(out_num)%output_name)
2388 IF(
fms_error_handler(
'diag_manager_mod::send_data_3d',
'module/output_field '//trim(error_string)//&
2389 &
', variable mask but no mask given', err_msg))
THEN
2390 DEALLOCATE(field_out)
2391 DEALLOCATE(oor_mask)
2396 IF (
PRESENT(mask) )
THEN
2397 IF ( missvalue_present )
THEN
2398 IF ( need_compute )
THEN
2399 IF (numthreads>1 .AND. phys_window)
then
2400 DO k = l_start(3), l_end(3)
2404 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2405 & j <= l_end(2)+hj )
THEN
2406 i1 = i-l_start(1)-hi+1
2407 j1= j-l_start(2)-hj+1
2408 IF ( mask(i-is+1+hi, j-js+1+hj, k) )
THEN
2409 IF ( pow_value /= 1 )
THEN
2410 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2411 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2412 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2414 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2415 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2416 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2419 output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
2427 DO k = l_start(3), l_end(3)
2431 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2432 & j <= l_end(2)+hj )
THEN
2433 i1 = i-l_start(1)-hi+1
2434 j1= j-l_start(2)-hj+1
2435 IF ( mask(i-is+1+hi, j-js+1+hj, k) )
THEN
2436 IF ( pow_value /= 1 )
THEN
2437 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2438 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2439 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2441 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2442 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2443 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2446 output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
2457 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2458 & j <= l_end(2)+hj )
THEN
2459 output_fields(out_num)%num_elements(sample) = &
2460 output_fields(out_num)%num_elements(sample) + l_end(3) - l_start(3) + 1
2465 ELSE IF ( reduced_k_range )
THEN
2466 IF (numthreads>1 .AND. phys_window)
then
2471 IF ( mask(i-is+1+hi,j-js+1+hj,k) )
THEN
2472 IF ( pow_value /= 1 )
THEN
2473 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2474 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2475 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2477 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2478 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2479 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2482 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue
2493 IF ( mask(i-is+1+hi,j-js+1+hj,k) )
THEN
2494 IF ( pow_value /= 1 )
THEN
2495 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2496 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2497 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2499 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2500 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2501 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2504 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue
2512 IF ( debug_diag_manager )
THEN
2513 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
2515 IF ( err_msg_local /=
'' )
THEN
2516 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
2517 DEALLOCATE(field_out)
2518 DEALLOCATE(oor_mask)
2523 IF (numthreads>1 .AND. phys_window)
then
2527 IF ( mask(i-is+1+hi,j-js+1+hj,k) )
THEN
2528 IF ( pow_value /= 1 )
THEN
2529 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2530 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2531 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2533 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2534 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2535 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2538 output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue
2548 IF ( mask(i-is+1+hi,j-js+1+hj,k) )
THEN
2549 IF ( pow_value /= 1 )
THEN
2550 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2551 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2552 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2554 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2555 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2556 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2559 output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue
2568 IF ( need_compute .AND. .NOT.phys_window )
THEN
2569 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))) ) &
2570 & output_fields(out_num)%count_0d(sample) =&
2571 & output_fields(out_num)%count_0d(sample) + weight1
2573 IF ( any(mask(f1:f2,f3:f4,ks:ke)) ) output_fields(out_num)%count_0d(sample) =&
2574 & output_fields(out_num)%count_0d(sample)+weight1
2579 IF ( (.NOT.all(mask(f1:f2,f3:f4,ks:ke)) .AND.
mpp_pe() .EQ. mpp_root_pe()).AND.&
2580 & .NOT.input_fields(diag_field_id)%issued_mask_ignore_warning )
THEN
2585 CALL error_mesg(
'diag_manager_mod::send_data_3d',&
2586 &
'Mask will be ignored since missing values were not specified for field '//&
2587 & trim(input_fields(diag_field_id)%field_name)//
' in module '//&
2588 & trim(input_fields(diag_field_id)%module_name), warning)
2589 input_fields(diag_field_id)%issued_mask_ignore_warning = .true.
2591 IF ( need_compute )
THEN
2592 IF (numthreads>1 .AND. phys_window)
then
2595 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2596 & j <= l_end(2)+hj )
THEN
2597 i1 = i-l_start(1)-hi+1
2598 j1 = j-l_start(2)-hj+1
2599 IF ( pow_value /= 1 )
THEN
2600 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2601 & output_fields(out_num)%buffer(i1,j1,:,sample)+ &
2602 & (field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value)
2604 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2605 & output_fields(out_num)%buffer(i1,j1,:,sample)+ &
2606 & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
2615 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2616 & j <= l_end(2)+hj )
THEN
2617 i1 = i-l_start(1)-hi+1
2618 j1 = j-l_start(2)-hj+1
2619 IF ( pow_value /= 1 )
THEN
2620 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2621 & output_fields(out_num)%buffer(i1,j1,:,sample)+ &
2622 & (field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value)
2624 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2625 & output_fields(out_num)%buffer(i1,j1,:,sample)+ &
2626 & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
2636 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2637 & j <= l_end(2)+hj )
THEN
2638 output_fields(out_num)%num_elements(sample)=&
2639 & output_fields(out_num)%num_elements(sample)+l_end(3)-l_start(3)+1
2645 ELSE IF ( reduced_k_range )
THEN
2646 IF (numthreads>1 .AND. phys_window)
then
2649 IF ( pow_value /= 1 )
THEN
2650 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2651 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) +&
2652 & (field_out(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value)
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
2662 IF ( pow_value /= 1 )
THEN
2663 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2664 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) +&
2665 & (field_out(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value)
2667 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2668 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) +&
2669 & field_out(f1:f2,f3:f4,ksr:ker)*weight1
2674 IF ( debug_diag_manager )
THEN
2675 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
2677 IF ( err_msg_local /=
'')
THEN
2678 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
2679 DEALLOCATE(field_out)
2680 DEALLOCATE(oor_mask)
2685 IF (numthreads>1 .AND. phys_window)
then
2686 IF ( pow_value /= 1 )
THEN
2687 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
2688 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
2689 & (field_out(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value)
2691 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
2692 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
2693 & field_out(f1:f2,f3:f4,ks:ke)*weight1
2697 IF ( pow_value /= 1 )
THEN
2698 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
2699 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
2700 & (field_out(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value)
2702 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
2703 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
2704 & field_out(f1:f2,f3:f4,ks:ke)*weight1
2710 IF ( .NOT.phys_window ) output_fields(out_num)%count_0d(sample) =&
2711 & output_fields(out_num)%count_0d(sample) + weight1
2715 IF ( missvalue_present )
THEN
2716 IF ( need_compute )
THEN
2717 if( numthreads>1 .AND. phys_window )
then
2718 DO k = l_start(3), l_end(3)
2719 k1 = k - l_start(3) + 1
2722 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2723 & j <= l_end(2)+hj)
THEN
2724 i1 = i-l_start(1)-hi+1
2725 j1= j-l_start(2)-hj+1
2726 IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue )
THEN
2727 IF ( pow_value /= 1 )
THEN
2728 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2729 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2730 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2732 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2733 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2734 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2737 output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
2745 DO k = l_start(3), l_end(3)
2746 k1 = k - l_start(3) + 1
2749 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2750 & j <= l_end(2)+hj)
THEN
2751 i1 = i-l_start(1)-hi+1
2752 j1= j-l_start(2)-hj+1
2753 IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue )
THEN
2754 IF ( pow_value /= 1 )
THEN
2755 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2756 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2757 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2759 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2760 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2761 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2764 output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
2775 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2776 & j <= l_end(2)+hj)
THEN
2777 output_fields(out_num)%num_elements(sample) =&
2778 & output_fields(out_num)%num_elements(sample) + l_end(3) - l_start(3) + 1
2782 IF ( .NOT.phys_window )
THEN
2783 outer0:
DO k = l_start(3), l_end(3)
2784 DO j=l_start(2)+hj, l_end(2)+hj
2785 DO i=l_start(1)+hi, l_end(1)+hi
2786 IF ( field_out(i,j,k) /= missvalue )
THEN
2787 output_fields(out_num)%count_0d(sample) = output_fields(out_num)%count_0d(sample)&
2796 ELSE IF ( reduced_k_range )
THEN
2797 if( numthreads>1 .AND. phys_window )
then
2804 IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue )
THEN
2805 IF ( pow_value /= 1 )
THEN
2806 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2807 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2808 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2810 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2811 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2812 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2815 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) = missvalue
2828 IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue )
THEN
2829 IF ( pow_value /= 1 )
THEN
2830 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2831 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2832 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2834 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2835 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2836 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2839 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) = missvalue
2847 outer3:
DO k = ksr, ker
2851 IF ( field_out(i,j,k) /= missvalue )
THEN
2852 output_fields(out_num)%count_0d(sample) = output_fields(out_num)%count_0d(sample) &
2861 IF ( debug_diag_manager )
THEN
2862 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
2864 IF ( err_msg_local /=
'' )
THEN
2865 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
2866 DEALLOCATE(field_out)
2867 DEALLOCATE(oor_mask)
2872 IF( numthreads > 1 .AND. phys_window )
then
2876 IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue )
THEN
2877 IF ( pow_value /= 1 )
THEN
2878 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2879 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2880 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2882 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2883 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2884 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2887 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) = missvalue
2897 IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue )
THEN
2898 IF ( pow_value /= 1 )
THEN
2899 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2900 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2901 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2903 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2904 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2905 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2908 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) = missvalue
2919 IF ( field_out(i,j,k) /= missvalue )
THEN
2920 output_fields(out_num)%count_0d(sample) = output_fields(out_num)%count_0d(sample) &
2930 IF ( need_compute )
THEN
2931 IF( numthreads > 1 .AND. phys_window )
then
2934 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2935 & j <= l_end(2)+hj )
THEN
2936 i1 = i-l_start(1)-hi+1
2937 j1= j-l_start(2)-hj+1
2938 IF ( pow_value /= 1 )
THEN
2939 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2940 & output_fields(out_num)%buffer(i1,j1,:,sample) +&
2941 & (field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value)
2943 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2944 & output_fields(out_num)%buffer(i1,j1,:,sample) +&
2945 & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
2954 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2955 & j <= l_end(2)+hj )
THEN
2956 i1 = i-l_start(1)-hi+1
2957 j1= j-l_start(2)-hj+1
2958 IF ( pow_value /= 1 )
THEN
2959 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2960 & output_fields(out_num)%buffer(i1,j1,:,sample) +&
2961 & (field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value)
2963 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2964 & output_fields(out_num)%buffer(i1,j1,:,sample) +&
2965 & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
2976 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2977 & j <= l_end(2)+hj )
THEN
2978 output_fields(out_num)%num_elements(sample) =&
2979 & output_fields(out_num)%num_elements(sample)+l_end(3)-l_start(3)+1
2985 ELSE IF ( reduced_k_range )
THEN
2988 IF( numthreads > 1 .AND. phys_window )
then
2989 IF ( pow_value /= 1 )
THEN
2990 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2991 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
2992 & (field_out(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value)
2994 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2995 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
2996 & field_out(f1:f2,f3:f4,ksr:ker)*weight1
3000 IF ( pow_value /= 1 )
THEN
3001 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
3002 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
3003 & (field_out(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value)
3005 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
3006 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
3007 & field_out(f1:f2,f3:f4,ksr:ker)*weight1
3012 IF ( debug_diag_manager )
THEN
3013 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3015 IF ( err_msg_local /=
'' )
THEN
3016 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3017 DEALLOCATE(field_out)
3018 DEALLOCATE(oor_mask)
3023 IF( numthreads > 1 .AND. phys_window )
then
3024 IF ( pow_value /= 1 )
THEN
3025 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
3026 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
3027 & (field_out(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value)
3029 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
3030 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
3031 & field_out(f1:f2,f3:f4,ks:ke)*weight1
3035 IF ( pow_value /= 1 )
THEN
3036 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
3037 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
3038 & (field_out(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value)
3040 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
3041 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
3042 & field_out(f1:f2,f3:f4,ks:ke)*weight1
3048 IF ( .NOT.phys_window ) output_fields(out_num)%count_0d(sample) =&
3049 & output_fields(out_num)%count_0d(sample) + weight1
3055 IF ( .NOT.need_compute .AND. .NOT.reduced_k_range )&
3056 & output_fields(out_num)%num_elements(sample) =&
3057 & output_fields(out_num)%num_elements(sample) + (ie-is+1)*(je-js+1)*(ke-ks+1)
3058 IF ( reduced_k_range ) &
3059 & output_fields(out_num)%num_elements(sample) = output_fields(out_num)%num_elements(sample) +&
3060 & (ie-is+1)*(je-js+1)*(ker-ksr+1)
3063 ELSE IF ( time_max )
THEN
3064 IF (
PRESENT(mask) )
THEN
3065 IF ( need_compute )
THEN
3066 DO k = l_start(3), l_end(3)
3067 k1 = k - l_start(3) + 1
3070 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
3071 & j <= l_end(2)+hj )
THEN
3072 i1 = i-l_start(1)-hi+1
3073 j1= j-l_start(2)-hj+1
3074 IF ( mask(i-is+1+hi,j-js+1+hj,k) .AND. field_out(i-is+1+hi,j-js+1+hj,k)>&
3075 & output_fields(out_num)%buffer(i1,j1,k1,sample) )
THEN
3076 output_fields(out_num)%buffer(i1,j1,k1,sample) = field_out(i-is+1+hi,j-js+1+hj,k)
3083 ELSE IF ( reduced_k_range )
THEN
3086 WHERE ( mask(f1:f2,f3:f4,ksr:ker) .AND. field_out(f1:f2,f3:f4,ksr:ker) >&
3087 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) )&
3088 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker)
3090 IF ( debug_diag_manager )
THEN
3091 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3093 IF ( err_msg_local /=
'' )
THEN
3094 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3095 DEALLOCATE(field_out)
3096 DEALLOCATE(oor_mask)
3101 WHERE ( mask(f1:f2,f3:f4,ks:ke) .AND. field_out(f1:f2,f3:f4,ks:ke)>&
3102 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) )&
3103 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke)
3106 IF ( need_compute )
THEN
3107 DO k = l_start(3), l_end(3)
3108 k1 = k - l_start(3) + 1
3111 IF(l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
3112 & j <= l_end(2)+hj )
THEN
3113 i1 = i-l_start(1)-hi+1
3114 j1 = j-l_start(2)-hj+1
3115 IF ( field_out(i-is+1+hi,j-js+1+hj,k)>output_fields(out_num)%buffer(i1,j1,k1,sample) )
THEN
3116 output_fields(out_num)%buffer(i1,j1,k1,sample) = field_out(i-is+1+hi,j-js+1+hj,k)
3123 ELSE IF ( reduced_k_range )
THEN
3126 WHERE ( field_out(f1:f2,f3:f4,ksr:ker) >&
3127 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) ) &
3128 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker)
3130 IF ( debug_diag_manager )
THEN
3131 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3133 IF ( err_msg_local /=
'' )
THEN
3134 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3135 DEALLOCATE(field_out)
3136 DEALLOCATE(oor_mask)
3141 WHERE ( field_out(f1:f2,f3:f4,ks:ke) >&
3142 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) ) &
3143 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke)
3146 output_fields(out_num)%count_0d(sample) = 1
3147 ELSE IF ( time_min )
THEN
3148 IF (
PRESENT(mask) )
THEN
3149 IF ( need_compute )
THEN
3150 DO k = l_start(3), l_end(3)
3151 k1 = k - l_start(3) + 1
3154 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
3155 & j <= l_end(2)+hj )
THEN
3156 i1 = i-l_start(1)-hi+1
3157 j1 = j-l_start(2)-hj+1
3158 IF ( mask(i-is+1+hi,j-js+1+hj,k) .AND. field_out(i-is+1+hi,j-js+1+hj,k) <&
3159 & output_fields(out_num)%buffer(i1,j1,k1,sample) )
THEN
3160 output_fields(out_num)%buffer(i1,j1,k1,sample) = field_out(i-is+1+hi,j-js+1+hj,k)
3167 ELSE IF ( reduced_k_range )
THEN
3170 WHERE ( mask(f1:f2,f3:f4,ksr:ker) .AND. field_out(f1:f2,f3:f4,ksr:ker) <&
3171 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) ) &
3172 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker)
3174 IF ( debug_diag_manager )
THEN
3175 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3177 IF ( err_msg_local /=
'' )
THEN
3178 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3179 DEALLOCATE(field_out)
3180 DEALLOCATE(oor_mask)
3185 WHERE ( mask(f1:f2,f3:f4,ks:ke) .AND. field_out(f1:f2,f3:f4,ks:ke) <&
3186 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) ) &
3187 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke)
3190 IF ( need_compute )
THEN
3191 DO k = l_start(3), l_end(3)
3192 k1 = k - l_start(3) + 1
3195 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
3196 i1 = i-l_start(1)-hi+1
3197 j1= j-l_start(2)-hj+1
3198 IF ( field_out(i-is+1+hi,j-js+1+hj,k) <&
3199 & output_fields(out_num)%buffer(i1,j1,k1,sample) )
THEN
3200 output_fields(out_num)%buffer(i1,j1,k1,sample) = field_out(i-is+1+hi,j-js+1+hj,k)
3207 ELSE IF ( reduced_k_range )
THEN
3210 WHERE ( field_out(f1:f2,f3:f4,ksr:ker) <&
3211 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) ) &
3212 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker)
3214 IF ( debug_diag_manager )
THEN
3215 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3217 IF ( err_msg_local /=
'' )
THEN
3218 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3219 DEALLOCATE(field_out)
3220 DEALLOCATE(oor_mask)
3225 WHERE ( field_out(f1:f2,f3:f4,ks:ke) <&
3226 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) )&
3227 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke)
3230 output_fields(out_num)%count_0d(sample) = 1
3231 ELSE IF ( time_sum )
THEN
3232 IF (
PRESENT(mask) )
THEN
3233 IF ( need_compute )
THEN
3234 DO k = l_start(3), l_end(3)
3235 k1 = k - l_start(3) + 1
3238 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
3239 & j <= l_end(2)+hj )
THEN
3240 i1 = i-l_start(1)-hi+1
3241 j1 = j-l_start(2)-hj+1
3242 IF ( mask(i-is+1+hi,j-js+1+hj,k) )
THEN
3243 output_fields(out_num)%buffer(i1,j1,k1,sample) = &
3244 output_fields(out_num)%buffer(i1,j1,k1,sample) + &
3245 field_out(i-is+1+hi,j-js+1+hj,k)
3252 ELSE IF ( reduced_k_range )
THEN
3255 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = &
3256 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
3257 & field_out(f1:f2,f3:f4,ksr:ker)
3259 IF ( debug_diag_manager )
THEN
3260 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3262 IF ( err_msg_local /=
'' )
THEN
3263 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3264 DEALLOCATE(field_out)
3265 DEALLOCATE(oor_mask)
3270 WHERE ( mask(f1:f2,f3:f4,ks:ke) ) &
3271 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = &
3272 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) + &
3273 & field_out(f1:f2,f3:f4,ks:ke)
3276 IF ( need_compute )
THEN
3277 DO k = l_start(3), l_end(3)
3278 k1 = k - l_start(3) + 1
3281 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
3282 i1 = i-l_start(1)-hi+1
3283 j1= j-l_start(2)-hj+1
3284 output_fields(out_num)%buffer(i1,j1,k1,sample) = &
3285 & output_fields(out_num)%buffer(i1,j1,k1,sample) + &
3286 & field_out(i-is+1+hi,j-js+1+hj,k)
3291 ELSE IF ( reduced_k_range )
THEN
3294 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = &
3295 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
3296 & field_out(f1:f2,f3:f4,ksr:ker)
3298 IF ( debug_diag_manager )
THEN
3299 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3301 IF ( err_msg_local /=
'' )
THEN
3302 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3303 DEALLOCATE(field_out)
3304 DEALLOCATE(oor_mask)
3309 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = &
3310 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) + &
3311 & field_out(f1:f2,f3:f4,ks:ke)
3314 output_fields(out_num)%count_0d(sample) = 1
3316 output_fields(out_num)%count_0d(sample) = 1
3317 IF ( need_compute )
THEN
3320 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
3321 i1 = i-l_start(1)-hi+1
3322 j1 = j-l_start(2)-hj+1
3323 output_fields(out_num)%buffer(i1,j1,:,sample) =&
3324 & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))
3329 ELSE IF ( reduced_k_range )
THEN
3332 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker)
3334 IF ( debug_diag_manager )
THEN
3335 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3337 IF ( err_msg_local /=
'' )
THEN
3338 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3339 DEALLOCATE(field_out)
3340 DEALLOCATE(oor_mask)
3345 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke)
3348 IF (
PRESENT(mask) .AND. missvalue_present )
THEN
3349 IF ( need_compute )
THEN
3350 DO k = l_start(3), l_end(3)
3351 k1 = k - l_start(3) + 1
3354 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
3355 & j <= l_end(2)+hj )
THEN
3356 i1 = i-l_start(1)-hi+1
3357 j1 = j-l_start(2)-hj+1
3358 IF ( .NOT.mask(i-is+1+hi,j-js+1+hj,k) )&
3359 & output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
3364 ELSE IF ( reduced_k_range )
THEN
3371 IF ( .NOT.mask(i-is+1+hi,j-js+1+hj,k) ) &
3372 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue
3380 IF ( .NOT.mask(i-is+1+hi,j-js+1+hj,k) )&
3381 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue
3389 IF ( output_fields(out_num)%static .AND. .NOT.need_compute .AND. debug_diag_manager )
THEN
3391 IF ( err_msg_local /=
'' )
THEN
3392 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg))
THEN
3393 DEALLOCATE(field_out)
3394 DEALLOCATE(oor_mask)
3403 IF (
PRESENT(rmask) .AND. missvalue_present )
THEN
3404 IF ( need_compute )
THEN
3406 TYPE IS (real(kind=r4_kind))
3407 DO k = l_start(3), l_end(3)
3408 k1 = k - l_start(3) + 1
3411 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND.&
3412 & j <= l_end(2)+hj )
THEN
3413 i1 = i-l_start(1)-hi+1
3414 j1 = j-l_start(2)-hj+1
3415 IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r4_kind ) &
3416 & output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
3421 TYPE IS (real(kind=r8_kind))
3422 DO k = l_start(3), l_end(3)
3423 k1 = k - l_start(3) + 1
3426 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND.&
3427 & j <= l_end(2)+hj )
THEN
3428 i1 = i-l_start(1)-hi+1
3429 j1 = j-l_start(2)-hj+1
3430 IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r8_kind ) &
3431 & output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
3437 CALL error_mesg (
'diag_manager_mod::send_data_3d',&
3438 &
'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
3440 ELSE IF ( reduced_k_range )
THEN
3444 TYPE IS (real(kind=r4_kind))
3449 IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r4_kind ) &
3450 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue
3454 TYPE IS (real(kind=r8_kind))
3459 IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r8_kind ) &
3460 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue
3465 CALL error_mesg (
'diag_manager_mod::send_data_3d',&
3466 &
'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
3470 TYPE IS (real(kind=r4_kind))
3474 IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r4_kind ) &
3475 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue
3479 TYPE IS (real(kind=r8_kind))
3483 IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r8_kind ) &
3484 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue
3489 CALL error_mesg (
'diag_manager_mod::send_data_3d',&
3490 &
'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
3495 END DO num_out_fields
3497 DEALLOCATE(field_out)
3498 DEALLOCATE(oor_mask)
3504 LOGICAL FUNCTION send_data_4d(diag_field_id, field, time, is_in, js_in, ks_in, &
3505 & mask, rmask, ie_in, je_in, ke_in, weight, err_msg)
3506 INTEGER,
INTENT(in) :: diag_field_id
3507 CLASS(*),
INTENT(in) :: field(:,:,:,:)
3508 CLASS(*),
INTENT(in),
OPTIONAL :: weight
3509 TYPE (
time_type),
INTENT(in),
OPTIONAL :: time
3510 INTEGER,
INTENT(in),
OPTIONAL :: is_in
3511 INTEGER,
INTENT(in),
OPTIONAL :: js_in
3512 INTEGER,
INTENT(in),
OPTIONAL :: ks_in
3513 INTEGER,
INTENT(in),
OPTIONAL :: ie_in
3514 INTEGER,
INTENT(in),
OPTIONAL :: je_in
3515 INTEGER,
INTENT(in),
OPTIONAL :: ke_in
3516 LOGICAL,
INTENT(in),
OPTIONAL :: mask(:,:,:,:)
3517 CLASS(*),
INTENT(in),
OPTIONAL :: rmask(:,:,:,:)
3518 CHARACTER(len=*),
INTENT(out),
OPTIONAL :: err_msg
3521 class(*),
allocatable :: rmask_local(:,:,:,:)
3522 logical,
allocatable :: mask_local(:,:,:,:)
3525 IF ( diag_field_id <= 0 )
THEN
3530 if (.not. use_modern_diag) &
3531 call mpp_error(fatal,
"Send_data_4d is only supported when diag_manager_nml::use_modern_diag=.true.")
3534 if (
present(mask)) mask_local = mask
3535 if (
present(rmask)) rmask_local = rmask
3537 call fms_diag_object%fms_diag_accept_data(diag_field_id, field, mask_local, rmask_local, &
3538 time, is_in, js_in, ks_in, ie_in, je_in, ke_in, weight, &
3542 if (
present(err_msg))
then
3543 if (err_msg .ne.
"")
then
3550 if (
allocated(rmask_local))
deallocate(rmask_local)
3551 if (
allocated(mask_local))
deallocate(mask_local)
3556 INTEGER,
INTENT(in) :: id
3557 REAL,
INTENT(in) :: field(:,:)
3558 REAL,
INTENT(in) :: area (:,:)
3560 LOGICAL,
INTENT(in),
OPTIONAL :: mask (:,:)
3562 REAL,
DIMENSION(SIZE(field,1)) :: out(size(field,1))
3576 INTEGER,
INTENT(in) :: diag_field_id
3577 REAL,
DIMENSION(:,:),
INTENT(in) :: x
3578 REAL,
DIMENSION(:,:),
INTENT(in) :: area
3579 LOGICAL,
DIMENSION(:,:),
INTENT(in) :: mask
3580 REAL,
DIMENSION(:),
INTENT(out) :: out
3583 REAL,
DIMENSION(SIZE(x,1)) :: s
3584 REAL :: local_missing_value
3588 IF ( diag_field_id <= 0 )
THEN
3592 CALL error_mesg(
'diag_manager_mod::average_tiles1d',&
3593 &
"diag_field_id less than 0. Contact developers.", fatal)
3597 IF ( input_fields(diag_field_id)%missing_value_present )
THEN
3598 local_missing_value = input_fields(diag_field_id)%missing_value
3600 local_missing_value = 0.0
3607 DO it = 1,
SIZE(area,dim=2)
3608 WHERE ( mask(:,it) )
3609 out(:) = out(:) + x(:,it)*area(:,it)
3610 s(:) = s(:) + area(:,it)
3615 out(:) = out(:)/s(:)
3617 out(:) = local_missing_value
3623 INTEGER,
INTENT(in) :: id
3624 REAL,
INTENT(in) :: field(:,:,:)
3625 REAL,
INTENT(in) :: area (:,:,:)
3627 LOGICAL,
INTENT(in),
OPTIONAL :: mask (:,:,:)
3629 REAL,
DIMENSION(SIZE(field,1),SIZE(field,2)) :: out(size(field,1), size(field,2))
3643 INTEGER,
INTENT(in) :: id
3644 REAL,
DIMENSION(:,:,:,:),
INTENT(in) :: field
3645 REAL,
DIMENSION(:,:,:),
INTENT(in) :: area (:,:,:)
3648 LOGICAL,
DIMENSION(:,:,:),
INTENT(in),
OPTIONAL :: mask
3650 REAL,
DIMENSION(SIZE(field,1),SIZE(field,2),SIZE(field,4)) :: out
3651 LOGICAL,
DIMENSION(SIZE(field,1),SIZE(field,2),SIZE(field,4)) :: mask3
3660 DO it=1,
SIZE(field,4)
3661 CALL average_tiles(id, field(:,:,:,it), area, mask, out(:,:,it) )
3664 mask3(:,:,1) = any(mask,dim=3)
3665 DO it = 2,
SIZE(field,4)
3666 mask3(:,:,it) = mask3(:,:,1)
3674 INTEGER,
INTENT(in) :: diag_field_id
3675 REAL,
DIMENSION(:,:,:),
INTENT(in) :: x
3676 REAL,
DIMENSION(:,:,:),
INTENT(in) :: area
3677 LOGICAL,
DIMENSION(:,:,:),
INTENT(in) :: mask
3678 REAL,
DIMENSION(:,:),
INTENT(out) :: out
3681 REAL,
DIMENSION(SIZE(x,1),SIZE(x,2)) :: s
3682 REAL :: local_missing_value
3686 IF ( diag_field_id <= 0 )
THEN
3690 CALL error_mesg(
'diag_manager_mod::average_tiles',&
3691 &
"diag_field_id less than 0. Contact developers.", fatal)
3695 IF ( input_fields(diag_field_id)%missing_value_present )
THEN
3696 local_missing_value = input_fields(diag_field_id)%missing_value
3698 local_missing_value = 0.0
3705 DO it = 1,
SIZE(area,3)
3706 WHERE ( mask(:,:,it) )
3707 out(:,:) = out(:,:) + x(:,:,it)*area(:,:,it)
3708 s(:,:) = s(:,:) + area(:,:,it)
3712 WHERE ( s(:,:) > 0 )
3713 out(:,:) = out(:,:)/s(:,:)
3715 out(:,:) = local_missing_value
3721 INTEGER,
INTENT(in) :: out_num
3722 LOGICAL,
INTENT(in) :: at_diag_end
3723 CHARACTER(len=*),
INTENT(out) :: error_string
3728 LOGICAL :: time_max, time_min, reduced_k_range, missvalue_present
3729 LOGICAL :: average, time_rms, need_compute, phys_window
3730 INTEGER :: in_num, file_num, freq, units
3731 INTEGER :: b1,b2,b3,b4
3732 INTEGER :: i, j, k, m
3733 REAL :: missvalue, num
3736 need_compute = output_fields(out_num)%need_compute
3738 in_num = output_fields(out_num)%input_field
3739 IF ( input_fields(in_num)%static )
RETURN
3741 missvalue = input_fields(in_num)%missing_value
3742 missvalue_present = input_fields(in_num)%missing_value_present
3743 reduced_k_range = output_fields(out_num)%reduced_k_range
3744 phys_window = output_fields(out_num)%phys_window
3746 average = output_fields(out_num)%time_average
3749 time_rms = output_fields(out_num)%time_rms
3751 time_max = output_fields(out_num)%time_max
3752 time_min = output_fields(out_num)%time_min
3753 file_num = output_fields(out_num)%output_file
3754 freq = files(file_num)%output_freq
3755 units = files(file_num)%output_units
3759 b1=
SIZE(output_fields(out_num)%buffer,1)
3760 b2=
SIZE(output_fields(out_num)%buffer,2)
3761 b3=
SIZE(output_fields(out_num)%buffer,3)
3762 b4=
SIZE(output_fields(out_num)%buffer,4)
3763 IF ( input_fields(in_num)%mask_variant )
THEN
3768 IF ( output_fields(out_num)%counter(i,j,k,m) > 0. )
THEN
3769 output_fields(out_num)%buffer(i,j,k,m) = &
3770 & output_fields(out_num)%buffer(i,j,k,m)/output_fields(out_num)%counter(i,j,k,m)
3771 IF ( time_rms ) output_fields(out_num)%buffer(i,j,k,m) = &
3772 sqrt(output_fields(out_num)%buffer(i,j,k,m))
3774 output_fields(out_num)%buffer(i,j,k,m) = missvalue
3782 IF ( phys_window )
THEN
3783 IF ( need_compute .OR. reduced_k_range )
THEN
3784 num = real(output_fields(out_num)%num_elements(m)/output_fields(out_num)%region_elements)
3786 num = real(output_fields(out_num)%num_elements(m)/output_fields(out_num)%total_elements)
3789 num = output_fields(out_num)%count_0d(m)
3791 IF ( num > 0. )
THEN
3792 IF ( missvalue_present )
THEN
3796 IF ( output_fields(out_num)%buffer(i,j,k,m) /= missvalue )
THEN
3797 output_fields(out_num)%buffer(i,j,k,m) = output_fields(out_num)%buffer(i,j,k,m)/num
3798 IF ( time_rms ) output_fields(out_num)%buffer(i,j,k,m) =&
3799 & sqrt(output_fields(out_num)%buffer(i,j,k,m))
3805 output_fields(out_num)%buffer(:,:,:,m) = output_fields(out_num)%buffer(:,:,:,m)/num
3806 IF ( time_rms ) output_fields(out_num)%buffer(:,:,:,m) =&
3807 & sqrt(output_fields(out_num)%buffer(:,:,:,m))
3809 ELSE IF ( .NOT. at_diag_end )
THEN
3810 IF ( missvalue_present )
THEN
3811 IF(any(output_fields(out_num)%buffer /= missvalue))
THEN
3812 WRITE (error_string,
'(a,"/",a)')&
3813 & trim(input_fields(in_num)%module_name), &
3814 & trim(output_fields(out_num)%output_name)
3822 ELSE IF ( time_min .OR. time_max )
THEN
3823 IF ( missvalue_present )
THEN
3824 WHERE ( abs(output_fields(out_num)%buffer) == min_value )
3825 output_fields(out_num)%buffer = missvalue
3831 IF ( at_diag_end .AND. freq == end_of_run ) output_fields(out_num)%next_output = time
3833 IF ( (output_fields(out_num)%time_ops) .AND. (.NOT. mix_snapshot_average_fields) )
THEN
3834 middle_time = (output_fields(out_num)%last_output+output_fields(out_num)%next_output)/2
3835 if (trim(files(file_num)%filename_time_bounds) ==
"begin")
then
3836 filename_time = output_fields(out_num)%last_output
3837 elseif (trim(files(file_num)%filename_time_bounds) ==
"middle")
then
3838 filename_time = middle_time
3839 elseif (trim(files(file_num)%filename_time_bounds) ==
"end")
then
3840 filename_time = output_fields(out_num)%next_output
3843 CALL diag_data_out(file_num, out_num, output_fields(out_num)%buffer, middle_time, &
3844 & filename_time=filename_time)
3847 & output_fields(out_num)%buffer, output_fields(out_num)%next_output)
3851 IF ( at_diag_end )
RETURN
3854 output_fields(out_num)%last_output = output_fields(out_num)%next_output
3855 IF ( freq == end_of_run )
THEN
3856 output_fields(out_num)%next_output = time
3858 IF ( freq == every_time )
THEN
3859 output_fields(out_num)%next_output = time
3861 output_fields(out_num)%next_output = output_fields(out_num)%next_next_output
3862 output_fields(out_num)%next_next_output = &
3863 & diag_time_inc(output_fields(out_num)%next_next_output, freq, units)
3865 output_fields(out_num)%count_0d(:) = 0.0
3866 output_fields(out_num)%num_elements(:) = 0
3867 IF ( time_max )
THEN
3868 output_fields(out_num)%buffer = max_value
3869 ELSE IF ( time_min )
THEN
3870 output_fields(out_num)%buffer = min_value
3872 output_fields(out_num)%buffer = empty
3874 IF ( input_fields(in_num)%mask_variant .AND. average ) output_fields(out_num)%counter = 0.0
3878 SUBROUTINE diag_manager_set_time_end(Time_end_in)
3879 TYPE (
time_type),
INTENT(in) :: time_end_in
3881 time_end = time_end_in
3882 if (use_modern_diag)
then
3883 call fms_diag_object%set_time_end(time_end_in)
3886 END SUBROUTINE diag_manager_set_time_end
3901 integer :: file, j, freq, in_num, file_num, out_num
3903 DO file = 1, num_files
3904 freq = files(file)%output_freq
3906 DO j = 1, files(file)%num_fields
3907 out_num = files(file)%fields(j)
3908 in_num = output_fields(out_num)%input_field
3909 IF ( (input_fields(in_num)%numthreads == 1) .AND.&
3910 & (input_fields(in_num)%active_omp_level.LE.1) ) cycle
3911 file_num = output_fields(out_num)%output_file
3913 & output_fields(out_num)%buffer, time)
3922 TYPE (
time_type),
INTENT(in) :: time_step
3923 character(len=*),
INTENT(out),
optional :: err_msg
3926 integer :: file, j, out_num, in_num, freq, status
3927 logical :: local_output, need_compute
3928 CHARACTER(len=128) :: error_string
3930 IF ( time_end == time_zero )
THEN
3934 CALL error_mesg(
'diag_manager_mod::diag_send_complete',&
3935 &
"diag_manager_set_time_end must be called before diag_send_complete", fatal)
3938 if (use_modern_diag)
then
3939 call fms_diag_object%fms_diag_send_complete(time_step)
3943 DO file = 1, num_files
3944 freq = files(file)%output_freq
3945 DO j = 1, files(file)%num_fields
3946 out_num = files(file)%fields(j)
3947 in_num = output_fields(out_num)%input_field
3949 IF ( (input_fields(in_num)%numthreads == 1) .AND. (input_fields(in_num)%active_omp_level.LE.1) ) cycle
3950 IF ( output_fields(out_num)%static .OR. freq == end_of_run ) cycle
3951 time = input_fields(in_num)%time
3952 IF ( time >= time_end ) cycle
3955 local_output = output_fields(out_num)%local_output
3957 need_compute = output_fields(out_num)%need_compute
3959 IF ( local_output .AND. (.NOT.need_compute) ) cycle
3960 next_time = time + time_step
3962 IF ( next_time > output_fields(out_num)%next_output )
THEN
3964 IF ( next_time > output_fields(out_num)%next_next_output .AND. freq > 0 )
THEN
3965 IF (
mpp_pe() .EQ. mpp_root_pe() )
THEN
3966 WRITE (error_string,
'(a,"/",a)')&
3967 & trim(input_fields(in_num)%module_name), &
3968 & trim(output_fields(out_num)%output_name)
3970 &
'module/output_field '//trim(error_string)//&
3971 &
' is skipped one time level in output data', err_msg))
RETURN
3975 status =
writing_field(out_num, .false., error_string, next_time)
3976 IF ( status == -1 )
THEN
3977 IF (
mpp_pe() .EQ. mpp_root_pe() )
THEN
3978 IF(
fms_error_handler(
'diag_manager_mod::diag_send_complete',
'module/output_field '//&
3979 & trim(error_string)//
', write EMPTY buffer', err_msg))
RETURN
3995 IF ( do_diag_field_log )
THEN
3996 close (diag_log_unit)
3998 DO file = 1, num_files
4001 if (
allocated(fileobju))
deallocate(fileobju)
4002 if (
allocated(fileobj))
deallocate(fileobj)
4003 if (
allocated(fileobjnd))
deallocate(fileobjnd)
4006 if (use_modern_diag)
then
4007 call fms_diag_object%diag_end(time)
4013 INTEGER,
INTENT(in) :: file
4016 INTEGER :: j, i, input_num, freq, status
4017 INTEGER :: stdout_unit
4018 LOGICAL :: reduced_k_range, need_compute, local_output
4019 CHARACTER(len=128) :: message
4024 DO j = 1, files(file)%num_fields
4025 i = files(file)%fields(j)
4028 local_output = output_fields(i)%local_output
4030 need_compute = output_fields(i)%need_compute
4032 reduced_k_range = output_fields(i)%reduced_k_range
4035 IF ( local_output .AND. (.NOT. need_compute) ) cycle
4037 input_num = output_fields(i)%input_field
4038 IF ( input_fields(input_num)%static ) cycle
4039 IF ( .NOT.input_fields(input_num)%register ) cycle
4040 freq = files(file)%output_freq
4041 IF ( freq /= end_of_run .AND. files(file)%file_unit < 0 &
4042 & .AND. all(output_fields(i)%num_elements(:) == 0)&
4043 & .AND. all(output_fields(i)%count_0d(:) == 0) ) cycle
4046 IF ( time >= output_fields(i)%next_output .OR. freq == end_of_run )
THEN
4047 IF ( time >= output_fields(i)%next_next_output .AND. freq > 0 )
THEN
4048 WRITE (message,
'(a,"/",a)') trim(input_fields(input_num)%module_name), &
4049 & trim(output_fields(i)%output_name)
4054 IF (
mpp_pe() .EQ. mpp_root_pe() ) &
4055 &
CALL error_mesg(
'diag_manager_mod::closing_file',
'module/output_field ' //&
4056 & trim(message)//
', skip one time level, maybe send_data never called', warning)
4061 ELSEIF ( .NOT.output_fields(i)%written_once )
THEN
4066 CALL error_mesg(
'Potential error in diag_manager_end ',&
4067 & trim(output_fields(i)%output_name)//
' NOT available,'//&
4068 &
' check if output interval > runlength. Netcdf fill_values are written', note)
4069 output_fields(i)%buffer = fill_value
4070 CALL diag_data_out(file, i, output_fields(i)%buffer, time, .true.)
4077 IF ( write_bytes_in_file )
THEN
4078 CALL mpp_sum (files(file)%bytes_written)
4079 IF (
mpp_pe() == mpp_root_pe() )&
4080 &
WRITE (stdout_unit,
'(a,i12,a,a)')
'Diag_Manager: ',files(file)%bytes_written, &
4081 &
' bytes of data written to file ',trim(files(file)%name)
4088 INTEGER,
OPTIONAL,
INTENT(IN) :: diag_model_subset
4089 INTEGER,
DIMENSION(6),
OPTIONAL,
INTENT(IN) :: time_init
4090 CHARACTER(len=*),
INTENT(out),
OPTIONAL :: err_msg
4092 CHARACTER(len=*),
PARAMETER :: sep =
'|'
4094 INTEGER,
PARAMETER :: fltkind = r4_kind
4095 INTEGER,
PARAMETER :: dblkind = r8_kind
4096 INTEGER :: diag_subset_output
4098 INTEGER,
ALLOCATABLE,
DIMENSION(:) :: pelist
4099 INTEGER :: stdlog_unit, stdout_unit
4101 CHARACTER(len=256) :: err_msg_local
4103 namelist /diag_manager_nml/ append_pelist_name, mix_snapshot_average_fields, max_output_fields, &
4104 & max_input_fields, max_axes, do_diag_field_log, write_bytes_in_file, debug_diag_manager,&
4105 & max_num_axis_sets, max_files, use_cmor, issue_oor_warnings,&
4106 & oor_warnings_fatal, max_out_per_in_field, flush_nc_files, region_out_use_alt_value, max_field_attributes,&
4107 & max_file_attributes, max_axis_attributes, prepend_date, use_modern_diag, use_clock_average, &
4109 & wildcard_filename_prefix, wildcard_filename_separator
4112 IF ( module_is_initialized )
RETURN
4115 IF (
PRESENT(err_msg) ) err_msg =
''
4120 call diag_data_init()
4123 pack_size =
SIZE(transfer(0.0_dblkind, (/0.0, 0.0, 0.0, 0.0/)))
4124 IF (pack_size .EQ. 1)
then
4125 pack_size_str =
"double"
4126 else if (pack_size .EQ. 2)
then
4127 pack_size_str =
"float"
4129 IF (
fms_error_handler(
'diag_manager_mod::diag_manager_init',
'unknown pack_size. Must be 1, or 2.', &
4134 min_value = huge(0.0_fltkind)
4135 max_value = -min_value
4146 time_end = time_zero
4147 diag_subset_output = diag_all
4148 IF (
PRESENT(diag_model_subset) )
THEN
4149 IF ( diag_model_subset >= diag_other .AND. diag_model_subset <= diag_all )
THEN
4150 diag_subset_output = diag_model_subset
4152 IF (
fms_error_handler(
'diag_manager_mod::diag_manager_init',
'invalid value of diag_model_subset', &
4157 READ (input_nml_file, nml=diag_manager_nml, iostat=mystat)
4160 IF (
check_nml_error(iostat=mystat, nml_name=
'DIAG_MANAGER_NML') < 0 )
THEN
4161 IF (
mpp_pe() == mpp_root_pe() )
THEN
4162 CALL error_mesg(
'diag_manager_mod::diag_manager_init', &
4163 &
'DIAG_MANAGER_NML not found in input nml file. Using defaults.', warning)
4167 IF (.not. use_modern_diag .and. use_clock_average) &
4168 call mpp_error(fatal,
"diag_manager_mod: You cannot set use_modern_diag=.false. and &
4169 & use_clock_average=.true. in diag_manager_nml")
4171 IF (
mpp_pe() == mpp_root_pe() )
THEN
4172 WRITE (stdlog_unit, diag_manager_nml)
4176 IF ( use_cmor )
THEN
4178 WRITE (err_msg_local,
'(ES8.1E2)') cmor_missing_value
4179 CALL error_mesg(
'diag_manager_mod::diag_manager_init',
'Using CMOR missing value ('//trim(err_msg_local)// &
4185 IF ( index(trim(wildcard_filename_prefix),
'/') > 0 )
THEN
4186 CALL error_mesg(
'diag_manager_mod::diag_manager_init',
'DIAG_MANAGER_NML variable '//&
4187 &
'wildcard_filename_prefix ("'//trim(wildcard_filename_prefix)//
'") cannot contain "/"', fatal)
4189 IF ( index(trim(wildcard_filename_separator),
'/') > 0 )
THEN
4190 CALL error_mesg(
'diag_manager_mod::diag_manager_init',
'DIAG_MANAGER_NML variable '//&
4191 &
'wildcard_filename_separator ("'//trim(wildcard_filename_separator)//
'") cannot contain "/"', fatal)
4195 IF ( oor_warnings_fatal )
THEN
4197 CALL error_mesg(
'diag_manager_mod::diag_manager_init',
'Out &
4198 &of Range warnings are fatal.', note)
4199 ELSEIF ( .NOT.issue_oor_warnings )
THEN
4200 CALL error_mesg(
'diag_manager_mod::diag_manager_init',
'Out &
4201 &of Range warnings will be ignored.', note)
4204 IF ( mix_snapshot_average_fields )
THEN
4205 IF ( .not. use_modern_diag )
THEN
4206 CALL error_mesg(
'diag_manager_mod::diag_manager_init',
'Setting diag_manager_nml variable '//&
4207 &
'mix_snapshot_average_fields = .TRUE. will cause ERRORS in the time coordinates '//&
4208 &
'of all time averaged fields. Strongly recommend setting mix_snapshot_average_fields '//&
4209 &
'= .FALSE.', note)
4211 CALL error_mesg(
'diag_manager_mod::diag_manager_init',
'mix_snapshot_average_fields = .TRUE. is not '//&
4212 &
'supported if use_modern_diag = .TRUE. Please set mix_snapshot_average_fields '//&
4213 &
'to .FALSE. and put instantaneous and averaged fields in separate files!', fatal)
4216 ALLOCATE(output_fields(max_output_fields))
4217 ALLOCATE(input_fields(max_input_fields))
4218 DO j = 1, max_input_fields
4219 ALLOCATE(input_fields(j)%output_fields(max_out_per_in_field))
4222 ALLOCATE(files(max_files))
4223 ALLOCATE(fileobju(max_files))
4224 ALLOCATE(fileobj(max_files))
4225 ALLOCATE(fileobjnd(max_files))
4230 CALL mpp_get_current_pelist(pelist, pelist_name)
4233 IF (
PRESENT(time_init) )
THEN
4234 diag_init_time =
set_date(time_init(1), time_init(2), time_init(3), time_init(4),&
4235 & time_init(5), time_init(6))
4237 diag_init_time = get_base_time()
4238 IF ( prepend_date .EQV. .true. )
THEN
4239 CALL error_mesg(
'diag_manager_mod::diag_manager_init',&
4240 &
'prepend_date only supported when diag_manager_init is called with time_init present.', note)
4241 prepend_date = .false.
4245 if (use_modern_diag)
then
4246 CALL error_mesg(
'diag_manager_mod::diag_manager_init',&
4247 &
'You are using the yaml version of the diag table', note)
4248 CALL fms_diag_object%init(diag_subset_output, time_init)
4250 if (.not. use_modern_diag)
then
4251 CALL error_mesg(
'diag_manager_mod::diag_manager_init',&
4252 &
'You are using the legacy version of the diag table', note)
4253 CALL parse_diag_table(diag_subset=diag_subset_output, istat=mystat, err_msg=err_msg_local)
4254 IF ( mystat /= 0 )
THEN
4256 &
'Error parsing diag_table. '//trim(err_msg_local), err_msg) )
RETURN
4260 files(:)%bytes_written = 0
4263 IF ( do_diag_field_log.AND.
mpp_pe().EQ.mpp_root_pe() )
THEN
4264 open(newunit=diag_log_unit, file=
'diag_field_log.out.'//
string(
mpp_pe()), action=
'WRITE')
4265 WRITE (diag_log_unit,
'(777a)') &
4273 module_is_initialized = .true.
4275 if(.not. use_modern_diag) null_axis_id = diag_axis_init(
'scalar_axis', (/0./),
'none',
'N',
'none')
4282 INTEGER,
INTENT(out) :: year, month, day, hour, minute, second
4285 IF (.NOT.module_is_initialized)
CALL error_mesg (
'diag_manager_mod::get_base_date', &
4286 &
'module has not been initialized', fatal)
4287 year = get_base_year()
4288 month = get_base_month()
4289 day = get_base_day()
4290 hour = get_base_hour()
4291 minute = get_base_minute()
4292 second = get_base_second()
4302 TYPE(
time_type),
INTENT(in) :: next_model_time
4303 INTEGER,
INTENT(in) :: diag_field_id
4305 INTEGER :: i, out_num
4308 IF ( diag_field_id < 0 )
RETURN
4309 DO i = 1, input_fields(diag_field_id)%num_output_fields
4311 out_num = input_fields(diag_field_id)%output_fields(i)
4312 IF ( .NOT.output_fields(out_num)%static )
THEN
4313 IF ( next_model_time > output_fields(out_num)%next_output )
need_data=.true.
4317 IF ( output_fields(out_num)%time_average)
need_data = .true.
4329 INTEGER,
INTENT(in) :: n_samples
4331 REAL :: center_data (n_samples)
4332 REAL :: edges (n_samples+1)
4341 CHARACTER(32) :: name
4342 CHARACTER(128) :: units
4345 WRITE (units,11)
'hours', year, month, day, hour, minute, second
4346 11
FORMAT(a,
' since ',i4.4,
'-',i2.2,
'-',i2.2,
' ',i2.2,
':',i2.2,
':',i2.2)
4350 center_data(i) = 24.0*(real(i)-0.5)/n_samples
4351 edges(i+1) = 24.0* real(i)/n_samples
4356 WRITE (name,
'(a,i2.2)')
'time_of_day_edges_', n_samples
4357 edges_id = get_axis_num(name,
'diurnal')
4358 IF ( edges_id <= 0 )
THEN
4359 edges_id = diag_axis_init(name,edges,units,
'N',
'time of day edges', set_name=
'diurnal')
4364 WRITE (name,
'(a,i2.2)')
'time_of_day_', n_samples
4367 init_diurnal_axis = diag_axis_init(name, center_data, units,
'N',
'time of day', &
4368 set_name=
'diurnal', edges=edges_id)
4373 INTEGER,
INTENT(in) :: diag_field_id
4374 CHARACTER(len=*),
INTENT(in) :: name
4375 INTEGER,
INTENT(in) ::
type
4376 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: cval
4377 INTEGER,
DIMENSION(:),
INTENT(in),
OPTIONAL :: ival
4378 REAL,
DIMENSION(:),
INTENT(in),
OPTIONAL :: rval
4380 INTEGER :: istat, length, i, j, this_attribute, out_field
4382 IF ( .NOT.first_send_data_call )
THEN
4388 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',
'Attempting to add attribute "'&
4389 &//trim(name)//
'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//
'/'&
4390 &//trim(input_fields(diag_field_id)%field_name)//
'" after first send_data call. Too late.', fatal)
4394 IF ( diag_field_id .LE. 0 )
THEN
4397 DO j=1,input_fields(diag_field_id)%num_output_fields
4398 out_field = input_fields(diag_field_id)%output_fields(j)
4405 DO i=1, output_fields(out_field)%num_attributes
4406 IF ( trim(output_fields(out_field)%attributes(i)%name) .EQ. trim(name) )
THEN
4412 IF ( this_attribute.NE.0 .AND. (type.EQ.nf90_int .OR. type.EQ.nf90_float) )
THEN
4417 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',&
4418 &
'Attribute "'//trim(name)//
'" already defined for module/input_field "'&
4419 &//trim(input_fields(diag_field_id)%module_name)//
'/'&
4420 &//trim(input_fields(diag_field_id)%field_name)//
'". Contact the developers.', fatal)
4421 ELSE IF ( this_attribute.NE.0 .AND. type.EQ.nf90_char .AND. debug_diag_manager )
THEN
4426 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',&
4427 &
'Attribute "'//trim(name)//
'" already defined for module/input_field "'&
4428 &//trim(input_fields(diag_field_id)%module_name)//
'/'&
4429 &//trim(input_fields(diag_field_id)%field_name)//
'". Prepending.', note)
4430 ELSE IF ( this_attribute.EQ.0 )
THEN
4433 this_attribute = output_fields(out_field)%num_attributes + 1
4435 IF ( this_attribute .GT. max_field_attributes )
THEN
4441 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',&
4442 &
'Number of attributes exceeds max_field_attributes for attribute "'&
4443 &//trim(name)//
'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//
'/'&
4444 &//trim(input_fields(diag_field_id)%field_name)&
4445 &//
'". Increase diag_manager_nml:max_field_attributes.', fatal)
4447 output_fields(out_field)%num_attributes = this_attribute
4449 output_fields(out_field)%attributes(this_attribute)%name = name
4450 output_fields(out_field)%attributes(this_attribute)%type =
type
4452 output_fields(out_field)%attributes(this_attribute)%catt =
''
4458 IF ( .NOT.
PRESENT(ival) )
THEN
4464 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',&
4465 &
'Attribute type claims INTEGER, but ival not present for attribute "'&
4466 &//trim(name)//
'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//
'/'&
4467 &//trim(input_fields(diag_field_id)%field_name)//
'". Contact then developers.', fatal)
4471 ALLOCATE(output_fields(out_field)%attributes(this_attribute)%iatt(length), stat=istat)
4472 IF ( istat.NE.0 )
THEN
4476 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',
'Unable to allocate iatt for attribute "'&
4477 &//trim(name)//
'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//
'/'&
4478 &//trim(input_fields(diag_field_id)%field_name)//
'"', fatal)
4481 output_fields(out_field)%attributes(this_attribute)%len = length
4482 output_fields(out_field)%attributes(this_attribute)%iatt = ival
4484 IF ( .NOT.
PRESENT(rval) )
THEN
4490 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',&
4491 &
'Attribute type claims REAL, but rval not present for attribute "'&
4492 &//trim(name)//
'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//
'/'&
4493 &//trim(input_fields(diag_field_id)%field_name)//
'". Contact the developers.', fatal)
4497 ALLOCATE(output_fields(out_field)%attributes(this_attribute)%fatt(length), stat=istat)
4498 IF ( istat.NE.0 )
THEN
4502 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',
'Unable to allocate fatt for attribute "'&
4503 &//trim(name)//
'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//
'/'&
4504 &//trim(input_fields(diag_field_id)%field_name)//
'"', fatal)
4507 output_fields(out_field)%attributes(this_attribute)%len = length
4508 output_fields(out_field)%attributes(this_attribute)%fatt = rval
4510 IF ( .NOT.
PRESENT(cval) )
THEN
4516 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',&
4517 &
'Attribute type claims CHARACTER, but cval not present for attribute "'&
4518 &//trim(name)//
'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//
'/'&
4519 &//trim(input_fields(diag_field_id)%field_name)//
'". Contact the developers.', fatal)
4527 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',
'Unknown attribute type for attribute "'&
4528 &//trim(name)//
'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//
'/'&
4529 &//trim(input_fields(diag_field_id)%field_name)//
'". Contact the developers.', fatal)
4537 INTEGER,
INTENT(in) :: diag_field_id
4538 CHARACTER(len=*),
INTENT(in) :: att_name
4539 class(*),
INTENT(in) :: att_value
4541 if (use_modern_diag)
then
4542 select type(att_value)
4543 type is (real(kind=r4_kind))
4544 call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, (/att_value /))
4545 type is (real(kind=r8_kind))
4546 call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, (/att_value /))
4547 type is (
integer(kind=i4_kind))
4548 call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, (/att_value /))
4549 type is (
character(len=*))
4550 call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, (/att_value /))
4552 call mpp_error(fatal,
"Diag_field_add_attribute 0d:: unsupported type. The acceptable types "//&
4553 "are float, double, integer, and string")
4556 select type(att_value)
4557 type is (real(kind=r4_kind))
4559 type is (real(kind=r8_kind))
4561 type is (
integer(kind=i4_kind))
4563 type is (
character(len=*))
4566 call mpp_error(fatal,
"Diag_field_add_attribute 0d:: unsupported type. The acceptable types "//&
4567 "are float, double, integer, and string")
4575 INTEGER,
INTENT(in) :: diag_field_id
4576 CHARACTER(len=*),
INTENT(in) :: att_name
4577 class(*),
INTENT(in) :: att_value(:)
4579 if (use_modern_diag)
then
4580 call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, att_value)
4582 select type(att_value)
4583 type is (real(kind=r4_kind))
4585 type is (real(kind=r8_kind))
4587 type is (
integer(kind=i4_kind))
4590 call mpp_error(fatal,
"Diag_field_add_attribute 1d:: unsupported type. The acceptable types "//&
4591 "are float, double, and integer")
4602 INTEGER,
INTENT(in) :: diag_field_id
4603 INTEGER,
INTENT(in),
OPTIONAL :: area
4604 INTEGER,
INTENT(in),
OPTIONAL :: volume
4608 IF ( diag_field_id.GT.0 )
THEN
4609 IF ( .NOT.
PRESENT(area) .AND. .NOT.
present(volume) )
THEN
4610 CALL error_mesg(
'diag_manager_mod::diag_field_add_cell_measures', &
4611 &
'either area or volume arguments must be present', fatal )
4614 if (use_modern_diag)
then
4615 call fms_diag_object%fms_diag_field_add_cell_measures(diag_field_id, area, volume)
4619 DO j=1, input_fields(diag_field_id)%num_output_fields
4620 ind = input_fields(diag_field_id)%output_fields(j)
4628 class(*),
intent(in) :: data_in(:,:,:)
4629 character(len=*),
intent(in) :: field_name
4630 class(*),
allocatable,
intent(out) :: data_out(:,:,:,:)
4633 select type(data_in)
4634 type is (real(kind=r8_kind))
4635 allocate(real(kind=r8_kind) :: data_out(1:
size(data_in,1), 1:
size(data_in,2), 1:
size(data_in,3), 1))
4636 select type (data_out)
4637 type is (real(kind=r8_kind))
4638 data_out(:,:,:,1) = data_in
4640 call mpp_error(fatal,
"The copy of "//trim(field_name)//&
4641 " was not allocated to the correct type (r8_kind). This shouldn't have happened")
4643 type is (real(kind=r4_kind))
4644 allocate(real(kind=r4_kind) :: data_out(1:
size(data_in,1), 1:
size(data_in,2), 1:
size(data_in,3), 1))
4645 select type (data_out)
4646 type is (real(kind=r4_kind))
4647 data_out(:,:,:,1) = data_in
4649 call mpp_error(fatal,
"The copy of "//trim(field_name)//&
4650 " was not allocated to the correct type (r4_kind). This shouldn't have happened")
4653 call mpp_error(fatal,
"The data for "//trim(field_name)//&
4654 &
" is not a valid type. Currently only r4 and r8 are supported")
4658 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.
character(len=16) wildcard_filename_separator
String inserted between each subsequent substituted time field when using a wildcard (%) file name.
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
character(len=16) wildcard_filename_prefix
String inserted immediately before the first substituted time field when using a wildcard (%) file na...
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.