146 MODULE diag_manager_mod
210 &
OPERATOR(<),
OPERATOR(==),
OPERATOR(/=),
OPERATOR(/),
OPERATOR(+),
ASSIGNMENT(=),
get_date, &
214 USE mpp_mod,
ONLY: input_nml_file,
mpp_error
227 & end_of_run, diag_seconds, diag_minutes, diag_hours, diag_days, diag_months, diag_years,
num_files,&
231 & output_fields, time_zero, append_pelist_name, mix_snapshot_average_fields,&
232 & first_send_data_call, do_diag_field_log, write_bytes_in_file, debug_diag_manager,&
243 use fms_diag_object_mod,
only:fms_diag_object
245 USE constants_mod,
ONLY: seconds_per_day
249 USE fms_string_utils_mod,
ONLY:
string
251 USE netcdf,
ONLY: nf90_int, nf90_float, nf90_char
264 &
need_data, diag_all, diag_ocean, diag_other, get_date_dif, diag_seconds,&
268 PUBLIC :: center, north, east
274 PUBLIC :: diag_field_not_found
278 #include<file_version.h>
280 type(time_type) :: Time_end
383 & long_name, units, missing_value, range, standard_name, do_not_log, err_msg,&
384 & area, volume, realm, multiple_send_data)
385 CHARACTER(len=*),
INTENT(in) :: module_name
386 CHARACTER(len=*),
INTENT(in) :: field_name
387 TYPE(
time_type),
OPTIONAL,
INTENT(in) :: init_time
388 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: long_name
389 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: units
390 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: standard_name
391 CLASS(*),
OPTIONAL,
INTENT(in) :: missing_value
392 CLASS(*),
OPTIONAL,
INTENT(in) :: range(:)
393 LOGICAL,
OPTIONAL,
INTENT(in) :: do_not_log
394 CHARACTER(len=*),
OPTIONAL,
INTENT(out):: err_msg
395 INTEGER,
OPTIONAL,
INTENT(in) :: area
396 INTEGER,
OPTIONAL,
INTENT(in) :: volume
397 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: realm
398 LOGICAL,
OPTIONAL,
INTENT(in) :: multiple_send_data
402 IF (
PRESENT(range) )
THEN
403 IF (
SIZE(range) .NE. 2 )
THEN
405 CALL error_mesg (
'diag_manager_mod::register_diag_field',
'extent of range should be 2', fatal)
408 if (use_modern_diag)
then
409 if( do_diag_field_log)
then
410 if (
PRESENT(do_not_log) )
THEN
411 if(.not. do_not_log)
call log_diag_field_info(module_name, field_name, (/null_axis_id/), long_name,&
412 & units, missing_value, range, dynamic=.true.)
415 & missing_value, range, dynamic=.true.)
419 & module_name, field_name, init_time, long_name=long_name, units=units, &
420 & missing_value=missing_value, var_range=range, standard_name=standard_name, &
421 & do_not_log=do_not_log, err_msg=err_msg, area=area, volume=volume, realm=realm, &
422 multiple_send_data=multiple_send_data)
425 & long_name=long_name, units=units, missing_value=missing_value, range=range, standard_name=standard_name, &
426 & do_not_log=do_not_log, err_msg=err_msg, area=area, volume=volume, realm=realm)
433 & long_name, units, missing_value, range, mask_variant, standard_name, verbose,&
434 & do_not_log, err_msg, interp_method, tile_count, area, volume, realm, multiple_send_data)
435 CHARACTER(len=*),
INTENT(in) :: module_name
436 CHARACTER(len=*),
INTENT(in) :: field_name
437 INTEGER,
INTENT(in) :: axes(:)
438 TYPE(
time_type),
OPTIONAL,
INTENT(in) :: init_time
439 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: long_name
440 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: units
441 CLASS(*),
OPTIONAL,
INTENT(in) :: missing_value
442 CLASS(*),
OPTIONAL,
INTENT(in) :: range(:)
443 LOGICAL,
OPTIONAL,
INTENT(in) :: mask_variant
444 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: standard_name
445 LOGICAL,
OPTIONAL,
INTENT(in) :: verbose
446 LOGICAL,
OPTIONAL,
INTENT(in) :: do_not_log
447 CHARACTER(len=*),
OPTIONAL,
INTENT(out):: err_msg
448 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: interp_method
452 INTEGER,
OPTIONAL,
INTENT(in) :: tile_count
453 INTEGER,
OPTIONAL,
INTENT(in) :: area
454 INTEGER,
OPTIONAL,
INTENT(in) :: volume
455 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: realm
456 LOGICAL,
OPTIONAL,
INTENT(in) :: multiple_send_data
459 if (use_modern_diag)
then
460 if( do_diag_field_log)
then
461 if (
PRESENT(do_not_log) )
THEN
463 & units, missing_value, range, dynamic=.true.)
466 & missing_value, range, dynamic=.true.)
470 & module_name, field_name, axes, init_time, long_name=long_name, &
471 & units=units, missing_value=missing_value, var_range=range, mask_variant=mask_variant, &
472 & standard_name=standard_name, verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
473 & interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm, &
474 multiple_send_data=multiple_send_data)
477 & long_name=long_name, units=units, missing_value=missing_value, range=range, mask_variant=mask_variant, &
478 & standard_name=standard_name, verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
479 & interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm)
486 & missing_value, range, mask_variant, standard_name, DYNAMIC, do_not_log, interp_method,&
487 & tile_count, area, volume, realm)
488 CHARACTER(len=*),
INTENT(in) :: module_name
489 CHARACTER(len=*),
INTENT(in) :: field_name
490 INTEGER,
DIMENSION(:),
INTENT(in) :: axes
491 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: long_name
492 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: units
493 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: standard_name
494 CLASS(*),
OPTIONAL,
INTENT(in) :: missing_value
495 CLASS(*),
DIMENSION(:),
OPTIONAL,
INTENT(in) :: range
496 LOGICAL,
OPTIONAL,
INTENT(in) :: mask_variant
497 LOGICAL,
OPTIONAL,
INTENT(in) :: dynamic
498 LOGICAL,
OPTIONAL,
INTENT(in) :: do_not_log
499 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: interp_method
503 INTEGER,
OPTIONAL,
INTENT(in) :: tile_count
504 INTEGER,
OPTIONAL,
INTENT(in) :: area
506 INTEGER,
OPTIONAL,
INTENT(in) :: volume
508 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: realm
512 IF ( .NOT.module_is_initialized )
THEN
514 CALL error_mesg (
'diag_manager_mod::register_static_field',
'diag_manager has NOT been initialized', fatal)
517 if (use_modern_diag)
then
518 if( do_diag_field_log)
then
519 if (
PRESENT(do_not_log) )
THEN
521 & units, missing_value, range, dynamic=.false.)
524 & missing_value, range, dynamic=.false.)
528 & long_name=long_name, units=units, missing_value=missing_value, range=range, mask_variant=mask_variant, &
529 & standard_name=standard_name, dynamic=dynamic, do_not_log=do_not_log, interp_method=interp_method,&
530 & tile_count=tile_count, area=area, volume=volume, realm=realm)
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)
542 & long_name, units, missing_value, range, standard_name, do_not_log, err_msg,&
543 & area, volume, realm)
544 CHARACTER(len=*),
INTENT(in) :: module_name
545 CHARACTER(len=*),
INTENT(in) :: field_name
546 TYPE(
time_type),
OPTIONAL,
INTENT(in) :: init_time
547 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: long_name
548 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: units
549 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: standard_name
550 CLASS(*),
OPTIONAL,
INTENT(in) :: missing_value
551 CLASS(*),
OPTIONAL,
INTENT(in) :: range(:)
552 LOGICAL,
OPTIONAL,
INTENT(in) :: do_not_log
553 CHARACTER(len=*),
OPTIONAL,
INTENT(out):: err_msg
554 INTEGER,
OPTIONAL,
INTENT(in) :: area
555 INTEGER,
OPTIONAL,
INTENT(in) :: volume
556 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: realm
558 IF (
PRESENT(err_msg) ) err_msg =
''
560 IF (
PRESENT(init_time) )
THEN
562 & (/null_axis_id/), init_time,long_name, units, missing_value, range, &
563 & standard_name=standard_name, do_not_log=do_not_log, err_msg=err_msg,&
564 & area=area, volume=volume, realm=realm)
567 & (/null_axis_id/),long_name, units, missing_value, range,&
568 & standard_name=standard_name, do_not_log=do_not_log, realm=realm)
575 & long_name, units, missing_value, range, mask_variant, standard_name, verbose,&
576 & do_not_log, err_msg, interp_method, tile_count, area, volume, realm)
577 CHARACTER(len=*),
INTENT(in) :: module_name, field_name
578 INTEGER,
INTENT(in) :: axes(:)
580 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: long_name, units, standard_name
581 CLASS(*),
OPTIONAL,
INTENT(in) :: missing_value
582 CLASS(*),
DIMENSION(:),
OPTIONAL,
INTENT(in) :: range
583 LOGICAL,
OPTIONAL,
INTENT(in) :: mask_variant,verbose
584 LOGICAL,
OPTIONAL,
INTENT(in) :: do_not_log
585 CHARACTER(len=*),
OPTIONAL,
INTENT(out):: err_msg
586 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: interp_method
590 INTEGER,
OPTIONAL,
INTENT(in) :: tile_count
591 INTEGER,
OPTIONAL,
INTENT(in) :: area
592 INTEGER,
OPTIONAL,
INTENT(in) :: volume
593 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: realm
595 INTEGER :: field, j, ind, file_num, freq
596 INTEGER :: output_units
597 INTEGER :: stdout_unit
598 LOGICAL :: mask_variant1, verbose1
599 CHARACTER(len=128) :: msg
605 IF (
PRESENT(mask_variant) )
THEN
606 mask_variant1 = mask_variant
608 mask_variant1 = .false.
611 IF (
PRESENT(verbose) )
THEN
617 IF (
PRESENT(err_msg) ) err_msg =
''
620 IF (
PRESENT(range) )
THEN
621 IF (
SIZE(range) .NE. 2 )
THEN
623 CALL error_mesg (
'diag_manager_mod::register_diag_field',
'extent of range should be 2', fatal)
629 & long_name, units, missing_value, range, mask_variant1, standard_name=standard_name,&
630 & dynamic=.true., do_not_log=do_not_log, interp_method=interp_method, tile_count=tile_count, realm=realm)
632 IF ( .NOT.first_send_data_call )
THEN
637 IF (
mpp_pe() == mpp_root_pe() ) &
638 &
CALL error_mesg (
'diag_manager_mod::register_diag_field',
'module/output_field '&
639 &//trim(module_name)//
'/'// trim(field_name)//&
640 &
' registered AFTER first send_data call, TOO LATE', warning)
647 IF ( debug_diag_manager .OR. verbose1 )
THEN
648 IF (
mpp_pe() == mpp_root_pe() ) &
649 &
CALL error_mesg (
'diag_manager_mod::register_diag_field',
'module/output_field '&
650 &//trim(module_name)//
'/'// trim(field_name)//
' NOT found in diag_table',&
659 IF (
PRESENT(volume).AND.
PRESENT(area) )
THEN
660 IF ( area.EQ.volume )
THEN
661 IF (
PRESENT(err_msg))
THEN
662 err_msg =
'diag_manager_mod::register_diag_field: module/output_field '&
663 &//trim(module_name)//
'/'// trim(field_name)//
' AREA and VOLUME CANNOT be the same variable.&
664 & Contact the developers.'
668 CALL error_mesg (
'diag_manager_mod::register_diag_field',
'module/output_field '&
669 &//trim(module_name)//
'/'// trim(field_name)//
' AREA and VOLUME CANNOT be the same variable.&
670 & Contact the developers.',&
677 IF (
PRESENT(area) )
THEN
679 IF (
PRESENT(err_msg))
THEN
680 err_msg =
'diag_manager_mod::register_diag_field: module/output_field '&
681 &//trim(module_name)//
'/'// trim(field_name)//
' AREA measures field NOT found in diag_table.&
682 & Contact the model liaison.'
686 CALL error_mesg (
'diag_manager_mod::register_diag_field',
'module/output_field '&
687 &//trim(module_name)//
'/'// trim(field_name)//
' AREA measures field NOT found in diag_table.&
688 & Contact the model liaison.',&
693 IF (
PRESENT(volume) )
THEN
694 IF ( volume < 0 )
THEN
695 IF (
PRESENT(err_msg))
THEN
696 err_msg =
'diag_manager_mod::register_diag_field: module/output_field '&
697 &//trim(module_name)//
'/'// trim(field_name)//
' VOLUME measures field NOT found in diag_table.&
698 & Contact the model liaison.'
702 CALL error_mesg (
'diag_manager_mod::register_diag_field',
'module/output_field '&
703 &//trim(module_name)//
'/'// trim(field_name)//
' VOLUME measures field NOT found in diag_table.&
704 & Contact the model liaison.',&
710 IF (
PRESENT(standard_name) ) input_fields(field)%standard_name = standard_name
712 DO j = 1, input_fields(field)%num_output_fields
713 ind = input_fields(field)%output_fields(j)
714 output_fields(ind)%static = .false.
717 file_num = output_fields(ind)%output_file
718 IF ( file_num == max_files ) cycle
719 IF ( output_fields(ind)%local_output )
THEN
720 IF ( output_fields(ind)%need_compute)
THEN
721 files(file_num)%local = .true.
729 IF ( msg /=
'' )
THEN
730 IF (
fms_error_handler(
'diag_manager_mod::register_diag_field', trim(msg), err_msg) )
RETURN
733 freq = files(file_num)%output_freq
735 output_units = files(file_num)%output_units
736 output_fields(ind)%last_output = diag_file_init_time
737 output_fields(ind)%next_output = diag_time_inc(diag_file_init_time, freq, output_units, err_msg=msg)
738 IF ( msg /=
'' )
THEN
740 &
' file='//trim(files(file_num)%name)//
': '//trim(msg),err_msg))
RETURN
742 output_fields(ind)%next_next_output = &
743 & diag_time_inc(output_fields(ind)%next_output, freq, output_units, err_msg=msg)
744 IF ( msg /=
'' )
THEN
746 &
' file='//trim(files(file_num)%name)//
': '//trim(msg),err_msg) )
RETURN
748 IF ( debug_diag_manager .AND.
mpp_pe() == mpp_root_pe() .AND. output_fields(ind)%local_output )
THEN
749 WRITE (msg,
'(" lon(",F5.1,", ",F5.1,"), lat(",F5.1,", ",F5.1,"), dep(",F5.1,", ",F5.1,")")') &
750 & output_fields(ind)%output_grid%start(1),output_fields(ind)%output_grid%end(1),&
751 & output_fields(ind)%output_grid%start(2),output_fields(ind)%output_grid%end(2),&
752 & output_fields(ind)%output_grid%start(3),output_fields(ind)%output_grid%end(3)
753 WRITE(stdout_unit,* )
'module/output_field '//trim(module_name)//
'/'//trim(field_name)// &
754 &
' will be output in region:'//trim(msg)
759 IF ( len_trim(err_msg).GT.0 )
THEN
760 CALL error_mesg (
'diag_manager_mod::register_diag_field',&
761 & trim(err_msg)//
' for module/field '//trim(module_name)//
'/'//trim(field_name),&
772 & missing_value, range, mask_variant, standard_name, DYNAMIC, do_not_log, interp_method,&
773 & tile_count, area, volume, realm)
774 CHARACTER(len=*),
INTENT(in) :: module_name, field_name
775 INTEGER,
DIMENSION(:),
INTENT(in) :: axes
776 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: long_name, units, standard_name
777 CLASS(*),
OPTIONAL,
INTENT(in) :: missing_value
778 CLASS(*),
DIMENSION(:),
OPTIONAL,
INTENT(in) :: range
779 LOGICAL,
OPTIONAL,
INTENT(in) :: mask_variant
780 LOGICAL,
OPTIONAL,
INTENT(in) :: dynamic
781 LOGICAL,
OPTIONAL,
INTENT(in) :: do_not_log
782 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: interp_method
786 INTEGER,
OPTIONAL,
INTENT(in) :: tile_count
787 INTEGER,
OPTIONAL,
INTENT(in) :: area
788 INTEGER,
OPTIONAL,
INTENT(in) :: volume
789 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: realm
791 REAL :: missing_value_use
792 REAL,
DIMENSION(2) :: range_use
793 INTEGER :: field, num_axes, j, out_num, k
794 INTEGER,
DIMENSION(3) :: siz, local_siz, local_start, local_end
795 INTEGER :: tile, file_num
796 LOGICAL :: mask_variant1, dynamic1, allow_log
797 CHARACTER(len=128) :: msg
798 INTEGER :: domain_type, i
799 character(len=256) :: axis_name
802 IF ( .NOT.module_is_initialized )
THEN
804 CALL error_mesg (
'diag_manager_mod::register_static_field_old',
'diag_manager has NOT been initialized', fatal)
808 IF (
PRESENT(missing_value) )
THEN
810 missing_value_use = cmor_missing_value
812 SELECT TYPE (missing_value)
813 TYPE IS (real(kind=r4_kind))
814 missing_value_use = missing_value
815 TYPE IS (real(kind=r8_kind))
816 missing_value_use = real(missing_value)
818 CALL error_mesg (
'diag_manager_mod::register_static_field',&
819 &
'The missing_value is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
824 IF (
PRESENT(mask_variant) )
THEN
825 mask_variant1 = mask_variant
827 mask_variant1 = .false.
830 IF (
PRESENT(dynamic) )
THEN
836 IF (
PRESENT(tile_count) )
THEN
842 IF (
PRESENT(do_not_log) )
THEN
843 allow_log = .NOT.do_not_log
849 IF (
PRESENT(range) )
THEN
850 IF (
SIZE(range) .NE. 2 )
THEN
852 CALL error_mesg (
'diag_manager_mod::register_static_field',
'extent of range should be 2', fatal)
858 IF ( do_diag_field_log.AND.allow_log )
THEN
860 & long_name, units, missing_value=missing_value, range=range, &
870 domain_type = axis_compatible_check(axes,field_name)
873 IF ( .NOT.input_fields(field)%register )
THEN
878 CALL error_mesg (
'diag_manager_mod::register_diag_field',
'module/output_field '//trim(module_name)//
'/'//&
879 & trim(field_name)//
' is not registered for tile_count = 1, should not register for tile_count > 1',&
885 DO j = 1, input_fields(field)%num_output_fields
886 out_num = input_fields(field)%output_fields(j)
887 file_num = output_fields(out_num)%output_file
888 IF(input_fields(field)%local)
THEN
889 CALL init_output_field(module_name, field_name,output_fields(out_num)%output_name,&
890 & files(file_num)%name,output_fields(out_num)%time_method, output_fields(out_num)%pack,&
891 & tile, input_fields(field)%local_coord)
893 CALL init_output_field(module_name, field_name,output_fields(out_num)%output_name,&
894 & files(file_num)%name,output_fields(out_num)%time_method, output_fields(out_num)%pack, tile)
904 input_fields(field)%static = .true.
906 IF ( input_fields(field)%register .AND.
mpp_pe() == mpp_root_pe() )
THEN
911 CALL error_mesg (
'diag_manager_mod::register_diag_field',
'module/output_field '//trim(module_name)//
'/'//&
912 & trim(field_name)//
' ALREADY registered, should not register twice', fatal)
916 IF (
PRESENT(volume).AND.
PRESENT(area) )
THEN
917 IF ( area.EQ.volume )
THEN
918 CALL error_mesg (
'diag_manager_mod::register_static_field_old',
'module/output_field '&
919 &//trim(module_name)//
'/'// trim(field_name)//
' AREA and VOLUME CANNOT be the same variable.&
920 & Contact the developers.',&
926 IF (
PRESENT(area) )
THEN
928 CALL error_mesg (
'diag_manager_mod::register_static_field_old',
'module/output_field '&
929 &//trim(module_name)//
'/'// trim(field_name)//
' AREA measures field NOT found in diag_table.&
930 & Contact the model liaison.n',&
934 IF (
PRESENT(volume) )
THEN
935 IF ( volume < 0 )
THEN
936 CALL error_mesg (
'diag_manager_mod::register_static_field_old',
'module/output_field '&
937 &//trim(module_name)//
'/'// trim(field_name)//
' VOLUME measures field NOT found in diag_table&
938 & Contact the model liaison.',&
944 input_fields(field)%register = .true.
946 input_fields(field)%mask_variant = mask_variant1
948 input_fields(field)%issued_mask_ignore_warning = .false.
951 IF (
PRESENT(long_name) )
THEN
952 input_fields(field)%long_name = trim(long_name)
954 input_fields(field)%long_name = input_fields(field)%field_name
957 IF (
PRESENT(standard_name) ) input_fields(field)%standard_name = standard_name
959 IF (
PRESENT(units) )
THEN
960 input_fields(field)%units = trim(units)
962 input_fields(field)%units =
'none'
965 IF (
PRESENT(missing_value) )
THEN
966 input_fields(field)%missing_value = missing_value_use
967 input_fields(field)%missing_value_present = .true.
969 input_fields(field)%missing_value_present = .false.
972 IF (
PRESENT(range) )
THEN
974 TYPE IS (real(kind=r4_kind))
976 TYPE IS (real(kind=r8_kind))
977 range_use = real(range)
979 CALL error_mesg (
'diag_manager_mod::register_static_field',&
980 &
'The range is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
982 input_fields(field)%range = range_use
984 input_fields(field)%range_present = range_use(2) .gt. range_use(1)
986 input_fields(field)%range = (/ 1., 0. /)
987 input_fields(field)%range_present = .false.
990 IF (
PRESENT(interp_method) )
THEN
991 IF ( trim(interp_method) .NE.
'conserve_order1' .AND.&
992 & trim(interp_method) .NE.
'conserve_order2' .AND.&
993 & trim(interp_method) .NE.
'none' )
THEN
999 CALL error_mesg (
'diag_manager_mod::register_diag_field',&
1000 &
'when registering module/output_field '//trim(module_name)//
'/'//&
1001 & trim(field_name)//
', the optional argument interp_method = '//trim(interp_method)//&
1002 &
', but it should be "conserve_order1", "conserve_order2", or "none"', fatal)
1004 input_fields(field)%interp_method = trim(interp_method)
1006 input_fields(field)%interp_method =
''
1010 num_axes =
SIZE(axes(:))
1011 input_fields(field)%axes(1:num_axes) = axes
1012 input_fields(field)%num_axes = num_axes
1016 IF ( axes(j) .LE. 0 )
THEN
1020 CALL error_mesg (
'diag_manager_mod::register_diag_field',
'module/output_field '//trim(module_name)//
'/'//&
1021 & trim(field_name)//
' has non-positive axis_id', fatal)
1023 siz(j) = get_axis_length(axes(j))
1028 input_fields(field)%size(j) = siz(j)
1035 DO j = 1, input_fields(field)%num_output_fields
1036 out_num = input_fields(field)%output_fields(j)
1038 IF ( output_fields(out_num)%pack>=4 .AND. .NOT.input_fields(field)%range_present )
THEN
1039 IF(
mpp_pe() .EQ. mpp_root_pe())
THEN
1043 CALL error_mesg (
'diag_manager_mod::register_diag_field ',
'output_field '//trim(field_name)// &
1044 ' has pack >=4, range is REQUIRED in register_diag_field', fatal)
1049 IF ( .NOT.dynamic1 ) output_fields(out_num)%n_diurnal_samples = 1
1053 file_num = output_fields(out_num)%output_file
1054 if (domain_type .eq. diag_axis_2ddomain)
then
1055 if (files(file_num)%use_domainUG)
then
1056 call error_mesg(
"diag_manager_mod::register_static_field_old", &
1057 "Diagnostics living on a structured grid" &
1058 //
" and an unstructured grid cannot exist" &
1059 //
" in the same file (" &
1060 //trim(files(file_num)%name)//
")", &
1062 elseif (.not. files(file_num)%use_domain2D)
then
1063 files(file_num)%use_domain2D = .true.
1066 if (files(file_num)%use_domain2D)
then
1067 call error_mesg(
"diag_manager_mod::register_static_field_old", &
1068 "Diagnostics living on a structured grid" &
1069 //
" and an unstructured grid cannot exist" &
1070 //
" in the same file (" &
1071 //trim(files(file_num)%name)//
")", &
1073 elseif (.not. files(file_num)%use_domainUG)
then
1074 files(file_num)%use_domainUG = .true.
1080 IF ( output_fields(out_num)%reduced_k_range )
THEN
1089 local_start(2) = output_fields(out_num)%output_grid%l_start_indx(2)
1090 local_end(2) = output_fields(out_num)%output_grid%l_end_indx(2)
1091 local_siz(2) = local_end(2) - local_start(2) + 1
1092 allocate(output_fields(out_num)%buffer(siz(1),local_siz(2),siz(3), &
1093 output_fields(out_num)%n_diurnal_samples))
1094 output_fields(out_num)%region_elements = siz(1)*local_siz(2)*siz(3)
1095 output_fields(out_num)%reduced_k_unstruct = .true.
1097 local_start(3) = output_fields(out_num)%output_grid%l_start_indx(3)
1098 local_end(3) = output_fields(out_num)%output_grid%l_end_indx(3)
1099 local_siz(3) = local_end(3) - local_start(3) + 1
1100 allocate(output_fields(out_num)%buffer(siz(1),siz(2),local_siz(3), &
1101 output_fields(out_num)%n_diurnal_samples))
1102 output_fields(out_num)%region_elements = siz(1)*siz(2)*local_siz(3)
1103 output_fields(out_num)%reduced_k_unstruct = .false.
1105 output_fields(out_num)%total_elements = siz(1)*siz(2)*siz(3)
1108 IF ( output_fields(out_num)%time_max )
THEN
1109 output_fields(out_num)%buffer = max_value
1110 ELSE IF ( output_fields(out_num)%time_min )
THEN
1111 output_fields(out_num)%buffer = min_value
1113 output_fields(out_num)%buffer = empty
1115 ELSE IF ( output_fields(out_num)%local_output )
THEN
1116 IF (
SIZE(axes(:)) .LE. 1 )
THEN
1118 CALL error_mesg (
'diag_manager_mod::register_diag_field',
'axes of '//trim(field_name)//&
1119 &
' must >= 2 for local output', fatal)
1122 IF ( output_fields(out_num)%need_compute )
THEN
1124 local_start(k) = output_fields(out_num)%output_grid%l_start_indx(k)
1125 local_end(k) = output_fields(out_num)%output_grid%l_end_indx(k)
1126 local_siz(k) = local_end(k) - local_start(k) +1
1128 ALLOCATE(output_fields(out_num)%buffer(local_siz(1), local_siz(2), local_siz(3),&
1129 & output_fields(out_num)%n_diurnal_samples))
1130 IF(output_fields(out_num)%time_max)
THEN
1131 output_fields(out_num)%buffer = max_value
1132 ELSE IF(output_fields(out_num)%time_min)
THEN
1133 output_fields(out_num)%buffer = min_value
1135 output_fields(out_num)%buffer = empty
1137 output_fields(out_num)%region_elements = local_siz(1)*local_siz(2)*local_siz(3)
1138 output_fields(out_num)%total_elements = siz(1)*siz(2)*siz(3)
1139 files(output_fields(out_num)%output_file)%local = .true.
1143 ALLOCATE(output_fields(out_num)%buffer(siz(1), siz(2), siz(3),&
1144 & output_fields(out_num)%n_diurnal_samples))
1145 IF(output_fields(out_num)%time_max)
THEN
1146 output_fields(out_num)%buffer = max_value
1147 ELSE IF(output_fields(out_num)%time_min)
THEN
1148 output_fields(out_num)%buffer = min_value
1150 output_fields(out_num)%buffer = empty
1152 output_fields(out_num)%total_elements = siz(1)*siz(2)*siz(3)
1156 output_fields(out_num)%static = .true.
1158 IF ( .NOT.dynamic1 .AND. output_fields(out_num)%time_ops )
THEN
1159 WRITE (msg,
'(a,"/",a)') trim(module_name), trim(field_name)
1160 IF (
mpp_pe() .EQ. mpp_root_pe() )
THEN
1167 CALL error_mesg (
'diag_manager_mod::register_static_field_old',&
1168 &
'module/field '//trim(msg)//
' is STATIC. Cannot perform time operations&
1169 & average, maximum, or minimum on static fields. Setting the time operation&
1170 & to "NONE" for this field.', warning)
1172 output_fields(out_num)%time_ops = .false.
1173 output_fields(out_num)%time_average = .false.
1174 output_fields(out_num)%time_method =
'point'
1179 output_fields(out_num)%num_axes = input_fields(field)%num_axes
1181 IF ( .NOT.output_fields(out_num)%local_output )
THEN
1182 output_fields(out_num)%axes(1:input_fields(field)%num_axes) =&
1183 & input_fields(field)%axes(1:input_fields(field)%num_axes)
1185 output_fields(out_num)%axes(1:input_fields(field)%num_axes) =&
1186 & output_fields(out_num)%output_grid%subaxes(1:input_fields(field)%num_axes)
1191 IF ( output_fields(out_num)%n_diurnal_samples > 1 )
THEN
1192 output_fields(out_num)%axes(output_fields(out_num)%num_axes+1) =&
1194 output_fields(out_num)%num_axes = output_fields(out_num)%num_axes+1
1197 IF ( output_fields(out_num)%reduced_k_range )
THEN
1201 output_fields(out_num)%axes(2) = output_fields(out_num)%output_grid%subaxes(2)
1203 output_fields(out_num)%axes(3) = output_fields(out_num)%output_grid%subaxes(3)
1209 output_fields(out_num)%Time_of_prev_field_data = time_zero
1213 IF ( len_trim(msg).GT.0 )
THEN
1214 CALL error_mesg (
'diag_manager_mod::register_static_field_old',&
1215 & trim(msg)//
' for module/field '//trim(module_name)//
'/'//trim(field_name),&
1220 IF (
PRESENT(realm) )
THEN
1221 CALL prepend_attribute(output_fields(out_num),
'modeling_realm', lowercase(trim(realm)))
1225 IF ( input_fields(field)%mask_variant )
THEN
1226 DO j = 1, input_fields(field)%num_output_fields
1227 out_num = input_fields(field)%output_fields(j)
1228 IF(output_fields(out_num)%time_average)
THEN
1234 if (output_fields(out_num)%reduced_k_range .and. &
1236 allocate(output_fields(out_num)%counter(siz(1),local_siz(2),siz(3), &
1237 output_fields(out_num)%n_diurnal_samples))
1239 allocate(output_fields(out_num)%counter(siz(1),siz(2),siz(3), &
1240 output_fields(out_num)%n_diurnal_samples))
1243 output_fields(out_num)%counter = 0.0
1254 CHARACTER(len=*),
INTENT(in) :: module_name
1255 CHARACTER(len=*),
INTENT(in) :: field_name
1260 if (use_modern_diag)
then
1261 get_diag_field_id = fms_diag_object%fms_get_diag_field_id_from_name(module_name, field_name)
1272 INTEGER,
INTENT(in) :: field
1274 INTEGER,
INTENT(out) :: out_field_id
1275 INTEGER,
INTENT(out) :: out_file_id
1277 INTEGER :: i, cm_ind, cm_file_num
1281 rel_file = rel_field%output_file
1289 DO i = 1, input_fields(field)%num_output_fields
1290 cm_ind = input_fields(field)%output_fields(i)
1291 cm_file_num = output_fields(cm_ind)%output_file
1293 IF ( cm_file_num.EQ.rel_file.AND.&
1294 & (( (output_fields(cm_ind)%time_ops.EQV.rel_field%time_ops) .AND.&
1295 & (output_fields(cm_ind)%next_output.EQ.rel_field%next_output) .AND.&
1296 & (output_fields(cm_ind)%last_output.EQ.rel_field%last_output) ).OR.&
1297 & (output_fields(cm_ind)%static.OR.rel_field%static) ) )
THEN
1299 out_field_id = cm_ind
1300 out_file_id = cm_file_num
1307 DO i = 1, input_fields(field)%num_output_fields
1308 cm_ind = input_fields(field)%output_fields(i)
1309 cm_file_num = output_fields(cm_ind)%output_file
1320 IF ( output_fields(cm_ind)%static.OR.rel_field%static )
THEN
1322 out_field_id = cm_ind
1323 out_file_id = cm_file_num
1333 INTEGER,
INTENT(in),
OPTIONAL :: area
1334 INTEGER,
INTENT(in),
OPTIONAL :: volume
1335 CHARACTER(len=*),
INTENT(out),
OPTIONAL :: err_msg
1337 INTEGER :: cm_ind, cm_file_num, file_num
1339 IF (
PRESENT(err_msg) )
THEN
1344 IF (
PRESENT(area) )
THEN
1345 IF ( area.LE.0 )
THEN
1347 &
'AREA field not in diag_table for field '//trim(input_fields(output_field%input_field)%module_name)//&
1348 &
'/'//trim(input_fields(output_field%input_field)%field_name), err_msg) )
RETURN
1352 IF (
PRESENT(volume) )
THEN
1353 IF ( volume.LE.0 )
THEN
1355 &
'VOLUME field not in diag_table for field '//trim(input_fields(output_field%input_field)%module_name)//&
1356 &
'/'//trim(input_fields(output_field%input_field)%field_name), err_msg) )
RETURN
1361 file_num = output_field%output_file
1364 IF (
PRESENT(area) )
THEN
1367 &
'area: '//trim(output_fields(cm_ind)%output_name))
1368 IF ( cm_file_num.NE.file_num )
THEN
1374 &
'AREA measures field "'//trim(input_fields(area)%module_name)//
'/'//&
1375 & trim(input_fields(area)%field_name)//&
1376 &
'" NOT in diag_table with correct output frequency for field '//&
1377 & trim(input_fields(output_field%input_field)%module_name)//&
1378 &
'/'//trim(input_fields(output_field%input_field)%field_name), err_msg) )
RETURN
1383 IF (
PRESENT(volume) )
THEN
1386 &
'volume: '//trim(output_fields(cm_ind)%output_name))
1387 IF ( cm_file_num.NE.file_num )
THEN
1393 &
'VOLUME measures field "'//trim(input_fields(volume)%module_name)//
'/'//&
1394 & trim(input_fields(volume)%field_name)//&
1395 &
'" NOT in diag_table with correct output frequency for field '//&
1396 & trim(input_fields(output_field%input_field)%module_name)//&
1397 &
'/'//trim(input_fields(output_field%input_field)%field_name), err_msg) )
RETURN
1408 INTEGER,
intent(in) :: file_num
1409 INTEGER,
intent(in) :: cm_file_num
1410 INTEGER,
intent(in) :: cm_ind
1412 INTEGER :: year, month, day, hour, minute, second
1414 CHARACTER(len=25) :: date_prefix
1415 CHARACTER(len=FMS_FILE_LEN) :: asso_file_name
1418 IF ( prepend_date )
THEN
1419 CALL get_date(diag_init_time, year, month, day, hour, minute, second)
1420 WRITE (date_prefix,
'(1I20.4, 2I2.2,".")') year, month, day
1421 date_prefix=adjustl(date_prefix)
1429 IF ( len_trim(files(cm_file_num)%name)+17 > len(asso_file_name) )
THEN
1430 CALL error_mesg (
'diag_manager_mod::add_associated_files',&
1431 &
'Length of asso_file_name is not long enough to hold the associated file name. '&
1432 & //
'Contact the developer', fatal)
1434 asso_file_name = trim(files(cm_file_num)%name)
1445 n = max(len_trim(asso_file_name),3)
1446 if (asso_file_name(n-2:n).NE.
'.nc') asso_file_name = trim(asso_file_name)//
'.nc'
1450 & trim(output_fields(cm_ind)%output_name)//
': '//&
1451 & trim(date_prefix)//trim(asso_file_name))
1456 INTEGER,
INTENT(in) :: diag_field_id
1457 CLASS(*),
INTENT(in) :: field
1458 TYPE(
time_type),
INTENT(in),
OPTIONAL :: time
1459 CHARACTER(len=*),
INTENT(out),
OPTIONAL :: err_msg
1461 CLASS(*),
allocatable :: field_out(:, :, :)
1464 IF ( diag_field_id <= 0 )
THEN
1471 TYPE IS (real(kind=r4_kind))
1472 allocate(real(r4_kind) :: field_out(1,1,1))
1473 select type(field_out)
1474 type is (real(r4_kind))
1475 field_out(1, 1, 1) = field
1477 call error_mesg(
'diag_manager_mod::send_data_0d', &
1478 &
'Error allocating field out as real(r4_kind)', fatal)
1480 TYPE IS (real(kind=r8_kind))
1481 allocate(real(r8_kind) :: field_out(1,1,1))
1482 select type(field_out)
1483 type is (real(r8_kind))
1484 field_out(1, 1, 1) = field
1486 call error_mesg(
'diag_manager_mod::send_data_0d', &
1487 &
'Error allocating field out as real(r8_kind)', fatal)
1490 CALL error_mesg (
'diag_manager_mod::send_data_0d',&
1491 &
'The field is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
1498 LOGICAL FUNCTION send_data_1d(diag_field_id, field, time, is_in, mask, rmask, ie_in, weight, err_msg)
1499 INTEGER,
INTENT(in) :: diag_field_id
1500 CLASS(*),
DIMENSION(:),
INTENT(in) :: field
1501 CLASS(*),
INTENT(in),
OPTIONAL :: weight
1502 CLASS(*),
INTENT(in),
DIMENSION(:),
OPTIONAL :: rmask
1503 TYPE (
time_type),
INTENT(in),
OPTIONAL :: time
1504 INTEGER,
INTENT(in),
OPTIONAL :: is_in, ie_in
1505 LOGICAL,
INTENT(in),
DIMENSION(:),
OPTIONAL :: mask
1506 CHARACTER(len=*),
INTENT(out),
OPTIONAL :: err_msg
1508 CLASS(*),
ALLOCATABLE :: field_out(:,:,:)
1509 LOGICAL,
DIMENSION(SIZE(field(:)), 1, 1) :: mask_out
1512 IF ( diag_field_id <= 0 )
THEN
1520 TYPE IS (real(kind=r4_kind))
1521 allocate(real(r4_kind) :: field_out(
SIZE(field),1,1))
1522 select type(field_out)
1523 type is (real(r4_kind))
1524 field_out(:, 1, 1) = field
1526 call error_mesg(
'diag_manager_mod::send_data_1d', &
1527 &
'Error allocating field out as real(r4_kind)', fatal)
1529 TYPE IS (real(kind=r8_kind))
1530 allocate(real(r8_kind) :: field_out(
SIZE(field),1,1))
1531 select type(field_out)
1532 type is (real(r8_kind))
1533 field_out(:, 1, 1) = field
1535 call error_mesg(
'diag_manager_mod::send_data_1d', &
1536 &
'Error allocating field out as real(r8_kind)', fatal)
1539 CALL error_mesg (
'diag_manager_mod::send_data_1d',&
1540 &
'The field is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
1544 IF (
PRESENT(mask) )
THEN
1545 mask_out(:, 1, 1) = mask
1550 IF (
PRESENT(rmask) )
THEN
1552 TYPE IS (real(kind=r4_kind))
1553 WHERE (rmask < 0.5_r4_kind) mask_out(:, 1, 1) = .false.
1554 TYPE IS (real(kind=r8_kind))
1555 WHERE (rmask < 0.5_r8_kind) mask_out(:, 1, 1) = .false.
1557 CALL error_mesg (
'diag_manager_mod::send_data_1d',&
1558 &
'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
1562 IF (
PRESENT(mask) .OR.
PRESENT(rmask) )
THEN
1563 IF (
PRESENT(is_in) .OR.
PRESENT(ie_in) )
THEN
1565 & mask=mask_out, ie_in=ie_in, je_in=1, ke_in=1, weight=weight, err_msg=err_msg)
1568 & weight=weight, err_msg=err_msg)
1571 IF (
PRESENT(is_in) .OR.
PRESENT(ie_in) )
THEN
1573 & ie_in=ie_in, je_in=1, ke_in=1, weight=weight, err_msg=err_msg)
1582 & mask, rmask, ie_in, je_in, weight, err_msg)
1583 INTEGER,
INTENT(in) :: diag_field_id
1584 CLASS(*),
INTENT(in),
DIMENSION(:,:) :: field
1585 CLASS(*),
INTENT(in),
OPTIONAL :: weight
1586 TYPE (
time_type),
INTENT(in),
OPTIONAL :: time
1587 INTEGER,
INTENT(in),
OPTIONAL :: is_in, js_in, ie_in, je_in
1588 LOGICAL,
INTENT(in),
DIMENSION(:,:),
OPTIONAL :: mask
1589 CLASS(*),
INTENT(in),
DIMENSION(:,:),
OPTIONAL :: rmask
1590 CHARACTER(len=*),
INTENT(out),
OPTIONAL :: err_msg
1592 CLASS(*),
ALLOCATABLE :: field_out(:,:,:)
1593 LOGICAL,
DIMENSION(SIZE(field,1),SIZE(field,2),1) :: mask_out
1596 IF ( diag_field_id <= 0 )
THEN
1603 TYPE IS (real(kind=r4_kind))
1604 allocate(real(r4_kind) :: field_out(
SIZE(field,1),
SIZE(field,2),1))
1605 select type(field_out)
1606 type is (real(r4_kind))
1607 field_out(:, :, 1) = field
1609 call error_mesg(
'diag_manager_mod::send_data_2d', &
1610 &
'Error allocating field out as real(r4_kind)', fatal)
1612 TYPE IS (real(kind=r8_kind))
1613 allocate(real(r8_kind) :: field_out(
SIZE(field,1),
SIZE(field,2),1))
1614 select type(field_out)
1615 type is (real(r8_kind))
1616 field_out(:, :, 1) = field
1618 call error_mesg(
'diag_manager_mod::send_data_2d', &
1619 &
'Error allocating field out as real(r8_kind)', fatal)
1622 CALL error_mesg (
'diag_manager_mod::send_data_2d',&
1623 &
'The field is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
1627 IF (
PRESENT(mask) )
THEN
1628 mask_out(:, :, 1) = mask
1633 IF (
PRESENT(rmask) )
THEN
1635 TYPE IS (real(kind=r4_kind))
1636 WHERE ( rmask < 0.5_r4_kind ) mask_out(:, :, 1) = .false.
1637 TYPE IS (real(kind=r8_kind))
1638 WHERE ( rmask < 0.5_r8_kind ) mask_out(:, :, 1) = .false.
1640 CALL error_mesg (
'diag_manager_mod::send_data_2d',&
1641 &
'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
1645 IF (
PRESENT(mask) .OR.
PRESENT(rmask) )
THEN
1647 & mask=mask_out, ie_in=ie_in, je_in=je_in, ke_in=1, weight=weight, err_msg=err_msg)
1650 & ie_in=ie_in, je_in=je_in, ke_in=1, weight=weight, err_msg=err_msg)
1655 LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
1656 & mask, rmask, ie_in, je_in, ke_in, weight, err_msg)
1657 INTEGER,
INTENT(in) :: diag_field_id
1658 CLASS(*),
DIMENSION(:,:,:),
INTENT(in) :: field
1659 CLASS(*),
INTENT(in),
OPTIONAL :: weight
1660 TYPE (
time_type),
INTENT(in),
OPTIONAL :: time
1661 INTEGER,
INTENT(in),
OPTIONAL :: is_in, js_in, ks_in,ie_in,je_in, ke_in
1662 LOGICAL,
DIMENSION(:,:,:),
INTENT(in),
OPTIONAL :: mask
1663 CLASS(*),
DIMENSION(:,:,:),
INTENT(in),
OPTIONAL :: rmask
1664 CHARACTER(len=*),
INTENT(out),
OPTIONAL :: err_msg
1666 if (
present(mask) .and.
present(rmask))
then
1668 mask=mask, rmask=rmask, ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, &
1670 elseif (
present(rmask))
then
1672 rmask=rmask, ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, err_msg=err_msg)
1673 elseif (
present(mask))
then
1675 mask=mask, ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, err_msg=err_msg)
1678 ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, err_msg=err_msg)
1685 & mask, rmask, ie_in, je_in, ke_in, weight, err_msg)
1686 INTEGER,
INTENT(in) :: diag_field_id
1687 CLASS(*),
DIMENSION(:,:,:),
INTENT(in),
TARGET,
CONTIGUOUS :: field
1688 CLASS(*),
INTENT(in),
OPTIONAL :: weight
1689 TYPE (
time_type),
INTENT(in),
OPTIONAL :: time
1690 INTEGER,
INTENT(in),
OPTIONAL :: is_in, js_in, ks_in,ie_in,je_in, ke_in
1691 LOGICAL,
DIMENSION(:,:,:),
INTENT(in),
OPTIONAL,
contiguous,
target :: mask
1692 CLASS(*),
DIMENSION(:,:,:),
INTENT(in),
OPTIONAL,
contiguous,
target :: rmask
1693 CHARACTER(len=*),
INTENT(out),
OPTIONAL :: err_msg
1697 INTEGER :: pow_value
1699 INTEGER :: i, out_num, file_num, n1, n2, n3, number_of_outputs, ii,f1,f2,f3,f4
1700 INTEGER :: freq, units, is, js, ks, ie, je, ke, i1, j1,k1, j, k
1701 INTEGER,
DIMENSION(3) :: l_start
1702 INTEGER,
DIMENSION(3) :: l_end
1712 INTEGER :: numthreads
1713 INTEGER :: active_omp_level
1714 #if defined(_OPENMP)
1715 INTEGER :: omp_get_num_threads
1716 INTEGER :: omp_get_level
1718 LOGICAL :: average, phys_window, need_compute
1719 LOGICAL :: reduced_k_range, local_output
1720 LOGICAL :: time_max, time_min, time_rms, time_sum
1721 LOGICAL :: missvalue_present
1722 LOGICAL,
ALLOCATABLE,
DIMENSION(:,:,:) :: oor_mask
1723 CHARACTER(len=256) :: err_msg_local
1724 CHARACTER(len=128) :: error_string, error_string1
1726 REAL,
ALLOCATABLE,
DIMENSION(:,:,:) :: field_out
1727 class(*),
allocatable,
dimension(:,:,:,:) :: field_remap
1728 logical,
allocatable,
dimension(:,:,:,:) :: mask_remap
1729 class(*),
allocatable,
dimension(:,:,:,:) :: rmask_remap
1730 REAL(kind=r4_kind),
POINTER,
DIMENSION(:,:,:) :: rmask_ptr_r4
1731 REAL(kind=r8_kind),
POINTER,
DIMENSION(:,:,:) :: rmask_ptr_r8
1735 LOGICAL :: mf_result
1737 REAL :: rmask_threshold
1739 character(len=:),
allocatable :: field_name
1742 IF ( diag_field_id <= 0 )
THEN
1749 IF (
PRESENT(err_msg) ) err_msg =
''
1750 IF ( .NOT.module_is_initialized )
THEN
1751 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d',
'diag_manager NOT initialized', err_msg) )
RETURN
1764 ALLOCATE(field_out(
SIZE(field,1),
SIZE(field,2),
SIZE(field,3)), stat=status)
1765 IF ( status .NE. 0 )
THEN
1766 WRITE (err_msg_local, fmt=
'("Unable to allocate field_out(",I5,",",I5,",",I5,"). (STAT: ",I5,")")')&
1767 &
SIZE(field,1),
SIZE(field,2),
SIZE(field,3), status
1768 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
RETURN
1771 TYPE IS (real(kind=r4_kind))
1773 TYPE IS (real(kind=r8_kind))
1774 field_out = real(field)
1776 CALL error_mesg (
'diag_manager_mod::send_data_3d',&
1777 &
'The field is not one of the supported types (real(kind=4) or real(kind=8)). '//&
1778 &
'If using an integer, please set use_modern_diag=.t. in the diag_manager_nml.', fatal)
1781 modern_if:
iF (use_modern_diag)
then
1782 field_name = fms_diag_object%fms_get_field_name_from_id(diag_field_id)
1783 call copy_3d_to_4d(field, field_remap, trim(field_name)//
"'s data")
1784 if (
present(rmask))
call copy_3d_to_4d(rmask, rmask_remap, trim(field_name)//
"'s mask")
1785 if (
present(mask))
then
1786 allocate(mask_remap(1:
size(mask,1), 1:
size(mask,2), 1:
size(mask,3), 1))
1787 mask_remap(:,:,:,1) = mask
1789 call fms_diag_object%fms_diag_accept_data(diag_field_id, field_remap, mask_remap, rmask_remap, &
1790 time, is_in, js_in, ks_in, ie_in, je_in, ke_in, weight, &
1792 deallocate (field_remap)
1793 if (
allocated(mask_remap))
deallocate(mask_remap)
1794 if (
allocated(rmask_remap))
deallocate(rmask_remap)
1797 ALLOCATE(oor_mask(
SIZE(field,1),
SIZE(field,2),
SIZE(field,3)), stat=status)
1798 IF ( status .NE. 0 )
THEN
1799 WRITE (err_msg_local, fmt=
'("Unable to allocate oor_mask(",I5,",",I5,",",I5,"). (STAT: ",I5,")")')&
1800 &
SIZE(field,1),
SIZE(field,2),
SIZE(field,3), status
1801 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
RETURN
1804 IF (
PRESENT(mask) )
THEN
1810 rmask_ptr_r4 => null()
1811 rmask_ptr_r8 => null()
1812 IF (
PRESENT(rmask) )
THEN
1814 TYPE IS (real(kind=r4_kind))
1815 WHERE ( rmask < 0.5_r4_kind ) oor_mask = .false.
1816 rmask_threshold = 0.5_r4_kind
1817 rmask_ptr_r4 => rmask
1818 TYPE IS (real(kind=r8_kind))
1819 WHERE ( rmask < 0.5_r8_kind ) oor_mask = .false.
1820 rmask_threshold = 0.5_r8_kind
1821 rmask_ptr_r8 => rmask
1823 CALL error_mesg (
'diag_manager_mod::send_data_3d',&
1824 &
'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
1839 IF (
PRESENT(ie_in) )
THEN
1840 IF ( .NOT.
PRESENT(is_in) )
THEN
1841 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d',
'ie_in present without is_in', err_msg) )
THEN
1842 DEALLOCATE(field_out)
1843 DEALLOCATE(oor_mask)
1847 IF (
PRESENT(js_in) .AND. .NOT.
PRESENT(je_in) )
THEN
1849 &
'is_in and ie_in present, but js_in present without je_in', err_msg) )
THEN
1850 DEALLOCATE(field_out)
1851 DEALLOCATE(oor_mask)
1856 IF (
PRESENT(je_in) )
THEN
1857 IF ( .NOT.
PRESENT(js_in) )
THEN
1858 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d',
'je_in present without js_in', err_msg) )
THEN
1859 DEALLOCATE(field_out)
1860 DEALLOCATE(oor_mask)
1864 IF (
PRESENT(is_in) .AND. .NOT.
PRESENT(ie_in) )
THEN
1866 &
'js_in and je_in present, but is_in present without ie_in', err_msg))
THEN
1867 DEALLOCATE(field_out)
1868 DEALLOCATE(oor_mask)
1878 IF (
PRESENT(is_in) ) is = is_in
1879 IF (
PRESENT(js_in) ) js = js_in
1880 IF (
PRESENT(ks_in) ) ks = ks_in
1887 IF (
PRESENT(ie_in) ) ie = ie_in
1888 IF (
PRESENT(je_in) ) je = je_in
1889 IF (
PRESENT(ke_in) ) ke = ke_in
1890 twohi = n1-(ie-is+1)
1891 IF ( mod(twohi,2) /= 0 )
THEN
1892 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d',
'non-symmetric halos in first dimension', &
1894 DEALLOCATE(field_out)
1895 DEALLOCATE(oor_mask)
1899 twohj = n2-(je-js+1)
1900 IF ( mod(twohj,2) /= 0 )
THEN
1901 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d',
'non-symmetric halos in second dimension', &
1903 DEALLOCATE(field_out)
1904 DEALLOCATE(oor_mask)
1913 IF (
PRESENT(ie_in) .AND.
PRESENT(je_in) )
THEN
1927 IF (
PRESENT(weight) )
THEN
1928 SELECT TYPE (weight)
1929 TYPE IS (real(kind=r4_kind))
1931 TYPE IS (real(kind=r8_kind))
1932 weight1 = real(weight)
1934 CALL error_mesg (
'diag_manager_mod::send_data_3d',&
1935 &
'The weight is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
1942 missvalue_present = input_fields(diag_field_id)%missing_value_present
1943 IF ( missvalue_present ) missvalue = input_fields(diag_field_id)%missing_value
1945 number_of_outputs = input_fields(diag_field_id)%num_output_fields
1947 input_fields(diag_field_id)%numthreads = 1
1949 #if defined(_OPENMP)
1950 input_fields(diag_field_id)%numthreads = omp_get_num_threads()
1951 input_fields(diag_field_id)%active_omp_level = omp_get_level()
1953 numthreads = input_fields(diag_field_id)%numthreads
1954 active_omp_level = input_fields(diag_field_id)%active_omp_level
1957 if(
present(time)) input_fields(diag_field_id)%time = time
1960 IF ( input_fields(diag_field_id)%range_present )
THEN
1961 IF ( issue_oor_warnings .OR. oor_warnings_fatal )
THEN
1962 WRITE (error_string,
'("[",ES14.5E3,",",ES14.5E3,"]")')&
1963 & input_fields(diag_field_id)%range(1:2)
1964 WRITE (error_string1,
'("(Min: ",ES14.5E3,", Max: ",ES14.5E3, ")")')&
1965 & minval(field_out(f1:f2,f3:f4,ks:ke),mask=oor_mask(f1:f2,f3:f4,ks:ke)),&
1966 & maxval(field_out(f1:f2,f3:f4,ks:ke),mask=oor_mask(f1:f2,f3:f4,ks:ke))
1967 IF ( missvalue_present )
THEN
1968 IF ( any(oor_mask(f1:f2,f3:f4,ks:ke) .AND.&
1969 & ((field_out(f1:f2,f3:f4,ks:ke) < input_fields(diag_field_id)%range(1) .OR.&
1970 & field_out(f1:f2,f3:f4,ks:ke) > input_fields(diag_field_id)%range(2)).AND.&
1971 & field_out(f1:f2,f3:f4,ks:ke) .NE. missvalue)) )
THEN
1977 CALL error_mesg(
'diag_manager_mod::send_data_3d',&
1979 &trim(input_fields(diag_field_id)%module_name)//
' in field '//&
1980 &trim(input_fields(diag_field_id)%field_name)//
' '&
1981 &//trim(error_string1)//&
1982 &
' is outside the range '//trim(error_string)//
',&
1983 & and not equal to the missing value.',&
1987 IF ( any(oor_mask(f1:f2,f3:f4,ks:ke) .AND.&
1988 & (field_out(f1:f2,f3:f4,ks:ke) < input_fields(diag_field_id)%range(1) .OR.&
1989 & field_out(f1:f2,f3:f4,ks:ke) > input_fields(diag_field_id)%range(2))) )
THEN
1994 CALL error_mesg(
'diag_manager_mod::send_data_3d',&
1996 &trim(input_fields(diag_field_id)%module_name)//
' in field '//&
1997 &trim(input_fields(diag_field_id)%field_name)//
' '&
1998 &//trim(error_string1)//&
1999 &
' is outside the range '//trim(error_string)//
'.',&
2007 num_out_fields:
DO ii = 1, number_of_outputs
2009 out_num = input_fields(diag_field_id)%output_fields(ii)
2012 local_output = output_fields(out_num)%local_output
2014 need_compute = output_fields(out_num)%need_compute
2016 reduced_k_range = output_fields(out_num)%reduced_k_range
2019 IF ( local_output .AND. (.NOT.need_compute) ) cycle
2022 file_num = output_fields(out_num)%output_file
2023 IF(file_num == max_files) cycle
2025 freq = files(file_num)%output_freq
2026 units = files(file_num)%output_units
2028 average = output_fields(out_num)%time_average
2031 time_rms = output_fields(out_num)%time_rms
2033 pow_value = output_fields(out_num)%pow_value
2035 time_max = output_fields(out_num)%time_max
2036 time_min = output_fields(out_num)%time_min
2038 time_sum = output_fields(out_num)%time_sum
2039 IF ( output_fields(out_num)%total_elements >
SIZE(field_out(f1:f2,f3:f4,ks:ke)) )
THEN
2040 output_fields(out_num)%phys_window = .true.
2042 output_fields(out_num)%phys_window = .false.
2044 phys_window = output_fields(out_num)%phys_window
2045 IF ( need_compute )
THEN
2046 l_start = output_fields(out_num)%output_grid%l_start_indx
2047 l_end = output_fields(out_num)%output_grid%l_end_indx
2052 IF (
PRESENT(time) )
THEN
2053 CALL get_time(time,second,day,tick)
2055 & * output_fields(out_num)%n_diurnal_samples/seconds_per_day) + 1
2059 IF ( reduced_k_range )
THEN
2062 if (output_fields(out_num)%reduced_k_unstruct)
then
2063 js = output_fields(out_num)%output_grid%l_start_indx(2)
2064 je = output_fields(out_num)%output_grid%l_end_indx(2)
2066 l_start(3) = output_fields(out_num)%output_grid%l_start_indx(3)
2067 l_end(3) = output_fields(out_num)%output_grid%l_end_indx(3)
2074 IF ( freq == every_time .AND. .NOT.output_fields(out_num)%static )
THEN
2075 IF (
PRESENT(time))
THEN
2076 IF ( numthreads .ne. 1 .or. active_omp_level .gt. 1)
THEN
2080 IF ( time > output_fields(out_num)%last_output )
THEN
2081 output_fields(out_num)%next_output = time
2087 IF ( output_fields(out_num)%next_output == output_fields(out_num)%last_output )
THEN
2088 output_fields(out_num)%next_output = time
2091 ELSE IF ( output_fields(out_num)%next_output == output_fields(out_num)%last_output )
THEN
2092 WRITE (error_string,
'(a,"/",a)')&
2093 & trim(input_fields(diag_field_id)%module_name),&
2094 & trim(output_fields(out_num)%output_name)
2095 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d',
'module/output_field '//trim(error_string)//&
2096 &
', time must be present when output frequency = EVERY_TIME', err_msg))
THEN
2097 DEALLOCATE(field_out)
2098 DEALLOCATE(oor_mask)
2103 IF ( .NOT.output_fields(out_num)%static .AND. .NOT.
PRESENT(time) )
THEN
2104 WRITE (error_string,
'(a,"/",a)')&
2105 & trim(input_fields(diag_field_id)%module_name), &
2106 & trim(output_fields(out_num)%output_name)
2107 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d',
'module/output_field '//trim(error_string)//&
2108 &
', time must be present for nonstatic field', err_msg))
THEN
2109 DEALLOCATE(field_out)
2110 DEALLOCATE(oor_mask)
2118 IF ( (numthreads == 1) .AND. (active_omp_level.LE.1) )
then
2119 IF ( .NOT.output_fields(out_num)%static .AND. freq /= end_of_run )
THEN
2120 IF ( time > output_fields(out_num)%next_output )
THEN
2122 IF ( time > output_fields(out_num)%next_next_output .AND. freq > 0 )
THEN
2123 IF (
mpp_pe() .EQ. mpp_root_pe() )
THEN
2124 WRITE (error_string,
'(a,"/",a)')&
2125 & trim(input_fields(diag_field_id)%module_name), &
2126 & trim(output_fields(out_num)%output_name)
2127 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d',
'module/output_field '//&
2128 & trim(error_string)//
' is skipped one time level in output data', err_msg))
THEN
2129 DEALLOCATE(field_out)
2130 DEALLOCATE(oor_mask)
2136 status =
writing_field(out_num, .false., error_string, time)
2137 IF(status == -1)
THEN
2138 IF (
mpp_pe() .EQ. mpp_root_pe() )
THEN
2139 IF(
fms_error_handler(
'diag_manager_mod::send_data_3d',
'module/output_field '//trim(error_string)&
2140 & //
', write EMPTY buffer', err_msg))
THEN
2141 DEALLOCATE(field_out)
2142 DEALLOCATE(oor_mask)
2152 if (
present(time))
then
2154 if (output_fields(out_num)%last_output > time) cycle
2157 IF ( .NOT.output_fields(out_num)%static .AND. .NOT.need_compute .AND. debug_diag_manager )
THEN
2159 IF ( err_msg_local /=
'' )
THEN
2160 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
2161 DEALLOCATE(field_out)
2162 DEALLOCATE(oor_mask)
2168 IF (use_refactored_send)
THEN
2169 ALLOCATE( ofield_index_cfg )
2170 CALL ofield_index_cfg%initialize( is, js, ks, ie, je, ke, &
2171 & hi, hj, f1, f2, f3, f4)
2173 ALLOCATE( ofield_cfg )
2174 CALL ofield_cfg%initialize( input_fields(diag_field_id), output_fields(out_num),
PRESENT(mask), freq)
2178 mf_result =
fieldbuff_update(ofield_cfg, ofield_index_cfg, field_out, sample, &
2179 & output_fields(out_num)%buffer, output_fields(out_num)%counter ,output_fields(out_num)%buff_bounds,&
2180 & output_fields(out_num)%count_0d(sample), output_fields(out_num)%num_elements(sample), &
2181 & mask, weight1 ,missvalue, &
2182 & input_fields(diag_field_id)%numthreads, input_fields(diag_field_id)%active_omp_level,&
2183 & input_fields(diag_field_id)%issued_mask_ignore_warning, &
2184 & l_start, l_end, err_msg, err_msg_local )
2185 IF (mf_result .eqv. .false.)
THEN
2186 DEALLOCATE(ofield_index_cfg)
2187 DEALLOCATE(ofield_cfg)
2188 DEALLOCATE(field_out)
2189 DEALLOCATE(oor_mask)
2194 & output_fields(out_num)%buffer, output_fields(out_num)%buff_bounds , &
2195 & output_fields(out_num)%count_0d(sample), &
2196 & mask, missvalue, l_start, l_end, err_msg, err_msg_local)
2197 IF (mf_result .eqv. .false.)
THEN
2198 DEALLOCATE(ofield_index_cfg)
2199 DEALLOCATE(ofield_cfg)
2200 DEALLOCATE(field_out)
2201 DEALLOCATE(oor_mask)
2206 IF ( output_fields(out_num)%static .AND. .NOT.need_compute .AND. debug_diag_manager )
THEN
2208 IF ( err_msg_local /=
'' )
THEN
2209 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg))
THEN
2210 DEALLOCATE(field_out)
2211 DEALLOCATE(oor_mask)
2238 IF(
ALLOCATED(ofield_index_cfg))
THEN
2239 DEALLOCATE(ofield_index_cfg)
2241 IF(
ALLOCATED(ofield_cfg))
THEN
2242 DEALLOCATE(ofield_cfg)
2249 IF ( input_fields(diag_field_id)%mask_variant )
THEN
2250 IF ( need_compute )
THEN
2251 WRITE (error_string,
'(a,"/",a)') &
2252 & trim(input_fields(diag_field_id)%module_name), &
2253 & trim(output_fields(out_num)%output_name)
2254 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d',
'module/output_field '//trim(error_string)//&
2255 &
', regional output NOT supported with mask_variant', err_msg))
THEN
2256 DEALLOCATE(field_out)
2257 DEALLOCATE(oor_mask)
2264 IF (
PRESENT(mask) )
THEN
2265 IF ( missvalue_present )
THEN
2266 IF ( debug_diag_manager )
THEN
2267 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
2269 IF ( err_msg_local /=
'' )
THEN
2270 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
2271 DEALLOCATE(field_out)
2272 DEALLOCATE(oor_mask)
2277 IF( numthreads>1 .AND. phys_window )
then
2278 IF ( reduced_k_range )
THEN
2283 IF ( mask(i-is+1+hi, j-js+1+hj, k) )
THEN
2284 IF ( pow_value /= 1 )
THEN
2285 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2286 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2287 & (field_out(i-is+1+hi, j-js+1+hj, k) * weight1)**(pow_value)
2289 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2290 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2291 & field_out(i-is+1+hi, j-js+1+hj, k) * weight1
2293 output_fields(out_num)%counter(i-hi,j-hj,k1,sample) =&
2294 & output_fields(out_num)%counter(i-hi,j-hj,k1,sample) + weight1
2303 IF ( mask(i-is+1+hi, j-js+1+hj, k) )
THEN
2304 IF ( pow_value /= 1 )
THEN
2305 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2306 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2307 & (field_out(i-is+1+hi,j-js+1+hj,k)*weight1)**(pow_value)
2309 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2310 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2311 & field_out(i-is+1+hi,j-js+1+hj,k)*weight1
2313 output_fields(out_num)%counter(i-hi,j-hj,k,sample) =&
2314 &output_fields(out_num)%counter(i-hi,j-hj,k,sample) + weight1
2322 IF ( reduced_k_range )
THEN
2327 IF ( mask(i-is+1+hi, j-js+1+hj, k) )
THEN
2328 IF ( pow_value /= 1 )
THEN
2329 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2330 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2331 & (field_out(i-is+1+hi, j-js+1+hj, k) * weight1)**(pow_value)
2333 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2334 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2335 & field_out(i-is+1+hi, j-js+1+hj, k) * weight1
2337 output_fields(out_num)%counter(i-hi,j-hj,k1,sample) =&
2338 & output_fields(out_num)%counter(i-hi,j-hj,k1,sample) + weight1
2347 IF ( mask(i-is+1+hi, j-js+1+hj, k) )
THEN
2348 IF ( pow_value /= 1 )
THEN
2349 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2350 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2351 & (field_out(i-is+1+hi,j-js+1+hj,k)*weight1)**(pow_value)
2353 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2354 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2355 & field_out(i-is+1+hi,j-js+1+hj,k)*weight1
2357 output_fields(out_num)%counter(i-hi,j-hj,k,sample) =&
2358 &output_fields(out_num)%counter(i-hi,j-hj,k,sample) + weight1
2367 WRITE (error_string,
'(a,"/",a)')&
2368 & trim(input_fields(diag_field_id)%module_name), &
2369 & trim(output_fields(out_num)%output_name)
2370 IF(
fms_error_handler(
'diag_manager_mod::send_data_3d',
'module/output_field '//trim(error_string)//&
2371 &
', variable mask but no missing value defined', err_msg))
THEN
2372 DEALLOCATE(field_out)
2373 DEALLOCATE(oor_mask)
2378 WRITE (error_string,
'(a,"/",a)')&
2379 & trim(input_fields(diag_field_id)%module_name), &
2380 & trim(output_fields(out_num)%output_name)
2381 IF(
fms_error_handler(
'diag_manager_mod::send_data_3d',
'module/output_field '//trim(error_string)//&
2382 &
', variable mask but no mask given', err_msg))
THEN
2383 DEALLOCATE(field_out)
2384 DEALLOCATE(oor_mask)
2389 IF (
PRESENT(mask) )
THEN
2390 IF ( missvalue_present )
THEN
2391 IF ( need_compute )
THEN
2392 IF (numthreads>1 .AND. phys_window)
then
2393 DO k = l_start(3), l_end(3)
2397 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2398 & j <= l_end(2)+hj )
THEN
2399 i1 = i-l_start(1)-hi+1
2400 j1= j-l_start(2)-hj+1
2401 IF ( mask(i-is+1+hi, j-js+1+hj, k) )
THEN
2402 IF ( pow_value /= 1 )
THEN
2403 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2404 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2405 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2407 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2408 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2409 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2412 output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
2420 DO k = l_start(3), l_end(3)
2424 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2425 & j <= l_end(2)+hj )
THEN
2426 i1 = i-l_start(1)-hi+1
2427 j1= j-l_start(2)-hj+1
2428 IF ( mask(i-is+1+hi, j-js+1+hj, k) )
THEN
2429 IF ( pow_value /= 1 )
THEN
2430 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2431 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2432 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2434 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2435 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2436 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2439 output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
2450 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2451 & j <= l_end(2)+hj )
THEN
2452 output_fields(out_num)%num_elements(sample) = &
2453 output_fields(out_num)%num_elements(sample) + l_end(3) - l_start(3) + 1
2458 ELSE IF ( reduced_k_range )
THEN
2459 IF (numthreads>1 .AND. phys_window)
then
2464 IF ( mask(i-is+1+hi,j-js+1+hj,k) )
THEN
2465 IF ( pow_value /= 1 )
THEN
2466 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2467 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2468 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2470 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2471 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2472 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2475 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue
2486 IF ( mask(i-is+1+hi,j-js+1+hj,k) )
THEN
2487 IF ( pow_value /= 1 )
THEN
2488 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2489 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2490 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2492 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2493 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2494 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2497 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue
2505 IF ( debug_diag_manager )
THEN
2506 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
2508 IF ( err_msg_local /=
'' )
THEN
2509 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
2510 DEALLOCATE(field_out)
2511 DEALLOCATE(oor_mask)
2516 IF (numthreads>1 .AND. phys_window)
then
2520 IF ( mask(i-is+1+hi,j-js+1+hj,k) )
THEN
2521 IF ( pow_value /= 1 )
THEN
2522 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2523 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2524 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2526 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2527 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2528 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2531 output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue
2541 IF ( mask(i-is+1+hi,j-js+1+hj,k) )
THEN
2542 IF ( pow_value /= 1 )
THEN
2543 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2544 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2545 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2547 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2548 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2549 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2552 output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue
2561 IF ( need_compute .AND. .NOT.phys_window )
THEN
2562 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))) ) &
2563 & output_fields(out_num)%count_0d(sample) =&
2564 & output_fields(out_num)%count_0d(sample) + weight1
2566 IF ( any(mask(f1:f2,f3:f4,ks:ke)) ) output_fields(out_num)%count_0d(sample) =&
2567 & output_fields(out_num)%count_0d(sample)+weight1
2572 IF ( (.NOT.all(mask(f1:f2,f3:f4,ks:ke)) .AND.
mpp_pe() .EQ. mpp_root_pe()).AND.&
2573 & .NOT.input_fields(diag_field_id)%issued_mask_ignore_warning )
THEN
2578 CALL error_mesg(
'diag_manager_mod::send_data_3d',&
2579 &
'Mask will be ignored since missing values were not specified for field '//&
2580 & trim(input_fields(diag_field_id)%field_name)//
' in module '//&
2581 & trim(input_fields(diag_field_id)%module_name), warning)
2582 input_fields(diag_field_id)%issued_mask_ignore_warning = .true.
2584 IF ( need_compute )
THEN
2585 IF (numthreads>1 .AND. phys_window)
then
2588 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2589 & j <= l_end(2)+hj )
THEN
2590 i1 = i-l_start(1)-hi+1
2591 j1 = j-l_start(2)-hj+1
2592 IF ( pow_value /= 1 )
THEN
2593 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2594 & output_fields(out_num)%buffer(i1,j1,:,sample)+ &
2595 & (field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value)
2597 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2598 & output_fields(out_num)%buffer(i1,j1,:,sample)+ &
2599 & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
2608 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2609 & j <= l_end(2)+hj )
THEN
2610 i1 = i-l_start(1)-hi+1
2611 j1 = j-l_start(2)-hj+1
2612 IF ( pow_value /= 1 )
THEN
2613 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2614 & output_fields(out_num)%buffer(i1,j1,:,sample)+ &
2615 & (field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value)
2617 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2618 & output_fields(out_num)%buffer(i1,j1,:,sample)+ &
2619 & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
2629 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2630 & j <= l_end(2)+hj )
THEN
2631 output_fields(out_num)%num_elements(sample)=&
2632 & output_fields(out_num)%num_elements(sample)+l_end(3)-l_start(3)+1
2638 ELSE IF ( reduced_k_range )
THEN
2639 IF (numthreads>1 .AND. phys_window)
then
2642 IF ( pow_value /= 1 )
THEN
2643 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2644 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) +&
2645 & (field_out(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value)
2647 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2648 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) +&
2649 & field_out(f1:f2,f3:f4,ksr:ker)*weight1
2655 IF ( pow_value /= 1 )
THEN
2656 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2657 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) +&
2658 & (field_out(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value)
2660 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2661 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) +&
2662 & field_out(f1:f2,f3:f4,ksr:ker)*weight1
2667 IF ( debug_diag_manager )
THEN
2668 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
2670 IF ( err_msg_local /=
'')
THEN
2671 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
2672 DEALLOCATE(field_out)
2673 DEALLOCATE(oor_mask)
2678 IF (numthreads>1 .AND. phys_window)
then
2679 IF ( pow_value /= 1 )
THEN
2680 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
2681 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
2682 & (field_out(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value)
2684 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
2685 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
2686 & field_out(f1:f2,f3:f4,ks:ke)*weight1
2690 IF ( pow_value /= 1 )
THEN
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)**(pow_value)
2695 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
2696 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
2697 & field_out(f1:f2,f3:f4,ks:ke)*weight1
2703 IF ( .NOT.phys_window ) output_fields(out_num)%count_0d(sample) =&
2704 & output_fields(out_num)%count_0d(sample) + weight1
2708 IF ( missvalue_present )
THEN
2709 IF ( need_compute )
THEN
2710 if( numthreads>1 .AND. phys_window )
then
2711 DO k = l_start(3), l_end(3)
2712 k1 = k - l_start(3) + 1
2715 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2716 & j <= l_end(2)+hj)
THEN
2717 i1 = i-l_start(1)-hi+1
2718 j1= j-l_start(2)-hj+1
2719 IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue )
THEN
2720 IF ( pow_value /= 1 )
THEN
2721 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2722 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2723 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2725 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2726 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2727 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2730 output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
2738 DO k = l_start(3), l_end(3)
2739 k1 = k - l_start(3) + 1
2742 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2743 & j <= l_end(2)+hj)
THEN
2744 i1 = i-l_start(1)-hi+1
2745 j1= j-l_start(2)-hj+1
2746 IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue )
THEN
2747 IF ( pow_value /= 1 )
THEN
2748 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2749 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2750 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2752 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2753 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2754 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2757 output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
2768 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2769 & j <= l_end(2)+hj)
THEN
2770 output_fields(out_num)%num_elements(sample) =&
2771 & output_fields(out_num)%num_elements(sample) + l_end(3) - l_start(3) + 1
2775 IF ( .NOT.phys_window )
THEN
2776 outer0:
DO k = l_start(3), l_end(3)
2777 DO j=l_start(2)+hj, l_end(2)+hj
2778 DO i=l_start(1)+hi, l_end(1)+hi
2779 IF ( field_out(i,j,k) /= missvalue )
THEN
2780 output_fields(out_num)%count_0d(sample) = output_fields(out_num)%count_0d(sample)&
2789 ELSE IF ( reduced_k_range )
THEN
2790 if( numthreads>1 .AND. phys_window )
then
2797 IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue )
THEN
2798 IF ( pow_value /= 1 )
THEN
2799 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2800 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2801 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2803 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2804 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2805 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2808 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) = missvalue
2821 IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue )
THEN
2822 IF ( pow_value /= 1 )
THEN
2823 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2824 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2825 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2827 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2828 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2829 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2832 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) = missvalue
2840 outer3:
DO k = ksr, ker
2844 IF ( field_out(i,j,k) /= missvalue )
THEN
2845 output_fields(out_num)%count_0d(sample) = output_fields(out_num)%count_0d(sample) &
2854 IF ( debug_diag_manager )
THEN
2855 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
2857 IF ( err_msg_local /=
'' )
THEN
2858 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
2859 DEALLOCATE(field_out)
2860 DEALLOCATE(oor_mask)
2865 IF( numthreads > 1 .AND. phys_window )
then
2869 IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue )
THEN
2870 IF ( pow_value /= 1 )
THEN
2871 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2872 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2873 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2875 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2876 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2877 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2880 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) = missvalue
2890 IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue )
THEN
2891 IF ( pow_value /= 1 )
THEN
2892 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2893 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2894 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2896 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2897 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2898 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2901 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) = missvalue
2912 IF ( field_out(i,j,k) /= missvalue )
THEN
2913 output_fields(out_num)%count_0d(sample) = output_fields(out_num)%count_0d(sample) &
2923 IF ( need_compute )
THEN
2924 IF( numthreads > 1 .AND. phys_window )
then
2927 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2928 & j <= l_end(2)+hj )
THEN
2929 i1 = i-l_start(1)-hi+1
2930 j1= j-l_start(2)-hj+1
2931 IF ( pow_value /= 1 )
THEN
2932 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2933 & output_fields(out_num)%buffer(i1,j1,:,sample) +&
2934 & (field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value)
2936 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2937 & output_fields(out_num)%buffer(i1,j1,:,sample) +&
2938 & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
2947 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2948 & j <= l_end(2)+hj )
THEN
2949 i1 = i-l_start(1)-hi+1
2950 j1= j-l_start(2)-hj+1
2951 IF ( pow_value /= 1 )
THEN
2952 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2953 & output_fields(out_num)%buffer(i1,j1,:,sample) +&
2954 & (field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value)
2956 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2957 & output_fields(out_num)%buffer(i1,j1,:,sample) +&
2958 & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
2969 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2970 & j <= l_end(2)+hj )
THEN
2971 output_fields(out_num)%num_elements(sample) =&
2972 & output_fields(out_num)%num_elements(sample)+l_end(3)-l_start(3)+1
2978 ELSE IF ( reduced_k_range )
THEN
2981 IF( numthreads > 1 .AND. phys_window )
then
2982 IF ( pow_value /= 1 )
THEN
2983 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2984 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
2985 & (field_out(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value)
2987 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2988 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
2989 & field_out(f1:f2,f3:f4,ksr:ker)*weight1
2993 IF ( pow_value /= 1 )
THEN
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)**(pow_value)
2998 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2999 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
3000 & field_out(f1:f2,f3:f4,ksr:ker)*weight1
3005 IF ( debug_diag_manager )
THEN
3006 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3008 IF ( err_msg_local /=
'' )
THEN
3009 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3010 DEALLOCATE(field_out)
3011 DEALLOCATE(oor_mask)
3016 IF( numthreads > 1 .AND. phys_window )
then
3017 IF ( pow_value /= 1 )
THEN
3018 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
3019 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
3020 & (field_out(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value)
3022 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
3023 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
3024 & field_out(f1:f2,f3:f4,ks:ke)*weight1
3028 IF ( pow_value /= 1 )
THEN
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)**(pow_value)
3033 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
3034 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
3035 & field_out(f1:f2,f3:f4,ks:ke)*weight1
3041 IF ( .NOT.phys_window ) output_fields(out_num)%count_0d(sample) =&
3042 & output_fields(out_num)%count_0d(sample) + weight1
3048 IF ( .NOT.need_compute .AND. .NOT.reduced_k_range )&
3049 & output_fields(out_num)%num_elements(sample) =&
3050 & output_fields(out_num)%num_elements(sample) + (ie-is+1)*(je-js+1)*(ke-ks+1)
3051 IF ( reduced_k_range ) &
3052 & output_fields(out_num)%num_elements(sample) = output_fields(out_num)%num_elements(sample) +&
3053 & (ie-is+1)*(je-js+1)*(ker-ksr+1)
3056 ELSE IF ( time_max )
THEN
3057 IF (
PRESENT(mask) )
THEN
3058 IF ( need_compute )
THEN
3059 DO k = l_start(3), l_end(3)
3060 k1 = k - l_start(3) + 1
3063 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
3064 & j <= l_end(2)+hj )
THEN
3065 i1 = i-l_start(1)-hi+1
3066 j1= j-l_start(2)-hj+1
3067 IF ( mask(i-is+1+hi,j-js+1+hj,k) .AND. field_out(i-is+1+hi,j-js+1+hj,k)>&
3068 & output_fields(out_num)%buffer(i1,j1,k1,sample) )
THEN
3069 output_fields(out_num)%buffer(i1,j1,k1,sample) = field_out(i-is+1+hi,j-js+1+hj,k)
3076 ELSE IF ( reduced_k_range )
THEN
3079 WHERE ( mask(f1:f2,f3:f4,ksr:ker) .AND. field_out(f1:f2,f3:f4,ksr:ker) >&
3080 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) )&
3081 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker)
3083 IF ( debug_diag_manager )
THEN
3084 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3086 IF ( err_msg_local /=
'' )
THEN
3087 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3088 DEALLOCATE(field_out)
3089 DEALLOCATE(oor_mask)
3094 WHERE ( mask(f1:f2,f3:f4,ks:ke) .AND. field_out(f1:f2,f3:f4,ks:ke)>&
3095 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) )&
3096 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke)
3099 IF ( need_compute )
THEN
3100 DO k = l_start(3), l_end(3)
3101 k1 = k - l_start(3) + 1
3104 IF(l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
3105 & j <= l_end(2)+hj )
THEN
3106 i1 = i-l_start(1)-hi+1
3107 j1 = j-l_start(2)-hj+1
3108 IF ( field_out(i-is+1+hi,j-js+1+hj,k)>output_fields(out_num)%buffer(i1,j1,k1,sample) )
THEN
3109 output_fields(out_num)%buffer(i1,j1,k1,sample) = field_out(i-is+1+hi,j-js+1+hj,k)
3116 ELSE IF ( reduced_k_range )
THEN
3119 WHERE ( field_out(f1:f2,f3:f4,ksr:ker) >&
3120 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) ) &
3121 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker)
3123 IF ( debug_diag_manager )
THEN
3124 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3126 IF ( err_msg_local /=
'' )
THEN
3127 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3128 DEALLOCATE(field_out)
3129 DEALLOCATE(oor_mask)
3134 WHERE ( field_out(f1:f2,f3:f4,ks:ke) >&
3135 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) ) &
3136 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke)
3139 output_fields(out_num)%count_0d(sample) = 1
3140 ELSE IF ( time_min )
THEN
3141 IF (
PRESENT(mask) )
THEN
3142 IF ( need_compute )
THEN
3143 DO k = l_start(3), l_end(3)
3144 k1 = k - l_start(3) + 1
3147 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
3148 & j <= l_end(2)+hj )
THEN
3149 i1 = i-l_start(1)-hi+1
3150 j1 = j-l_start(2)-hj+1
3151 IF ( mask(i-is+1+hi,j-js+1+hj,k) .AND. field_out(i-is+1+hi,j-js+1+hj,k) <&
3152 & output_fields(out_num)%buffer(i1,j1,k1,sample) )
THEN
3153 output_fields(out_num)%buffer(i1,j1,k1,sample) = field_out(i-is+1+hi,j-js+1+hj,k)
3160 ELSE IF ( reduced_k_range )
THEN
3163 WHERE ( mask(f1:f2,f3:f4,ksr:ker) .AND. field_out(f1:f2,f3:f4,ksr:ker) <&
3164 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) ) &
3165 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker)
3167 IF ( debug_diag_manager )
THEN
3168 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3170 IF ( err_msg_local /=
'' )
THEN
3171 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3172 DEALLOCATE(field_out)
3173 DEALLOCATE(oor_mask)
3178 WHERE ( mask(f1:f2,f3:f4,ks:ke) .AND. field_out(f1:f2,f3:f4,ks:ke) <&
3179 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) ) &
3180 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke)
3183 IF ( need_compute )
THEN
3184 DO k = l_start(3), l_end(3)
3185 k1 = k - l_start(3) + 1
3188 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
3189 i1 = i-l_start(1)-hi+1
3190 j1= j-l_start(2)-hj+1
3191 IF ( field_out(i-is+1+hi,j-js+1+hj,k) <&
3192 & output_fields(out_num)%buffer(i1,j1,k1,sample) )
THEN
3193 output_fields(out_num)%buffer(i1,j1,k1,sample) = field_out(i-is+1+hi,j-js+1+hj,k)
3200 ELSE IF ( reduced_k_range )
THEN
3203 WHERE ( field_out(f1:f2,f3:f4,ksr:ker) <&
3204 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) ) &
3205 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker)
3207 IF ( debug_diag_manager )
THEN
3208 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3210 IF ( err_msg_local /=
'' )
THEN
3211 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3212 DEALLOCATE(field_out)
3213 DEALLOCATE(oor_mask)
3218 WHERE ( field_out(f1:f2,f3:f4,ks:ke) <&
3219 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) )&
3220 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke)
3223 output_fields(out_num)%count_0d(sample) = 1
3224 ELSE IF ( time_sum )
THEN
3225 IF (
PRESENT(mask) )
THEN
3226 IF ( need_compute )
THEN
3227 DO k = l_start(3), l_end(3)
3228 k1 = k - l_start(3) + 1
3231 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
3232 & j <= l_end(2)+hj )
THEN
3233 i1 = i-l_start(1)-hi+1
3234 j1 = j-l_start(2)-hj+1
3235 IF ( mask(i-is+1+hi,j-js+1+hj,k) )
THEN
3236 output_fields(out_num)%buffer(i1,j1,k1,sample) = &
3237 output_fields(out_num)%buffer(i1,j1,k1,sample) + &
3238 field_out(i-is+1+hi,j-js+1+hj,k)
3245 ELSE IF ( reduced_k_range )
THEN
3248 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = &
3249 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
3250 & field_out(f1:f2,f3:f4,ksr:ker)
3252 IF ( debug_diag_manager )
THEN
3253 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3255 IF ( err_msg_local /=
'' )
THEN
3256 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3257 DEALLOCATE(field_out)
3258 DEALLOCATE(oor_mask)
3263 WHERE ( mask(f1:f2,f3:f4,ks:ke) ) &
3264 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = &
3265 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) + &
3266 & field_out(f1:f2,f3:f4,ks:ke)
3269 IF ( need_compute )
THEN
3270 DO k = l_start(3), l_end(3)
3271 k1 = k - l_start(3) + 1
3274 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
3275 i1 = i-l_start(1)-hi+1
3276 j1= j-l_start(2)-hj+1
3277 output_fields(out_num)%buffer(i1,j1,k1,sample) = &
3278 & output_fields(out_num)%buffer(i1,j1,k1,sample) + &
3279 & field_out(i-is+1+hi,j-js+1+hj,k)
3284 ELSE IF ( reduced_k_range )
THEN
3287 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = &
3288 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
3289 & field_out(f1:f2,f3:f4,ksr:ker)
3291 IF ( debug_diag_manager )
THEN
3292 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3294 IF ( err_msg_local /=
'' )
THEN
3295 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3296 DEALLOCATE(field_out)
3297 DEALLOCATE(oor_mask)
3302 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = &
3303 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) + &
3304 & field_out(f1:f2,f3:f4,ks:ke)
3307 output_fields(out_num)%count_0d(sample) = 1
3309 output_fields(out_num)%count_0d(sample) = 1
3310 IF ( need_compute )
THEN
3313 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
3314 i1 = i-l_start(1)-hi+1
3315 j1 = j-l_start(2)-hj+1
3316 output_fields(out_num)%buffer(i1,j1,:,sample) =&
3317 & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))
3322 ELSE IF ( reduced_k_range )
THEN
3325 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker)
3327 IF ( debug_diag_manager )
THEN
3328 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3330 IF ( err_msg_local /=
'' )
THEN
3331 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3332 DEALLOCATE(field_out)
3333 DEALLOCATE(oor_mask)
3338 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke)
3341 IF (
PRESENT(mask) .AND. missvalue_present )
THEN
3342 IF ( need_compute )
THEN
3343 DO k = l_start(3), l_end(3)
3344 k1 = k - l_start(3) + 1
3347 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
3348 & j <= l_end(2)+hj )
THEN
3349 i1 = i-l_start(1)-hi+1
3350 j1 = j-l_start(2)-hj+1
3351 IF ( .NOT.mask(i-is+1+hi,j-js+1+hj,k) )&
3352 & output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
3357 ELSE IF ( reduced_k_range )
THEN
3364 IF ( .NOT.mask(i-is+1+hi,j-js+1+hj,k) ) &
3365 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue
3373 IF ( .NOT.mask(i-is+1+hi,j-js+1+hj,k) )&
3374 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue
3382 IF ( output_fields(out_num)%static .AND. .NOT.need_compute .AND. debug_diag_manager )
THEN
3384 IF ( err_msg_local /=
'' )
THEN
3385 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg))
THEN
3386 DEALLOCATE(field_out)
3387 DEALLOCATE(oor_mask)
3396 IF (
PRESENT(rmask) .AND. missvalue_present )
THEN
3397 IF ( need_compute )
THEN
3399 TYPE IS (real(kind=r4_kind))
3400 DO k = l_start(3), l_end(3)
3401 k1 = k - l_start(3) + 1
3404 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND.&
3405 & j <= l_end(2)+hj )
THEN
3406 i1 = i-l_start(1)-hi+1
3407 j1 = j-l_start(2)-hj+1
3408 IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r4_kind ) &
3409 & output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
3414 TYPE IS (real(kind=r8_kind))
3415 DO k = l_start(3), l_end(3)
3416 k1 = k - l_start(3) + 1
3419 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND.&
3420 & j <= l_end(2)+hj )
THEN
3421 i1 = i-l_start(1)-hi+1
3422 j1 = j-l_start(2)-hj+1
3423 IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r8_kind ) &
3424 & output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
3430 CALL error_mesg (
'diag_manager_mod::send_data_3d',&
3431 &
'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
3433 ELSE IF ( reduced_k_range )
THEN
3437 TYPE IS (real(kind=r4_kind))
3442 IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r4_kind ) &
3443 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue
3447 TYPE IS (real(kind=r8_kind))
3452 IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r8_kind ) &
3453 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue
3458 CALL error_mesg (
'diag_manager_mod::send_data_3d',&
3459 &
'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
3463 TYPE IS (real(kind=r4_kind))
3467 IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r4_kind ) &
3468 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue
3472 TYPE IS (real(kind=r8_kind))
3476 IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r8_kind ) &
3477 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue
3482 CALL error_mesg (
'diag_manager_mod::send_data_3d',&
3483 &
'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
3488 END DO num_out_fields
3490 DEALLOCATE(field_out)
3491 DEALLOCATE(oor_mask)
3497 LOGICAL FUNCTION send_data_4d(diag_field_id, field, time, is_in, js_in, ks_in, &
3498 & mask, rmask, ie_in, je_in, ke_in, weight, err_msg)
3499 INTEGER,
INTENT(in) :: diag_field_id
3500 CLASS(*),
INTENT(in) :: field(:,:,:,:)
3501 CLASS(*),
INTENT(in),
OPTIONAL :: weight
3502 TYPE (
time_type),
INTENT(in),
OPTIONAL :: time
3503 INTEGER,
INTENT(in),
OPTIONAL :: is_in
3504 INTEGER,
INTENT(in),
OPTIONAL :: js_in
3505 INTEGER,
INTENT(in),
OPTIONAL :: ks_in
3506 INTEGER,
INTENT(in),
OPTIONAL :: ie_in
3507 INTEGER,
INTENT(in),
OPTIONAL :: je_in
3508 INTEGER,
INTENT(in),
OPTIONAL :: ke_in
3509 LOGICAL,
INTENT(in),
OPTIONAL :: mask(:,:,:,:)
3510 CLASS(*),
INTENT(in),
OPTIONAL :: rmask(:,:,:,:)
3511 CHARACTER(len=*),
INTENT(out),
OPTIONAL :: err_msg
3514 class(*),
allocatable :: rmask_local(:,:,:,:)
3515 logical,
allocatable :: mask_local(:,:,:,:)
3518 IF ( diag_field_id <= 0 )
THEN
3523 if (.not. use_modern_diag) &
3524 call mpp_error(fatal,
"Send_data_4d is only supported when diag_manager_nml::use_modern_diag=.true.")
3527 if (
present(mask)) mask_local = mask
3528 if (
present(rmask)) rmask_local = rmask
3530 call fms_diag_object%fms_diag_accept_data(diag_field_id, field, mask_local, rmask_local, &
3531 time, is_in, js_in, ks_in, ie_in, je_in, ke_in, weight, &
3535 if (
present(err_msg))
then
3536 if (err_msg .ne.
"")
then
3543 if (
allocated(rmask_local))
deallocate(rmask_local)
3544 if (
allocated(mask_local))
deallocate(mask_local)
3549 INTEGER,
INTENT(in) :: id
3550 REAL,
INTENT(in) :: field(:,:)
3551 REAL,
INTENT(in) :: area (:,:)
3553 LOGICAL,
INTENT(in),
OPTIONAL :: mask (:,:)
3555 REAL,
DIMENSION(SIZE(field,1)) :: out(size(field,1))
3569 INTEGER,
INTENT(in) :: diag_field_id
3570 REAL,
DIMENSION(:,:),
INTENT(in) :: x
3571 REAL,
DIMENSION(:,:),
INTENT(in) :: area
3572 LOGICAL,
DIMENSION(:,:),
INTENT(in) :: mask
3573 REAL,
DIMENSION(:),
INTENT(out) :: out
3576 REAL,
DIMENSION(SIZE(x,1)) :: s
3577 REAL :: local_missing_value
3581 IF ( diag_field_id <= 0 )
THEN
3585 CALL error_mesg(
'diag_manager_mod::average_tiles1d',&
3586 &
"diag_field_id less than 0. Contact developers.", fatal)
3590 IF ( input_fields(diag_field_id)%missing_value_present )
THEN
3591 local_missing_value = input_fields(diag_field_id)%missing_value
3593 local_missing_value = 0.0
3600 DO it = 1,
SIZE(area,dim=2)
3601 WHERE ( mask(:,it) )
3602 out(:) = out(:) + x(:,it)*area(:,it)
3603 s(:) = s(:) + area(:,it)
3608 out(:) = out(:)/s(:)
3610 out(:) = local_missing_value
3616 INTEGER,
INTENT(in) :: id
3617 REAL,
INTENT(in) :: field(:,:,:)
3618 REAL,
INTENT(in) :: area (:,:,:)
3620 LOGICAL,
INTENT(in),
OPTIONAL :: mask (:,:,:)
3622 REAL,
DIMENSION(SIZE(field,1),SIZE(field,2)) :: out(size(field,1), size(field,2))
3636 INTEGER,
INTENT(in) :: id
3637 REAL,
DIMENSION(:,:,:,:),
INTENT(in) :: field
3638 REAL,
DIMENSION(:,:,:),
INTENT(in) :: area (:,:,:)
3641 LOGICAL,
DIMENSION(:,:,:),
INTENT(in),
OPTIONAL :: mask
3643 REAL,
DIMENSION(SIZE(field,1),SIZE(field,2),SIZE(field,4)) :: out
3644 LOGICAL,
DIMENSION(SIZE(field,1),SIZE(field,2),SIZE(field,4)) :: mask3
3653 DO it=1,
SIZE(field,4)
3654 CALL average_tiles(id, field(:,:,:,it), area, mask, out(:,:,it) )
3657 mask3(:,:,1) = any(mask,dim=3)
3658 DO it = 2,
SIZE(field,4)
3659 mask3(:,:,it) = mask3(:,:,1)
3667 INTEGER,
INTENT(in) :: diag_field_id
3668 REAL,
DIMENSION(:,:,:),
INTENT(in) :: x
3669 REAL,
DIMENSION(:,:,:),
INTENT(in) :: area
3670 LOGICAL,
DIMENSION(:,:,:),
INTENT(in) :: mask
3671 REAL,
DIMENSION(:,:),
INTENT(out) :: out
3674 REAL,
DIMENSION(SIZE(x,1),SIZE(x,2)) :: s
3675 REAL :: local_missing_value
3679 IF ( diag_field_id <= 0 )
THEN
3683 CALL error_mesg(
'diag_manager_mod::average_tiles',&
3684 &
"diag_field_id less than 0. Contact developers.", fatal)
3688 IF ( input_fields(diag_field_id)%missing_value_present )
THEN
3689 local_missing_value = input_fields(diag_field_id)%missing_value
3691 local_missing_value = 0.0
3698 DO it = 1,
SIZE(area,3)
3699 WHERE ( mask(:,:,it) )
3700 out(:,:) = out(:,:) + x(:,:,it)*area(:,:,it)
3701 s(:,:) = s(:,:) + area(:,:,it)
3705 WHERE ( s(:,:) > 0 )
3706 out(:,:) = out(:,:)/s(:,:)
3708 out(:,:) = local_missing_value
3714 INTEGER,
INTENT(in) :: out_num
3715 LOGICAL,
INTENT(in) :: at_diag_end
3716 CHARACTER(len=*),
INTENT(out) :: error_string
3721 LOGICAL :: time_max, time_min, reduced_k_range, missvalue_present
3722 LOGICAL :: average, time_rms, need_compute, phys_window
3723 INTEGER :: in_num, file_num, freq, units
3724 INTEGER :: b1,b2,b3,b4
3725 INTEGER :: i, j, k, m
3726 REAL :: missvalue, num
3729 need_compute = output_fields(out_num)%need_compute
3731 in_num = output_fields(out_num)%input_field
3732 IF ( input_fields(in_num)%static )
RETURN
3734 missvalue = input_fields(in_num)%missing_value
3735 missvalue_present = input_fields(in_num)%missing_value_present
3736 reduced_k_range = output_fields(out_num)%reduced_k_range
3737 phys_window = output_fields(out_num)%phys_window
3739 average = output_fields(out_num)%time_average
3742 time_rms = output_fields(out_num)%time_rms
3744 time_max = output_fields(out_num)%time_max
3745 time_min = output_fields(out_num)%time_min
3746 file_num = output_fields(out_num)%output_file
3747 freq = files(file_num)%output_freq
3748 units = files(file_num)%output_units
3752 b1=
SIZE(output_fields(out_num)%buffer,1)
3753 b2=
SIZE(output_fields(out_num)%buffer,2)
3754 b3=
SIZE(output_fields(out_num)%buffer,3)
3755 b4=
SIZE(output_fields(out_num)%buffer,4)
3756 IF ( input_fields(in_num)%mask_variant )
THEN
3761 IF ( output_fields(out_num)%counter(i,j,k,m) > 0. )
THEN
3762 output_fields(out_num)%buffer(i,j,k,m) = &
3763 & output_fields(out_num)%buffer(i,j,k,m)/output_fields(out_num)%counter(i,j,k,m)
3764 IF ( time_rms ) output_fields(out_num)%buffer(i,j,k,m) = &
3765 sqrt(output_fields(out_num)%buffer(i,j,k,m))
3767 output_fields(out_num)%buffer(i,j,k,m) = missvalue
3775 IF ( phys_window )
THEN
3776 IF ( need_compute .OR. reduced_k_range )
THEN
3777 num = real(output_fields(out_num)%num_elements(m)/output_fields(out_num)%region_elements)
3779 num = real(output_fields(out_num)%num_elements(m)/output_fields(out_num)%total_elements)
3782 num = output_fields(out_num)%count_0d(m)
3784 IF ( num > 0. )
THEN
3785 IF ( missvalue_present )
THEN
3789 IF ( output_fields(out_num)%buffer(i,j,k,m) /= missvalue )
THEN
3790 output_fields(out_num)%buffer(i,j,k,m) = output_fields(out_num)%buffer(i,j,k,m)/num
3791 IF ( time_rms ) output_fields(out_num)%buffer(i,j,k,m) =&
3792 & sqrt(output_fields(out_num)%buffer(i,j,k,m))
3798 output_fields(out_num)%buffer(:,:,:,m) = output_fields(out_num)%buffer(:,:,:,m)/num
3799 IF ( time_rms ) output_fields(out_num)%buffer(:,:,:,m) =&
3800 & sqrt(output_fields(out_num)%buffer(:,:,:,m))
3802 ELSE IF ( .NOT. at_diag_end )
THEN
3803 IF ( missvalue_present )
THEN
3804 IF(any(output_fields(out_num)%buffer /= missvalue))
THEN
3805 WRITE (error_string,
'(a,"/",a)')&
3806 & trim(input_fields(in_num)%module_name), &
3807 & trim(output_fields(out_num)%output_name)
3815 ELSE IF ( time_min .OR. time_max )
THEN
3816 IF ( missvalue_present )
THEN
3817 WHERE ( abs(output_fields(out_num)%buffer) == min_value )
3818 output_fields(out_num)%buffer = missvalue
3824 IF ( at_diag_end .AND. freq == end_of_run ) output_fields(out_num)%next_output = time
3826 IF ( (output_fields(out_num)%time_ops) .AND. (.NOT. mix_snapshot_average_fields) )
THEN
3827 middle_time = (output_fields(out_num)%last_output+output_fields(out_num)%next_output)/2
3828 if (trim(files(file_num)%filename_time_bounds) ==
"begin")
then
3829 filename_time = output_fields(out_num)%last_output
3830 elseif (trim(files(file_num)%filename_time_bounds) ==
"middle")
then
3831 filename_time = middle_time
3832 elseif (trim(files(file_num)%filename_time_bounds) ==
"end")
then
3833 filename_time = output_fields(out_num)%next_output
3836 CALL diag_data_out(file_num, out_num, output_fields(out_num)%buffer, middle_time, &
3837 & filename_time=filename_time)
3840 & output_fields(out_num)%buffer, output_fields(out_num)%next_output)
3844 IF ( at_diag_end )
RETURN
3847 output_fields(out_num)%last_output = output_fields(out_num)%next_output
3848 IF ( freq == end_of_run )
THEN
3849 output_fields(out_num)%next_output = time
3851 IF ( freq == every_time )
THEN
3852 output_fields(out_num)%next_output = time
3854 output_fields(out_num)%next_output = output_fields(out_num)%next_next_output
3855 output_fields(out_num)%next_next_output = &
3856 & diag_time_inc(output_fields(out_num)%next_next_output, freq, units)
3858 output_fields(out_num)%count_0d(:) = 0.0
3859 output_fields(out_num)%num_elements(:) = 0
3860 IF ( time_max )
THEN
3861 output_fields(out_num)%buffer = max_value
3862 ELSE IF ( time_min )
THEN
3863 output_fields(out_num)%buffer = min_value
3865 output_fields(out_num)%buffer = empty
3867 IF ( input_fields(in_num)%mask_variant .AND. average ) output_fields(out_num)%counter = 0.0
3871 SUBROUTINE diag_manager_set_time_end(Time_end_in)
3872 TYPE (
time_type),
INTENT(in) :: time_end_in
3874 time_end = time_end_in
3875 if (use_modern_diag)
then
3876 call fms_diag_object%set_time_end(time_end_in)
3879 END SUBROUTINE diag_manager_set_time_end
3894 integer :: file, j, freq, in_num, file_num, out_num
3896 DO file = 1, num_files
3897 freq = files(file)%output_freq
3899 DO j = 1, files(file)%num_fields
3900 out_num = files(file)%fields(j)
3901 in_num = output_fields(out_num)%input_field
3902 IF ( (input_fields(in_num)%numthreads == 1) .AND.&
3903 & (input_fields(in_num)%active_omp_level.LE.1) ) cycle
3904 file_num = output_fields(out_num)%output_file
3906 & output_fields(out_num)%buffer, time)
3915 TYPE (
time_type),
INTENT(in) :: time_step
3916 character(len=*),
INTENT(out),
optional :: err_msg
3919 integer :: file, j, out_num, in_num, freq, status
3920 logical :: local_output, need_compute
3921 CHARACTER(len=128) :: error_string
3923 IF ( time_end == time_zero )
THEN
3927 CALL error_mesg(
'diag_manager_mod::diag_send_complete',&
3928 &
"diag_manager_set_time_end must be called before diag_send_complete", fatal)
3931 if (use_modern_diag)
then
3932 call fms_diag_object%fms_diag_send_complete(time_step)
3936 DO file = 1, num_files
3937 freq = files(file)%output_freq
3938 DO j = 1, files(file)%num_fields
3939 out_num = files(file)%fields(j)
3940 in_num = output_fields(out_num)%input_field
3942 IF ( (input_fields(in_num)%numthreads == 1) .AND. (input_fields(in_num)%active_omp_level.LE.1) ) cycle
3943 IF ( output_fields(out_num)%static .OR. freq == end_of_run ) cycle
3944 time = input_fields(in_num)%time
3945 IF ( time >= time_end ) cycle
3948 local_output = output_fields(out_num)%local_output
3950 need_compute = output_fields(out_num)%need_compute
3952 IF ( local_output .AND. (.NOT.need_compute) ) cycle
3953 next_time = time + time_step
3955 IF ( next_time > output_fields(out_num)%next_output )
THEN
3957 IF ( next_time > output_fields(out_num)%next_next_output .AND. freq > 0 )
THEN
3958 IF (
mpp_pe() .EQ. mpp_root_pe() )
THEN
3959 WRITE (error_string,
'(a,"/",a)')&
3960 & trim(input_fields(in_num)%module_name), &
3961 & trim(output_fields(out_num)%output_name)
3963 &
'module/output_field '//trim(error_string)//&
3964 &
' is skipped one time level in output data', err_msg))
RETURN
3968 status =
writing_field(out_num, .false., error_string, next_time)
3969 IF ( status == -1 )
THEN
3970 IF (
mpp_pe() .EQ. mpp_root_pe() )
THEN
3971 IF(
fms_error_handler(
'diag_manager_mod::diag_send_complete',
'module/output_field '//&
3972 & trim(error_string)//
', write EMPTY buffer', err_msg))
RETURN
3988 IF ( do_diag_field_log )
THEN
3989 close (diag_log_unit)
3991 DO file = 1, num_files
3994 if (
allocated(fileobju))
deallocate(fileobju)
3995 if (
allocated(fileobj))
deallocate(fileobj)
3996 if (
allocated(fileobjnd))
deallocate(fileobjnd)
3999 if (use_modern_diag)
then
4000 call fms_diag_object%diag_end(time)
4006 INTEGER,
INTENT(in) :: file
4009 INTEGER :: j, i, input_num, freq, status
4010 INTEGER :: stdout_unit
4011 LOGICAL :: reduced_k_range, need_compute, local_output
4012 CHARACTER(len=128) :: message
4017 DO j = 1, files(file)%num_fields
4018 i = files(file)%fields(j)
4021 local_output = output_fields(i)%local_output
4023 need_compute = output_fields(i)%need_compute
4025 reduced_k_range = output_fields(i)%reduced_k_range
4028 IF ( local_output .AND. (.NOT. need_compute) ) cycle
4030 input_num = output_fields(i)%input_field
4031 IF ( input_fields(input_num)%static ) cycle
4032 IF ( .NOT.input_fields(input_num)%register ) cycle
4033 freq = files(file)%output_freq
4034 IF ( freq /= end_of_run .AND. files(file)%file_unit < 0 &
4035 & .AND. all(output_fields(i)%num_elements(:) == 0)&
4036 & .AND. all(output_fields(i)%count_0d(:) == 0) ) cycle
4039 IF ( time >= output_fields(i)%next_output .OR. freq == end_of_run )
THEN
4040 IF ( time >= output_fields(i)%next_next_output .AND. freq > 0 )
THEN
4041 WRITE (message,
'(a,"/",a)') trim(input_fields(input_num)%module_name), &
4042 & trim(output_fields(i)%output_name)
4047 IF (
mpp_pe() .EQ. mpp_root_pe() ) &
4048 &
CALL error_mesg(
'diag_manager_mod::closing_file',
'module/output_field ' //&
4049 & trim(message)//
', skip one time level, maybe send_data never called', warning)
4054 ELSEIF ( .NOT.output_fields(i)%written_once )
THEN
4059 CALL error_mesg(
'Potential error in diag_manager_end ',&
4060 & trim(output_fields(i)%output_name)//
' NOT available,'//&
4061 &
' check if output interval > runlength. Netcdf fill_values are written', note)
4062 output_fields(i)%buffer = fill_value
4063 CALL diag_data_out(file, i, output_fields(i)%buffer, time, .true.)
4070 IF ( write_bytes_in_file )
THEN
4071 CALL mpp_sum (files(file)%bytes_written)
4072 IF (
mpp_pe() == mpp_root_pe() )&
4073 &
WRITE (stdout_unit,
'(a,i12,a,a)')
'Diag_Manager: ',files(file)%bytes_written, &
4074 &
' bytes of data written to file ',trim(files(file)%name)
4081 INTEGER,
OPTIONAL,
INTENT(IN) :: diag_model_subset
4082 INTEGER,
DIMENSION(6),
OPTIONAL,
INTENT(IN) :: time_init
4083 CHARACTER(len=*),
INTENT(out),
OPTIONAL :: err_msg
4085 CHARACTER(len=*),
PARAMETER :: sep =
'|'
4087 INTEGER,
PARAMETER :: fltkind = r4_kind
4088 INTEGER,
PARAMETER :: dblkind = r8_kind
4089 INTEGER :: diag_subset_output
4091 INTEGER,
ALLOCATABLE,
DIMENSION(:) :: pelist
4092 INTEGER :: stdlog_unit, stdout_unit
4094 CHARACTER(len=256) :: err_msg_local
4096 namelist /diag_manager_nml/ append_pelist_name, mix_snapshot_average_fields, max_output_fields, &
4097 & max_input_fields, max_axes, do_diag_field_log, write_bytes_in_file, debug_diag_manager,&
4098 & max_num_axis_sets, max_files, use_cmor, issue_oor_warnings,&
4099 & oor_warnings_fatal, max_out_per_in_field, flush_nc_files, region_out_use_alt_value, max_field_attributes,&
4100 & max_file_attributes, max_axis_attributes, prepend_date, use_modern_diag, use_clock_average, &
4104 IF ( module_is_initialized )
RETURN
4107 IF (
PRESENT(err_msg) ) err_msg =
''
4112 call diag_data_init()
4115 pack_size =
SIZE(transfer(0.0_dblkind, (/0.0, 0.0, 0.0, 0.0/)))
4116 IF (pack_size .EQ. 1)
then
4117 pack_size_str =
"double"
4118 else if (pack_size .EQ. 2)
then
4119 pack_size_str =
"float"
4121 IF (
fms_error_handler(
'diag_manager_mod::diag_manager_init',
'unknown pack_size. Must be 1, or 2.', &
4126 min_value = huge(0.0_fltkind)
4127 max_value = -min_value
4138 time_end = time_zero
4139 diag_subset_output = diag_all
4140 IF (
PRESENT(diag_model_subset) )
THEN
4141 IF ( diag_model_subset >= diag_other .AND. diag_model_subset <= diag_all )
THEN
4142 diag_subset_output = diag_model_subset
4144 IF (
fms_error_handler(
'diag_manager_mod::diag_manager_init',
'invalid value of diag_model_subset', &
4149 READ (input_nml_file, nml=diag_manager_nml, iostat=mystat)
4152 IF (
check_nml_error(iostat=mystat, nml_name=
'DIAG_MANAGER_NML') < 0 )
THEN
4153 IF (
mpp_pe() == mpp_root_pe() )
THEN
4154 CALL error_mesg(
'diag_manager_mod::diag_manager_init', &
4155 &
'DIAG_MANAGER_NML not found in input nml file. Using defaults.', warning)
4159 IF (.not. use_modern_diag .and. use_clock_average) &
4160 call mpp_error(fatal,
"diag_manager_mod: You cannot set use_modern_diag=.false. and &
4161 & use_clock_average=.true. in diag_manager_nml")
4163 IF (
mpp_pe() == mpp_root_pe() )
THEN
4164 WRITE (stdlog_unit, diag_manager_nml)
4168 IF ( use_cmor )
THEN
4170 WRITE (err_msg_local,
'(ES8.1E2)') cmor_missing_value
4171 CALL error_mesg(
'diag_manager_mod::diag_manager_init',
'Using CMOR missing value ('//trim(err_msg_local)// &
4176 IF ( oor_warnings_fatal )
THEN
4178 CALL error_mesg(
'diag_manager_mod::diag_manager_init',
'Out &
4179 &of Range warnings are fatal.', note)
4180 ELSEIF ( .NOT.issue_oor_warnings )
THEN
4181 CALL error_mesg(
'diag_manager_mod::diag_manager_init',
'Out &
4182 &of Range warnings will be ignored.', note)
4185 IF ( mix_snapshot_average_fields )
THEN
4186 IF ( .not. use_modern_diag )
THEN
4187 CALL error_mesg(
'diag_manager_mod::diag_manager_init',
'Setting diag_manager_nml variable '//&
4188 &
'mix_snapshot_average_fields = .TRUE. will cause ERRORS in the time coordinates '//&
4189 &
'of all time averaged fields. Strongly recommend setting mix_snapshot_average_fields '//&
4190 &
'= .FALSE.', note)
4192 CALL error_mesg(
'diag_manager_mod::diag_manager_init',
'mix_snapshot_average_fields = .TRUE. is not '//&
4193 &
'supported if use_modern_diag = .TRUE. Please set mix_snapshot_average_fields '//&
4194 &
'to .FALSE. and put instantaneous and averaged fields in separate files!', fatal)
4197 ALLOCATE(output_fields(max_output_fields))
4198 ALLOCATE(input_fields(max_input_fields))
4199 DO j = 1, max_input_fields
4200 ALLOCATE(input_fields(j)%output_fields(max_out_per_in_field))
4203 ALLOCATE(files(max_files))
4204 ALLOCATE(fileobju(max_files))
4205 ALLOCATE(fileobj(max_files))
4206 ALLOCATE(fileobjnd(max_files))
4211 CALL mpp_get_current_pelist(pelist, pelist_name)
4214 IF (
PRESENT(time_init) )
THEN
4215 diag_init_time =
set_date(time_init(1), time_init(2), time_init(3), time_init(4),&
4216 & time_init(5), time_init(6))
4218 diag_init_time = get_base_time()
4219 IF ( prepend_date .EQV. .true. )
THEN
4220 CALL error_mesg(
'diag_manager_mod::diag_manager_init',&
4221 &
'prepend_date only supported when diag_manager_init is called with time_init present.', note)
4222 prepend_date = .false.
4226 if (use_modern_diag)
then
4227 CALL error_mesg(
'diag_manager_mod::diag_manager_init',&
4228 &
'You are using the yaml version of the diag table', note)
4229 CALL fms_diag_object%init(diag_subset_output, time_init)
4231 if (.not. use_modern_diag)
then
4232 CALL error_mesg(
'diag_manager_mod::diag_manager_init',&
4233 &
'You are using the legacy version of the diag table', note)
4234 CALL parse_diag_table(diag_subset=diag_subset_output, istat=mystat, err_msg=err_msg_local)
4235 IF ( mystat /= 0 )
THEN
4237 &
'Error parsing diag_table. '//trim(err_msg_local), err_msg) )
RETURN
4241 files(:)%bytes_written = 0
4244 IF ( do_diag_field_log.AND.
mpp_pe().EQ.mpp_root_pe() )
THEN
4245 open(newunit=diag_log_unit, file=
'diag_field_log.out.'//
string(
mpp_pe()), action=
'WRITE')
4246 WRITE (diag_log_unit,
'(777a)') &
4254 module_is_initialized = .true.
4256 if(.not. use_modern_diag) null_axis_id = diag_axis_init(
'scalar_axis', (/0./),
'none',
'N',
'none')
4263 INTEGER,
INTENT(out) :: year, month, day, hour, minute, second
4266 IF (.NOT.module_is_initialized)
CALL error_mesg (
'diag_manager_mod::get_base_date', &
4267 &
'module has not been initialized', fatal)
4268 year = get_base_year()
4269 month = get_base_month()
4270 day = get_base_day()
4271 hour = get_base_hour()
4272 minute = get_base_minute()
4273 second = get_base_second()
4283 TYPE(
time_type),
INTENT(in) :: next_model_time
4284 INTEGER,
INTENT(in) :: diag_field_id
4286 INTEGER :: i, out_num
4289 IF ( diag_field_id < 0 )
RETURN
4290 DO i = 1, input_fields(diag_field_id)%num_output_fields
4292 out_num = input_fields(diag_field_id)%output_fields(i)
4293 IF ( .NOT.output_fields(out_num)%static )
THEN
4294 IF ( next_model_time > output_fields(out_num)%next_output )
need_data=.true.
4298 IF ( output_fields(out_num)%time_average)
need_data = .true.
4310 INTEGER,
INTENT(in) :: n_samples
4312 REAL :: center_data (n_samples)
4313 REAL :: edges (n_samples+1)
4322 CHARACTER(32) :: name
4323 CHARACTER(128) :: units
4326 WRITE (units,11)
'hours', year, month, day, hour, minute, second
4327 11
FORMAT(a,
' since ',i4.4,
'-',i2.2,
'-',i2.2,
' ',i2.2,
':',i2.2,
':',i2.2)
4331 center_data(i) = 24.0*(real(i)-0.5)/n_samples
4332 edges(i+1) = 24.0* real(i)/n_samples
4337 WRITE (name,
'(a,i2.2)')
'time_of_day_edges_', n_samples
4338 edges_id = get_axis_num(name,
'diurnal')
4339 IF ( edges_id <= 0 )
THEN
4340 edges_id = diag_axis_init(name,edges,units,
'N',
'time of day edges', set_name=
'diurnal')
4345 WRITE (name,
'(a,i2.2)')
'time_of_day_', n_samples
4348 init_diurnal_axis = diag_axis_init(name, center_data, units,
'N',
'time of day', &
4349 set_name=
'diurnal', edges=edges_id)
4354 INTEGER,
INTENT(in) :: diag_field_id
4355 CHARACTER(len=*),
INTENT(in) :: name
4356 INTEGER,
INTENT(in) ::
type
4357 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: cval
4358 INTEGER,
DIMENSION(:),
INTENT(in),
OPTIONAL :: ival
4359 REAL,
DIMENSION(:),
INTENT(in),
OPTIONAL :: rval
4361 INTEGER :: istat, length, i, j, this_attribute, out_field
4363 IF ( .NOT.first_send_data_call )
THEN
4369 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',
'Attempting to add attribute "'&
4370 &//trim(name)//
'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//
'/'&
4371 &//trim(input_fields(diag_field_id)%field_name)//
'" after first send_data call. Too late.', fatal)
4375 IF ( diag_field_id .LE. 0 )
THEN
4378 DO j=1,input_fields(diag_field_id)%num_output_fields
4379 out_field = input_fields(diag_field_id)%output_fields(j)
4386 DO i=1, output_fields(out_field)%num_attributes
4387 IF ( trim(output_fields(out_field)%attributes(i)%name) .EQ. trim(name) )
THEN
4393 IF ( this_attribute.NE.0 .AND. (type.EQ.nf90_int .OR. type.EQ.nf90_float) )
THEN
4398 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',&
4399 &
'Attribute "'//trim(name)//
'" already defined for module/input_field "'&
4400 &//trim(input_fields(diag_field_id)%module_name)//
'/'&
4401 &//trim(input_fields(diag_field_id)%field_name)//
'". Contact the developers.', fatal)
4402 ELSE IF ( this_attribute.NE.0 .AND. type.EQ.nf90_char .AND. debug_diag_manager )
THEN
4407 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',&
4408 &
'Attribute "'//trim(name)//
'" already defined for module/input_field "'&
4409 &//trim(input_fields(diag_field_id)%module_name)//
'/'&
4410 &//trim(input_fields(diag_field_id)%field_name)//
'". Prepending.', note)
4411 ELSE IF ( this_attribute.EQ.0 )
THEN
4414 this_attribute = output_fields(out_field)%num_attributes + 1
4416 IF ( this_attribute .GT. max_field_attributes )
THEN
4422 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',&
4423 &
'Number of attributes exceeds max_field_attributes for attribute "'&
4424 &//trim(name)//
'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//
'/'&
4425 &//trim(input_fields(diag_field_id)%field_name)&
4426 &//
'". Increase diag_manager_nml:max_field_attributes.', fatal)
4428 output_fields(out_field)%num_attributes = this_attribute
4430 output_fields(out_field)%attributes(this_attribute)%name = name
4431 output_fields(out_field)%attributes(this_attribute)%type =
type
4433 output_fields(out_field)%attributes(this_attribute)%catt =
''
4439 IF ( .NOT.
PRESENT(ival) )
THEN
4445 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',&
4446 &
'Attribute type claims INTEGER, but ival not present for attribute "'&
4447 &//trim(name)//
'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//
'/'&
4448 &//trim(input_fields(diag_field_id)%field_name)//
'". Contact then developers.', fatal)
4452 ALLOCATE(output_fields(out_field)%attributes(this_attribute)%iatt(length), stat=istat)
4453 IF ( istat.NE.0 )
THEN
4457 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',
'Unable to allocate iatt for attribute "'&
4458 &//trim(name)//
'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//
'/'&
4459 &//trim(input_fields(diag_field_id)%field_name)//
'"', fatal)
4462 output_fields(out_field)%attributes(this_attribute)%len = length
4463 output_fields(out_field)%attributes(this_attribute)%iatt = ival
4465 IF ( .NOT.
PRESENT(rval) )
THEN
4471 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',&
4472 &
'Attribute type claims REAL, but rval not present for attribute "'&
4473 &//trim(name)//
'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//
'/'&
4474 &//trim(input_fields(diag_field_id)%field_name)//
'". Contact the developers.', fatal)
4478 ALLOCATE(output_fields(out_field)%attributes(this_attribute)%fatt(length), stat=istat)
4479 IF ( istat.NE.0 )
THEN
4483 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',
'Unable to allocate fatt for attribute "'&
4484 &//trim(name)//
'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//
'/'&
4485 &//trim(input_fields(diag_field_id)%field_name)//
'"', fatal)
4488 output_fields(out_field)%attributes(this_attribute)%len = length
4489 output_fields(out_field)%attributes(this_attribute)%fatt = rval
4491 IF ( .NOT.
PRESENT(cval) )
THEN
4497 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',&
4498 &
'Attribute type claims CHARACTER, but cval not present for attribute "'&
4499 &//trim(name)//
'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//
'/'&
4500 &//trim(input_fields(diag_field_id)%field_name)//
'". Contact the developers.', fatal)
4508 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',
'Unknown attribute type for attribute "'&
4509 &//trim(name)//
'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//
'/'&
4510 &//trim(input_fields(diag_field_id)%field_name)//
'". Contact the developers.', fatal)
4518 INTEGER,
INTENT(in) :: diag_field_id
4519 CHARACTER(len=*),
INTENT(in) :: att_name
4520 class(*),
INTENT(in) :: att_value
4522 if (use_modern_diag)
then
4523 select type(att_value)
4524 type is (real(kind=r4_kind))
4525 call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, (/att_value /))
4526 type is (real(kind=r8_kind))
4527 call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, (/att_value /))
4528 type is (
integer(kind=i4_kind))
4529 call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, (/att_value /))
4530 type is (
character(len=*))
4531 call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, (/att_value /))
4533 call mpp_error(fatal,
"Diag_field_add_attribute 0d:: unsupported type. The acceptable types "//&
4534 "are float, double, integer, and string")
4537 select type(att_value)
4538 type is (real(kind=r4_kind))
4540 type is (real(kind=r8_kind))
4542 type is (
integer(kind=i4_kind))
4544 type is (
character(len=*))
4547 call mpp_error(fatal,
"Diag_field_add_attribute 0d:: unsupported type. The acceptable types "//&
4548 "are float, double, integer, and string")
4556 INTEGER,
INTENT(in) :: diag_field_id
4557 CHARACTER(len=*),
INTENT(in) :: att_name
4558 class(*),
INTENT(in) :: att_value(:)
4560 if (use_modern_diag)
then
4561 call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, att_value)
4563 select type(att_value)
4564 type is (real(kind=r4_kind))
4566 type is (real(kind=r8_kind))
4568 type is (
integer(kind=i4_kind))
4571 call mpp_error(fatal,
"Diag_field_add_attribute 1d:: unsupported type. The acceptable types "//&
4572 "are float, double, and integer")
4583 INTEGER,
INTENT(in) :: diag_field_id
4584 INTEGER,
INTENT(in),
OPTIONAL :: area
4585 INTEGER,
INTENT(in),
OPTIONAL :: volume
4589 IF ( diag_field_id.GT.0 )
THEN
4590 IF ( .NOT.
PRESENT(area) .AND. .NOT.
present(volume) )
THEN
4591 CALL error_mesg(
'diag_manager_mod::diag_field_add_cell_measures', &
4592 &
'either area or volume arguments must be present', fatal )
4595 if (use_modern_diag)
then
4596 call fms_diag_object%fms_diag_field_add_cell_measures(diag_field_id, area, volume)
4600 DO j=1, input_fields(diag_field_id)%num_output_fields
4601 ind = input_fields(diag_field_id)%output_fields(j)
4609 class(*),
intent(in) :: data_in(:,:,:)
4610 character(len=*),
intent(in) :: field_name
4611 class(*),
allocatable,
intent(out) :: data_out(:,:,:,:)
4614 select type(data_in)
4615 type is (real(kind=r8_kind))
4616 allocate(real(kind=r8_kind) :: data_out(1:
size(data_in,1), 1:
size(data_in,2), 1:
size(data_in,3), 1))
4617 select type (data_out)
4618 type is (real(kind=r8_kind))
4619 data_out(:,:,:,1) = data_in
4621 call mpp_error(fatal,
"The copy of "//trim(field_name)//&
4622 " was not allocated to the correct type (r8_kind). This shouldn't have happened")
4624 type is (real(kind=r4_kind))
4625 allocate(real(kind=r4_kind) :: data_out(1:
size(data_in,1), 1:
size(data_in,2), 1:
size(data_in,3), 1))
4626 select type (data_out)
4627 type is (real(kind=r4_kind))
4628 data_out(:,:,:,1) = data_in
4630 call mpp_error(fatal,
"The copy of "//trim(field_name)//&
4631 " was not allocated to the correct type (r4_kind). This shouldn't have happened")
4634 call mpp_error(fatal,
"The data for "//trim(field_name)//&
4635 &
" is not a valid type. Currently only r4 and r8 are supported")
4639 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.
logical use_mpp_io
false is fms2_io (default); true is mpp_io
integer, parameter diag_field_not_found
Return value for a diag_field that isn't found in the diag_table.
integer max_out_per_in_field
Maximum number of output_fields per input_field. Increase via diag_manager_nml.
integer max_input_fields
Maximum number of input fields. Increase via diag_manager_nml.
logical use_clock_average
.TRUE. if the averaging of variable is done based on the clock For example, if doing daily averages a...
logical issue_oor_warnings
Issue warnings if the output field has values outside the given range for a variable.
logical region_out_use_alt_value
Will determine which value to use when checking a regional output if the region is the full axis or a...
integer num_output_fields
Number of output fields in use.
integer function get_base_day()
gets the module variable base_day
type(time_type) diag_init_time
Time diag_manager_init called. If init_time not included in diag_manager_init call,...
integer max_files
Maximum number of output files allowed. Increase via diag_manager_nml.
integer num_files
Number of output files currenly in use by the diag_manager.
integer max_file_attributes
Maximum number of user definable global attributes per file.
real(r8_kind), parameter cmor_missing_value
CMOR standard missing value.
logical prepend_date
Should the history file have the start date prepended to the file name. .TRUE. is only supported if t...
character(len=2), dimension(:), allocatable fnum_for_domain
If this file number in the array is for the "unstructured" or "2d" domain.
subroutine diag_data_init()
Initialize and write the version number of this file to the log file.
integer function get_base_month()
gets the module variable base_month
logical module_is_initialized
Indicate if diag_manager has been initialized.
logical oor_warnings_fatal
Cause a fatal error if the output field has a value outside the given range for a variable.
integer function get_base_second()
gets the module variable base_second
logical use_refactored_send
Namelist flag to use refactored send_data math funcitons.
integer max_field_attributes
Maximum number of user definable attributes per field. Liptak: Changed from 2 to 4 20170718.
Define the region for field output.
Type to hold the output field description.
subroutine, public diag_grid_init(domain, glo_lat, glo_lon, aglo_lat, aglo_lon)
Send the global grid to the diag_manager_mod for regional output.
subroutine, public diag_grid_end()
Unallocate the diag_global_grid variable.
logical function, public need_data(diag_field_id, next_model_time)
Determine whether data is needed for the current model time step.
logical function get_related_field(field, rel_field, out_field_id, out_file_id)
Finds the corresponding related output field and file for a given input field.
logical function send_data_2d(diag_field_id, field, time, is_in, js_in, mask, rmask, ie_in, je_in, weight, err_msg)
integer function register_diag_field_scalar(module_name, field_name, init_time, long_name, units, missing_value, range, standard_name, do_not_log, err_msg, area, volume, realm, multiple_send_data)
Registers a scalar field.
integer function, public register_static_field(module_name, field_name, axes, long_name, units, missing_value, range, mask_variant, standard_name, DYNAMIC, do_not_log, interp_method, tile_count, area, volume, realm)
Return field index for subsequent call to send_data.
subroutine copy_3d_to_4d(data_in, data_out, field_name)
Copies a 3d buffer to a 4d buffer.
logical function send_data_4d(diag_field_id, field, time, is_in, js_in, ks_in, mask, rmask, ie_in, je_in, ke_in, weight, err_msg)
Updates the output buffer for a field based on the data for current time step.
subroutine diag_field_attribute_init(diag_field_id, name, type, cval, ival, rval)
logical function send_tile_averaged_data3d(id, field, area, time, mask)
integer function register_diag_field_array(module_name, field_name, axes, init_time, long_name, units, missing_value, range, mask_variant, standard_name, verbose, do_not_log, err_msg, interp_method, tile_count, area, volume, realm, multiple_send_data)
Registers an array field.
integer function register_diag_field_scalar_old(module_name, field_name, init_time, long_name, units, missing_value, range, standard_name, do_not_log, err_msg, area, volume, realm)
Registers a scalar field.
integer function register_static_field_old(module_name, field_name, axes, long_name, units, missing_value, range, mask_variant, standard_name, DYNAMIC, do_not_log, interp_method, tile_count, area, volume, realm)
Return field index for subsequent call to send_data.
subroutine closing_file(file, time)
Replaces diag_manager_end; close just one file: files(file)
subroutine, public diag_field_add_cell_measures(diag_field_id, area, volume)
Add the cell_measures attribute to a diag out field.
subroutine init_field_cell_measures(output_field, area, volume, err_msg)
If needed, add cell_measures and associated_file attribute to out field/file.
integer function register_diag_field_array_old(module_name, field_name, axes, init_time, long_name, units, missing_value, range, mask_variant, standard_name, verbose, do_not_log, err_msg, interp_method, tile_count, area, volume, realm)
Registers an array field.
subroutine, public diag_send_complete_instant(time)
The subroutine 'diag_send_complete_instant' allows the user to save diagnostic data on variable inter...
subroutine average_tiles(diag_field_id, x, area, mask, out)
Calculates tile average of a field.
logical function send_data_0d(diag_field_id, field, time, err_msg)
subroutine add_associated_files(file_num, cm_file_num, cm_ind)
Add to the associated files attribute.
integer function writing_field(out_num, at_diag_end, error_string, time)
subroutine, public diag_manager_init(diag_model_subset, time_init, err_msg)
Initialize Diagnostics Manager.
integer function, public get_diag_field_id(module_name, field_name)
Return the diagnostic field ID of a given variable.
subroutine, public get_base_date(year, month, day, hour, minute, second)
Return base date for diagnostics.
logical function send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, mask, rmask, ie_in, je_in, ke_in, weight, err_msg)
subroutine average_tiles1d(diag_field_id, x, area, mask, out)
Calculates average for a field with the given area and land mask.
logical function diag_send_data(diag_field_id, field, time, is_in, js_in, ks_in, mask, rmask, ie_in, je_in, ke_in, weight, err_msg)
subroutine diag_field_add_attribute_0d(diag_field_id, att_name, att_value)
Add a scalr attribute to the diag field corresponding to a given id.
logical function send_tile_averaged_data1d(id, field, area, time, mask)
logical function send_data_1d(diag_field_id, field, time, is_in, mask, rmask, ie_in, weight, err_msg)
subroutine, public diag_manager_end(time)
Flushes diagnostic buffers where necessary. Close diagnostics files. A warning will be issued here if...
logical function send_tile_averaged_data2d(id, field, area, time, mask)
integer function init_diurnal_axis(n_samples)
Finds or initializes a diurnal time axis and returns its' ID.
subroutine diag_field_add_attribute_1d(diag_field_id, att_name, att_value)
Add an 1D array attribute to the diag field corresponding to a given id.
subroutine, public diag_send_complete(time_step, err_msg)
Saves diagnostic data for the given time value.
Add a attribute to the output field.
Register a diagnostic field for a given module.
Send data over to output fields.
Send tile-averaged data over to output fields.
subroutine, public get_diag_global_att(gAtt)
Return the global attribute type.
subroutine, public set_diag_global_att(component, gridType, tileName)
Set the global attribute type.
subroutine, public parse_diag_table(diag_subset, istat, err_msg)
Parse the diag_table in preparation for diagnostic output.
subroutine, public get_subfield_size(axes, outnum)
Get the size, start, and end indices for output fields.
subroutine, public init_input_field(module_name, field_name, tile_count)
Initialize the input field.
subroutine, public check_bounds_are_exact_static(out_num, diag_field_id, err_msg)
Check if the array indices for output_fields(out_num) are equal to the output_fields(out_num)buffer u...
integer function, public find_input_field(module_name, field_name, tile_count)
Return the field number for the given module name, field name, and tile number.
subroutine, public write_static(file)
Output all static fields in this file.
subroutine, public diag_data_out(file, field, dat, time, final_call_in, static_write_in, filename_time)
Write data out to file, and if necessary flush the buffers.
subroutine, public init_output_field(module_name, field_name, output_name, output_file, time_method, pack, tile_count, local_coord)
Initialize the output field.
type(time_type) function, public get_file_start_time(file_num)
Get the a diag_file's start_time as it is defined in the diag_table.
subroutine, public sync_file_times(file_id, init_time, err_msg)
Synchronize the file's start and close times with the model start and end times.
character(len=1), public field_log_separator
separator used for csv-style log of registered fields set by nml in diag_manager init
subroutine, public check_out_of_bounds(out_num, diag_field_id, err_msg)
Checks if the array indices for output_fields(out_num) are outside the output_fields(out_num)buffer u...
subroutine, public get_subfield_vert_size(axes, outnum)
Get size, start and end indices for output fields.
subroutine, public log_diag_field_info(module_name, field_name, axes, long_name, units, missing_value, range, dynamic)
Writes brief diagnostic field info to the log file.
subroutine, public update_bounds(out_num, lower_i, upper_i, lower_j, upper_j, lower_k, upper_k)
Update the output_fields x, y, and z min and max boundaries (array indices) with the six specified bo...
subroutine, public diag_util_init()
Write the version number of this file to the log file.
subroutine, public check_bounds_are_exact_dynamic(out_num, diag_field_id, Time, err_msg)
This is an adaptor to the check_bounds_are_exact_dynamic_modern function to maintain an interface ser...
Allocates the atttype in out_file.
Prepend a value to a string attribute in the output field or output file.
Interface fieldbuff_copy_fieldvals updates elements of the field output buffer with copies of corresp...
Interface fieldbuff_copy_missvals updates elements of the field output buffer with the missvalue inpu...
Interface fieldbuff_update updates elements of field output buffer based on input field data and math...
Class fmsDiagOutfield_type (along with class ms_diag_outfield_index_type ) contain information used i...
Class fms_diag_outfield_index_type which (along with class fmsDiagOutfield_type) encapsulate related ...
integer function, public check_nml_error(IOSTAT, NML_NAME)
Checks the iostat argument that is returned after reading a namelist and determines if the error code...
subroutine, public write_version_number(version, tag, unit)
Prints to the log file (or a specified unit) the version id string and tag name.
logical function, public fms_error_handler(routine, message, err_msg)
Facilitates the control of fatal error conditions.
subroutine, public error_mesg(routine, message, level)
Print notes, warnings and error messages; terminates program for warning and error messages....
character(:) function, allocatable, public string(v, fmt)
Converts a number or a Boolean value to a string.
integer function stdout()
This function returns the current standard fortran unit numbers for output.
integer function stdlog()
This function returns the current standard fortran unit numbers for log messages. Log messages,...
integer function mpp_npes()
Returns processor count for current pelist.
integer function mpp_pe()
Returns processor ID.
integer function, public get_ticks_per_second()
Returns the number of ticks per second.
subroutine, public get_time(Time, seconds, days, ticks, err_msg)
Returns days and seconds ( < 86400 ) corresponding to a time. err_msg should be checked for any error...
subroutine, public get_date(time, year, month, day, hour, minute, second, tick, err_msg)
Gets the date for different calendar types. Given a time_interval, returns the corresponding date und...
Given an input date in year, month, days, etc., creates a time_type that represents this time interva...
Given some number of seconds and days, returns the corresponding time_type.
Type to represent amounts of time. Implemented as seconds and days to allow for larger intervals.