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 (output_fields(out_num)%next_output == output_fields(out_num)%last_output)
THEN
2076 IF(
PRESENT(time))
THEN
2077 output_fields(out_num)%next_output = time
2079 WRITE (error_string,
'(a,"/",a)')&
2080 & trim(input_fields(diag_field_id)%module_name),&
2081 & trim(output_fields(out_num)%output_name)
2082 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d',
'module/output_field '//trim(error_string)//&
2083 &
', time must be present when output frequency = EVERY_TIME', err_msg))
THEN
2084 DEALLOCATE(field_out)
2085 DEALLOCATE(oor_mask)
2091 IF ( .NOT.output_fields(out_num)%static .AND. .NOT.
PRESENT(time) )
THEN
2092 WRITE (error_string,
'(a,"/",a)')&
2093 & trim(input_fields(diag_field_id)%module_name), &
2094 & trim(output_fields(out_num)%output_name)
2095 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d',
'module/output_field '//trim(error_string)//&
2096 &
', time must be present for nonstatic field', err_msg))
THEN
2097 DEALLOCATE(field_out)
2098 DEALLOCATE(oor_mask)
2106 IF ( (numthreads == 1) .AND. (active_omp_level.LE.1) )
then
2107 IF ( .NOT.output_fields(out_num)%static .AND. freq /= end_of_run )
THEN
2108 IF ( time > output_fields(out_num)%next_output )
THEN
2110 IF ( time > output_fields(out_num)%next_next_output .AND. freq > 0 )
THEN
2111 IF (
mpp_pe() .EQ. mpp_root_pe() )
THEN
2112 WRITE (error_string,
'(a,"/",a)')&
2113 & trim(input_fields(diag_field_id)%module_name), &
2114 & trim(output_fields(out_num)%output_name)
2115 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d',
'module/output_field '//&
2116 & trim(error_string)//
' is skipped one time level in output data', err_msg))
THEN
2117 DEALLOCATE(field_out)
2118 DEALLOCATE(oor_mask)
2124 status =
writing_field(out_num, .false., error_string, time)
2125 IF(status == -1)
THEN
2126 IF (
mpp_pe() .EQ. mpp_root_pe() )
THEN
2127 IF(
fms_error_handler(
'diag_manager_mod::send_data_3d',
'module/output_field '//trim(error_string)&
2128 & //
', write EMPTY buffer', err_msg))
THEN
2129 DEALLOCATE(field_out)
2130 DEALLOCATE(oor_mask)
2140 if (
present(time))
then
2142 if (output_fields(out_num)%last_output > time) cycle
2145 IF ( .NOT.output_fields(out_num)%static .AND. .NOT.need_compute .AND. debug_diag_manager )
THEN
2147 IF ( err_msg_local /=
'' )
THEN
2148 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
2149 DEALLOCATE(field_out)
2150 DEALLOCATE(oor_mask)
2156 IF (use_refactored_send)
THEN
2157 ALLOCATE( ofield_index_cfg )
2158 CALL ofield_index_cfg%initialize( is, js, ks, ie, je, ke, &
2159 & hi, hj, f1, f2, f3, f4)
2161 ALLOCATE( ofield_cfg )
2162 CALL ofield_cfg%initialize( input_fields(diag_field_id), output_fields(out_num),
PRESENT(mask), freq)
2166 mf_result =
fieldbuff_update(ofield_cfg, ofield_index_cfg, field_out, sample, &
2167 & output_fields(out_num)%buffer, output_fields(out_num)%counter ,output_fields(out_num)%buff_bounds,&
2168 & output_fields(out_num)%count_0d(sample), output_fields(out_num)%num_elements(sample), &
2169 & mask, weight1 ,missvalue, &
2170 & input_fields(diag_field_id)%numthreads, input_fields(diag_field_id)%active_omp_level,&
2171 & input_fields(diag_field_id)%issued_mask_ignore_warning, &
2172 & l_start, l_end, err_msg, err_msg_local )
2173 IF (mf_result .eqv. .false.)
THEN
2174 DEALLOCATE(ofield_index_cfg)
2175 DEALLOCATE(ofield_cfg)
2176 DEALLOCATE(field_out)
2177 DEALLOCATE(oor_mask)
2182 & output_fields(out_num)%buffer, output_fields(out_num)%buff_bounds , &
2183 & output_fields(out_num)%count_0d(sample), &
2184 & mask, missvalue, l_start, l_end, err_msg, err_msg_local)
2185 IF (mf_result .eqv. .false.)
THEN
2186 DEALLOCATE(ofield_index_cfg)
2187 DEALLOCATE(ofield_cfg)
2188 DEALLOCATE(field_out)
2189 DEALLOCATE(oor_mask)
2194 IF ( output_fields(out_num)%static .AND. .NOT.need_compute .AND. debug_diag_manager )
THEN
2196 IF ( err_msg_local /=
'' )
THEN
2197 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg))
THEN
2198 DEALLOCATE(field_out)
2199 DEALLOCATE(oor_mask)
2226 IF(
ALLOCATED(ofield_index_cfg))
THEN
2227 DEALLOCATE(ofield_index_cfg)
2229 IF(
ALLOCATED(ofield_cfg))
THEN
2230 DEALLOCATE(ofield_cfg)
2237 IF ( input_fields(diag_field_id)%mask_variant )
THEN
2238 IF ( need_compute )
THEN
2239 WRITE (error_string,
'(a,"/",a)') &
2240 & trim(input_fields(diag_field_id)%module_name), &
2241 & trim(output_fields(out_num)%output_name)
2242 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d',
'module/output_field '//trim(error_string)//&
2243 &
', regional output NOT supported with mask_variant', err_msg))
THEN
2244 DEALLOCATE(field_out)
2245 DEALLOCATE(oor_mask)
2252 IF (
PRESENT(mask) )
THEN
2253 IF ( missvalue_present )
THEN
2254 IF ( debug_diag_manager )
THEN
2255 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
2257 IF ( err_msg_local /=
'' )
THEN
2258 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
2259 DEALLOCATE(field_out)
2260 DEALLOCATE(oor_mask)
2265 IF( numthreads>1 .AND. phys_window )
then
2266 IF ( reduced_k_range )
THEN
2271 IF ( mask(i-is+1+hi, j-js+1+hj, k) )
THEN
2272 IF ( pow_value /= 1 )
THEN
2273 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2274 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2275 & (field_out(i-is+1+hi, j-js+1+hj, k) * weight1)**(pow_value)
2277 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2278 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2279 & field_out(i-is+1+hi, j-js+1+hj, k) * weight1
2281 output_fields(out_num)%counter(i-hi,j-hj,k1,sample) =&
2282 & output_fields(out_num)%counter(i-hi,j-hj,k1,sample) + weight1
2291 IF ( mask(i-is+1+hi, j-js+1+hj, k) )
THEN
2292 IF ( pow_value /= 1 )
THEN
2293 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2294 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2295 & (field_out(i-is+1+hi,j-js+1+hj,k)*weight1)**(pow_value)
2297 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2298 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2299 & field_out(i-is+1+hi,j-js+1+hj,k)*weight1
2301 output_fields(out_num)%counter(i-hi,j-hj,k,sample) =&
2302 &output_fields(out_num)%counter(i-hi,j-hj,k,sample) + weight1
2310 IF ( reduced_k_range )
THEN
2315 IF ( mask(i-is+1+hi, j-js+1+hj, k) )
THEN
2316 IF ( pow_value /= 1 )
THEN
2317 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2318 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2319 & (field_out(i-is+1+hi, j-js+1+hj, k) * weight1)**(pow_value)
2321 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2322 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2323 & field_out(i-is+1+hi, j-js+1+hj, k) * weight1
2325 output_fields(out_num)%counter(i-hi,j-hj,k1,sample) =&
2326 & output_fields(out_num)%counter(i-hi,j-hj,k1,sample) + weight1
2335 IF ( mask(i-is+1+hi, j-js+1+hj, k) )
THEN
2336 IF ( pow_value /= 1 )
THEN
2337 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2338 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2339 & (field_out(i-is+1+hi,j-js+1+hj,k)*weight1)**(pow_value)
2341 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2342 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2343 & field_out(i-is+1+hi,j-js+1+hj,k)*weight1
2345 output_fields(out_num)%counter(i-hi,j-hj,k,sample) =&
2346 &output_fields(out_num)%counter(i-hi,j-hj,k,sample) + weight1
2355 WRITE (error_string,
'(a,"/",a)')&
2356 & trim(input_fields(diag_field_id)%module_name), &
2357 & trim(output_fields(out_num)%output_name)
2358 IF(
fms_error_handler(
'diag_manager_mod::send_data_3d',
'module/output_field '//trim(error_string)//&
2359 &
', variable mask but no missing value defined', err_msg))
THEN
2360 DEALLOCATE(field_out)
2361 DEALLOCATE(oor_mask)
2366 WRITE (error_string,
'(a,"/",a)')&
2367 & trim(input_fields(diag_field_id)%module_name), &
2368 & trim(output_fields(out_num)%output_name)
2369 IF(
fms_error_handler(
'diag_manager_mod::send_data_3d',
'module/output_field '//trim(error_string)//&
2370 &
', variable mask but no mask given', err_msg))
THEN
2371 DEALLOCATE(field_out)
2372 DEALLOCATE(oor_mask)
2377 IF (
PRESENT(mask) )
THEN
2378 IF ( missvalue_present )
THEN
2379 IF ( need_compute )
THEN
2380 IF (numthreads>1 .AND. phys_window)
then
2381 DO k = l_start(3), l_end(3)
2385 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2386 & j <= l_end(2)+hj )
THEN
2387 i1 = i-l_start(1)-hi+1
2388 j1= j-l_start(2)-hj+1
2389 IF ( mask(i-is+1+hi, j-js+1+hj, k) )
THEN
2390 IF ( pow_value /= 1 )
THEN
2391 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2392 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2393 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2395 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2396 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2397 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2400 output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
2408 DO k = l_start(3), l_end(3)
2412 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2413 & j <= l_end(2)+hj )
THEN
2414 i1 = i-l_start(1)-hi+1
2415 j1= j-l_start(2)-hj+1
2416 IF ( mask(i-is+1+hi, j-js+1+hj, k) )
THEN
2417 IF ( pow_value /= 1 )
THEN
2418 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2419 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2420 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2422 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2423 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2424 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2427 output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
2438 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2439 & j <= l_end(2)+hj )
THEN
2440 output_fields(out_num)%num_elements(sample) = &
2441 output_fields(out_num)%num_elements(sample) + l_end(3) - l_start(3) + 1
2446 ELSE IF ( reduced_k_range )
THEN
2447 IF (numthreads>1 .AND. phys_window)
then
2452 IF ( mask(i-is+1+hi,j-js+1+hj,k) )
THEN
2453 IF ( pow_value /= 1 )
THEN
2454 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2455 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2456 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2458 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2459 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2460 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2463 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue
2474 IF ( mask(i-is+1+hi,j-js+1+hj,k) )
THEN
2475 IF ( pow_value /= 1 )
THEN
2476 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2477 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2478 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2480 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2481 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2482 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2485 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue
2493 IF ( debug_diag_manager )
THEN
2494 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
2496 IF ( err_msg_local /=
'' )
THEN
2497 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
2498 DEALLOCATE(field_out)
2499 DEALLOCATE(oor_mask)
2504 IF (numthreads>1 .AND. phys_window)
then
2508 IF ( mask(i-is+1+hi,j-js+1+hj,k) )
THEN
2509 IF ( pow_value /= 1 )
THEN
2510 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2511 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2512 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2514 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2515 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2516 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2519 output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue
2529 IF ( mask(i-is+1+hi,j-js+1+hj,k) )
THEN
2530 IF ( pow_value /= 1 )
THEN
2531 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2532 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2533 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2535 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2536 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2537 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2540 output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue
2549 IF ( need_compute .AND. .NOT.phys_window )
THEN
2550 IF ( any(mask(l_start(1)+hi:l_end(1)+hi,l_start(2)+hj:l_end(2)+hj,l_start(3):l_end(3))) ) &
2551 & output_fields(out_num)%count_0d(sample) =&
2552 & output_fields(out_num)%count_0d(sample) + weight1
2554 IF ( any(mask(f1:f2,f3:f4,ks:ke)) ) output_fields(out_num)%count_0d(sample) =&
2555 & output_fields(out_num)%count_0d(sample)+weight1
2560 IF ( (.NOT.all(mask(f1:f2,f3:f4,ks:ke)) .AND.
mpp_pe() .EQ. mpp_root_pe()).AND.&
2561 & .NOT.input_fields(diag_field_id)%issued_mask_ignore_warning )
THEN
2566 CALL error_mesg(
'diag_manager_mod::send_data_3d',&
2567 &
'Mask will be ignored since missing values were not specified for field '//&
2568 & trim(input_fields(diag_field_id)%field_name)//
' in module '//&
2569 & trim(input_fields(diag_field_id)%module_name), warning)
2570 input_fields(diag_field_id)%issued_mask_ignore_warning = .true.
2572 IF ( need_compute )
THEN
2573 IF (numthreads>1 .AND. phys_window)
then
2576 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2577 & j <= l_end(2)+hj )
THEN
2578 i1 = i-l_start(1)-hi+1
2579 j1 = j-l_start(2)-hj+1
2580 IF ( pow_value /= 1 )
THEN
2581 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2582 & output_fields(out_num)%buffer(i1,j1,:,sample)+ &
2583 & (field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value)
2585 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2586 & output_fields(out_num)%buffer(i1,j1,:,sample)+ &
2587 & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
2596 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2597 & j <= l_end(2)+hj )
THEN
2598 i1 = i-l_start(1)-hi+1
2599 j1 = j-l_start(2)-hj+1
2600 IF ( pow_value /= 1 )
THEN
2601 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2602 & output_fields(out_num)%buffer(i1,j1,:,sample)+ &
2603 & (field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value)
2605 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2606 & output_fields(out_num)%buffer(i1,j1,:,sample)+ &
2607 & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
2617 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2618 & j <= l_end(2)+hj )
THEN
2619 output_fields(out_num)%num_elements(sample)=&
2620 & output_fields(out_num)%num_elements(sample)+l_end(3)-l_start(3)+1
2626 ELSE IF ( reduced_k_range )
THEN
2627 IF (numthreads>1 .AND. phys_window)
then
2630 IF ( pow_value /= 1 )
THEN
2631 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2632 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) +&
2633 & (field_out(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value)
2635 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2636 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) +&
2637 & field_out(f1:f2,f3:f4,ksr:ker)*weight1
2643 IF ( pow_value /= 1 )
THEN
2644 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2645 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) +&
2646 & (field_out(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value)
2648 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2649 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) +&
2650 & field_out(f1:f2,f3:f4,ksr:ker)*weight1
2655 IF ( debug_diag_manager )
THEN
2656 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
2658 IF ( err_msg_local /=
'')
THEN
2659 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
2660 DEALLOCATE(field_out)
2661 DEALLOCATE(oor_mask)
2666 IF (numthreads>1 .AND. phys_window)
then
2667 IF ( pow_value /= 1 )
THEN
2668 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
2669 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
2670 & (field_out(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value)
2672 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
2673 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
2674 & field_out(f1:f2,f3:f4,ks:ke)*weight1
2678 IF ( pow_value /= 1 )
THEN
2679 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
2680 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
2681 & (field_out(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value)
2683 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
2684 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
2685 & field_out(f1:f2,f3:f4,ks:ke)*weight1
2691 IF ( .NOT.phys_window ) output_fields(out_num)%count_0d(sample) =&
2692 & output_fields(out_num)%count_0d(sample) + weight1
2696 IF ( missvalue_present )
THEN
2697 IF ( need_compute )
THEN
2698 if( numthreads>1 .AND. phys_window )
then
2699 DO k = l_start(3), l_end(3)
2700 k1 = k - l_start(3) + 1
2703 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2704 & j <= l_end(2)+hj)
THEN
2705 i1 = i-l_start(1)-hi+1
2706 j1= j-l_start(2)-hj+1
2707 IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue )
THEN
2708 IF ( pow_value /= 1 )
THEN
2709 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2710 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2711 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2713 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2714 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2715 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2718 output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
2726 DO k = l_start(3), l_end(3)
2727 k1 = k - l_start(3) + 1
2730 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2731 & j <= l_end(2)+hj)
THEN
2732 i1 = i-l_start(1)-hi+1
2733 j1= j-l_start(2)-hj+1
2734 IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue )
THEN
2735 IF ( pow_value /= 1 )
THEN
2736 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2737 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2738 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2740 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2741 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2742 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2745 output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
2756 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2757 & j <= l_end(2)+hj)
THEN
2758 output_fields(out_num)%num_elements(sample) =&
2759 & output_fields(out_num)%num_elements(sample) + l_end(3) - l_start(3) + 1
2763 IF ( .NOT.phys_window )
THEN
2764 outer0:
DO k = l_start(3), l_end(3)
2765 DO j=l_start(2)+hj, l_end(2)+hj
2766 DO i=l_start(1)+hi, l_end(1)+hi
2767 IF ( field_out(i,j,k) /= missvalue )
THEN
2768 output_fields(out_num)%count_0d(sample) = output_fields(out_num)%count_0d(sample)&
2777 ELSE IF ( reduced_k_range )
THEN
2778 if( numthreads>1 .AND. phys_window )
then
2785 IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue )
THEN
2786 IF ( pow_value /= 1 )
THEN
2787 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2788 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2789 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2791 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2792 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2793 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2796 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) = missvalue
2809 IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue )
THEN
2810 IF ( pow_value /= 1 )
THEN
2811 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2812 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2813 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2815 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2816 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2817 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2820 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) = missvalue
2828 outer3:
DO k = ksr, ker
2832 IF ( field_out(i,j,k) /= missvalue )
THEN
2833 output_fields(out_num)%count_0d(sample) = output_fields(out_num)%count_0d(sample) &
2842 IF ( debug_diag_manager )
THEN
2843 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
2845 IF ( err_msg_local /=
'' )
THEN
2846 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
2847 DEALLOCATE(field_out)
2848 DEALLOCATE(oor_mask)
2853 IF( numthreads > 1 .AND. phys_window )
then
2857 IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue )
THEN
2858 IF ( pow_value /= 1 )
THEN
2859 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2860 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2861 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2863 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2864 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2865 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2868 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) = missvalue
2878 IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue )
THEN
2879 IF ( pow_value /= 1 )
THEN
2880 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2881 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2882 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2884 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2885 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2886 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2889 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) = missvalue
2900 IF ( field_out(i,j,k) /= missvalue )
THEN
2901 output_fields(out_num)%count_0d(sample) = output_fields(out_num)%count_0d(sample) &
2911 IF ( need_compute )
THEN
2912 IF( numthreads > 1 .AND. phys_window )
then
2915 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2916 & j <= l_end(2)+hj )
THEN
2917 i1 = i-l_start(1)-hi+1
2918 j1= j-l_start(2)-hj+1
2919 IF ( pow_value /= 1 )
THEN
2920 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2921 & output_fields(out_num)%buffer(i1,j1,:,sample) +&
2922 & (field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value)
2924 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2925 & output_fields(out_num)%buffer(i1,j1,:,sample) +&
2926 & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
2935 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2936 & j <= l_end(2)+hj )
THEN
2937 i1 = i-l_start(1)-hi+1
2938 j1= j-l_start(2)-hj+1
2939 IF ( pow_value /= 1 )
THEN
2940 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2941 & output_fields(out_num)%buffer(i1,j1,:,sample) +&
2942 & (field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value)
2944 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2945 & output_fields(out_num)%buffer(i1,j1,:,sample) +&
2946 & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
2957 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2958 & j <= l_end(2)+hj )
THEN
2959 output_fields(out_num)%num_elements(sample) =&
2960 & output_fields(out_num)%num_elements(sample)+l_end(3)-l_start(3)+1
2966 ELSE IF ( reduced_k_range )
THEN
2969 IF( numthreads > 1 .AND. phys_window )
then
2970 IF ( pow_value /= 1 )
THEN
2971 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2972 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
2973 & (field_out(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value)
2975 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2976 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
2977 & field_out(f1:f2,f3:f4,ksr:ker)*weight1
2981 IF ( pow_value /= 1 )
THEN
2982 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2983 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
2984 & (field_out(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value)
2986 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2987 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
2988 & field_out(f1:f2,f3:f4,ksr:ker)*weight1
2993 IF ( debug_diag_manager )
THEN
2994 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
2996 IF ( err_msg_local /=
'' )
THEN
2997 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
2998 DEALLOCATE(field_out)
2999 DEALLOCATE(oor_mask)
3004 IF( numthreads > 1 .AND. phys_window )
then
3005 IF ( pow_value /= 1 )
THEN
3006 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
3007 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
3008 & (field_out(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value)
3010 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
3011 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
3012 & field_out(f1:f2,f3:f4,ks:ke)*weight1
3016 IF ( pow_value /= 1 )
THEN
3017 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
3018 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
3019 & (field_out(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value)
3021 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
3022 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
3023 & field_out(f1:f2,f3:f4,ks:ke)*weight1
3029 IF ( .NOT.phys_window ) output_fields(out_num)%count_0d(sample) =&
3030 & output_fields(out_num)%count_0d(sample) + weight1
3036 IF ( .NOT.need_compute .AND. .NOT.reduced_k_range )&
3037 & output_fields(out_num)%num_elements(sample) =&
3038 & output_fields(out_num)%num_elements(sample) + (ie-is+1)*(je-js+1)*(ke-ks+1)
3039 IF ( reduced_k_range ) &
3040 & output_fields(out_num)%num_elements(sample) = output_fields(out_num)%num_elements(sample) +&
3041 & (ie-is+1)*(je-js+1)*(ker-ksr+1)
3044 ELSE IF ( time_max )
THEN
3045 IF (
PRESENT(mask) )
THEN
3046 IF ( need_compute )
THEN
3047 DO k = l_start(3), l_end(3)
3048 k1 = k - l_start(3) + 1
3051 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
3052 & j <= l_end(2)+hj )
THEN
3053 i1 = i-l_start(1)-hi+1
3054 j1= j-l_start(2)-hj+1
3055 IF ( mask(i-is+1+hi,j-js+1+hj,k) .AND. field_out(i-is+1+hi,j-js+1+hj,k)>&
3056 & output_fields(out_num)%buffer(i1,j1,k1,sample) )
THEN
3057 output_fields(out_num)%buffer(i1,j1,k1,sample) = field_out(i-is+1+hi,j-js+1+hj,k)
3064 ELSE IF ( reduced_k_range )
THEN
3067 WHERE ( mask(f1:f2,f3:f4,ksr:ker) .AND. field_out(f1:f2,f3:f4,ksr:ker) >&
3068 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) )&
3069 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker)
3071 IF ( debug_diag_manager )
THEN
3072 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3074 IF ( err_msg_local /=
'' )
THEN
3075 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3076 DEALLOCATE(field_out)
3077 DEALLOCATE(oor_mask)
3082 WHERE ( mask(f1:f2,f3:f4,ks:ke) .AND. field_out(f1:f2,f3:f4,ks:ke)>&
3083 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) )&
3084 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke)
3087 IF ( need_compute )
THEN
3088 DO k = l_start(3), l_end(3)
3089 k1 = k - l_start(3) + 1
3092 IF(l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
3093 & j <= l_end(2)+hj )
THEN
3094 i1 = i-l_start(1)-hi+1
3095 j1 = j-l_start(2)-hj+1
3096 IF ( field_out(i-is+1+hi,j-js+1+hj,k)>output_fields(out_num)%buffer(i1,j1,k1,sample) )
THEN
3097 output_fields(out_num)%buffer(i1,j1,k1,sample) = field_out(i-is+1+hi,j-js+1+hj,k)
3104 ELSE IF ( reduced_k_range )
THEN
3107 WHERE ( field_out(f1:f2,f3:f4,ksr:ker) >&
3108 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) ) &
3109 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker)
3111 IF ( debug_diag_manager )
THEN
3112 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3114 IF ( err_msg_local /=
'' )
THEN
3115 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3116 DEALLOCATE(field_out)
3117 DEALLOCATE(oor_mask)
3122 WHERE ( field_out(f1:f2,f3:f4,ks:ke) >&
3123 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) ) &
3124 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke)
3127 output_fields(out_num)%count_0d(sample) = 1
3128 ELSE IF ( time_min )
THEN
3129 IF (
PRESENT(mask) )
THEN
3130 IF ( need_compute )
THEN
3131 DO k = l_start(3), l_end(3)
3132 k1 = k - l_start(3) + 1
3135 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
3136 & j <= l_end(2)+hj )
THEN
3137 i1 = i-l_start(1)-hi+1
3138 j1 = j-l_start(2)-hj+1
3139 IF ( mask(i-is+1+hi,j-js+1+hj,k) .AND. field_out(i-is+1+hi,j-js+1+hj,k) <&
3140 & output_fields(out_num)%buffer(i1,j1,k1,sample) )
THEN
3141 output_fields(out_num)%buffer(i1,j1,k1,sample) = field_out(i-is+1+hi,j-js+1+hj,k)
3148 ELSE IF ( reduced_k_range )
THEN
3151 WHERE ( mask(f1:f2,f3:f4,ksr:ker) .AND. field_out(f1:f2,f3:f4,ksr:ker) <&
3152 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) ) &
3153 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker)
3155 IF ( debug_diag_manager )
THEN
3156 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3158 IF ( err_msg_local /=
'' )
THEN
3159 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3160 DEALLOCATE(field_out)
3161 DEALLOCATE(oor_mask)
3166 WHERE ( mask(f1:f2,f3:f4,ks:ke) .AND. field_out(f1:f2,f3:f4,ks:ke) <&
3167 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) ) &
3168 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke)
3171 IF ( need_compute )
THEN
3172 DO k = l_start(3), l_end(3)
3173 k1 = k - l_start(3) + 1
3176 IF ( l_start(1)+hi <=i.AND.i<=l_end(1)+hi.AND.l_start(2)+hj<=j.AND.j<=l_end(2)+hj)
THEN
3177 i1 = i-l_start(1)-hi+1
3178 j1= j-l_start(2)-hj+1
3179 IF ( field_out(i-is+1+hi,j-js+1+hj,k) <&
3180 & output_fields(out_num)%buffer(i1,j1,k1,sample) )
THEN
3181 output_fields(out_num)%buffer(i1,j1,k1,sample) = field_out(i-is+1+hi,j-js+1+hj,k)
3188 ELSE IF ( reduced_k_range )
THEN
3191 WHERE ( field_out(f1:f2,f3:f4,ksr:ker) <&
3192 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) ) &
3193 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker)
3195 IF ( debug_diag_manager )
THEN
3196 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3198 IF ( err_msg_local /=
'' )
THEN
3199 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3200 DEALLOCATE(field_out)
3201 DEALLOCATE(oor_mask)
3206 WHERE ( field_out(f1:f2,f3:f4,ks:ke) <&
3207 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) )&
3208 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke)
3211 output_fields(out_num)%count_0d(sample) = 1
3212 ELSE IF ( time_sum )
THEN
3213 IF (
PRESENT(mask) )
THEN
3214 IF ( need_compute )
THEN
3215 DO k = l_start(3), l_end(3)
3216 k1 = k - l_start(3) + 1
3219 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
3220 & j <= l_end(2)+hj )
THEN
3221 i1 = i-l_start(1)-hi+1
3222 j1 = j-l_start(2)-hj+1
3223 IF ( mask(i-is+1+hi,j-js+1+hj,k) )
THEN
3224 output_fields(out_num)%buffer(i1,j1,k1,sample) = &
3225 output_fields(out_num)%buffer(i1,j1,k1,sample) + &
3226 field_out(i-is+1+hi,j-js+1+hj,k)
3233 ELSE IF ( reduced_k_range )
THEN
3236 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = &
3237 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
3238 & field_out(f1:f2,f3:f4,ksr:ker)
3240 IF ( debug_diag_manager )
THEN
3241 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3243 IF ( err_msg_local /=
'' )
THEN
3244 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3245 DEALLOCATE(field_out)
3246 DEALLOCATE(oor_mask)
3251 WHERE ( mask(f1:f2,f3:f4,ks:ke) ) &
3252 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = &
3253 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) + &
3254 & field_out(f1:f2,f3:f4,ks:ke)
3257 IF ( need_compute )
THEN
3258 DO k = l_start(3), l_end(3)
3259 k1 = k - l_start(3) + 1
3262 IF ( l_start(1)+hi <=i.AND.i<=l_end(1)+hi.AND.l_start(2)+hj<=j.AND.j<=l_end(2)+hj)
THEN
3263 i1 = i-l_start(1)-hi+1
3264 j1= j-l_start(2)-hj+1
3265 output_fields(out_num)%buffer(i1,j1,k1,sample) = &
3266 & output_fields(out_num)%buffer(i1,j1,k1,sample) + &
3267 & field_out(i-is+1+hi,j-js+1+hj,k)
3272 ELSE IF ( reduced_k_range )
THEN
3275 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = &
3276 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
3277 & field_out(f1:f2,f3:f4,ksr:ker)
3279 IF ( debug_diag_manager )
THEN
3280 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3282 IF ( err_msg_local /=
'' )
THEN
3283 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3284 DEALLOCATE(field_out)
3285 DEALLOCATE(oor_mask)
3290 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = &
3291 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) + &
3292 & field_out(f1:f2,f3:f4,ks:ke)
3295 output_fields(out_num)%count_0d(sample) = 1
3297 output_fields(out_num)%count_0d(sample) = 1
3298 IF ( need_compute )
THEN
3301 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. j <= l_end(2)+hj)
THEN
3302 i1 = i-l_start(1)-hi+1
3303 j1 = j-l_start(2)-hj+1
3304 output_fields(out_num)%buffer(i1,j1,:,sample) =&
3305 & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))
3310 ELSE IF ( reduced_k_range )
THEN
3313 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker)
3315 IF ( debug_diag_manager )
THEN
3316 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3318 IF ( err_msg_local /=
'' )
THEN
3319 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3320 DEALLOCATE(field_out)
3321 DEALLOCATE(oor_mask)
3326 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke)
3329 IF (
PRESENT(mask) .AND. missvalue_present )
THEN
3330 IF ( need_compute )
THEN
3331 DO k = l_start(3), l_end(3)
3332 k1 = k - l_start(3) + 1
3335 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
3336 & j <= l_end(2)+hj )
THEN
3337 i1 = i-l_start(1)-hi+1
3338 j1 = j-l_start(2)-hj+1
3339 IF ( .NOT.mask(i-is+1+hi,j-js+1+hj,k) )&
3340 & output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
3345 ELSE IF ( reduced_k_range )
THEN
3352 IF ( .NOT.mask(i-is+1+hi,j-js+1+hj,k) ) &
3353 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue
3361 IF ( .NOT.mask(i-is+1+hi,j-js+1+hj,k) )&
3362 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue
3370 IF ( output_fields(out_num)%static .AND. .NOT.need_compute .AND. debug_diag_manager )
THEN
3372 IF ( err_msg_local /=
'' )
THEN
3373 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg))
THEN
3374 DEALLOCATE(field_out)
3375 DEALLOCATE(oor_mask)
3384 IF (
PRESENT(rmask) .AND. missvalue_present )
THEN
3385 IF ( need_compute )
THEN
3387 TYPE IS (real(kind=r4_kind))
3388 DO k = l_start(3), l_end(3)
3389 k1 = k - l_start(3) + 1
3392 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND.&
3393 & j <= l_end(2)+hj )
THEN
3394 i1 = i-l_start(1)-hi+1
3395 j1 = j-l_start(2)-hj+1
3396 IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r4_kind ) &
3397 & output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
3402 TYPE IS (real(kind=r8_kind))
3403 DO k = l_start(3), l_end(3)
3404 k1 = k - l_start(3) + 1
3407 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND.&
3408 & j <= l_end(2)+hj )
THEN
3409 i1 = i-l_start(1)-hi+1
3410 j1 = j-l_start(2)-hj+1
3411 IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r8_kind ) &
3412 & output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
3418 CALL error_mesg (
'diag_manager_mod::send_data_3d',&
3419 &
'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
3421 ELSE IF ( reduced_k_range )
THEN
3425 TYPE IS (real(kind=r4_kind))
3430 IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r4_kind ) &
3431 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue
3435 TYPE IS (real(kind=r8_kind))
3440 IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r8_kind ) &
3441 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue
3446 CALL error_mesg (
'diag_manager_mod::send_data_3d',&
3447 &
'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
3451 TYPE IS (real(kind=r4_kind))
3455 IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r4_kind ) &
3456 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue
3460 TYPE IS (real(kind=r8_kind))
3464 IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r8_kind ) &
3465 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue
3470 CALL error_mesg (
'diag_manager_mod::send_data_3d',&
3471 &
'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
3476 END DO num_out_fields
3478 DEALLOCATE(field_out)
3479 DEALLOCATE(oor_mask)
3485 LOGICAL FUNCTION send_data_4d(diag_field_id, field, time, is_in, js_in, ks_in, &
3486 & mask, rmask, ie_in, je_in, ke_in, weight, err_msg)
3487 INTEGER,
INTENT(in) :: diag_field_id
3488 CLASS(*),
INTENT(in) :: field(:,:,:,:)
3489 CLASS(*),
INTENT(in),
OPTIONAL :: weight
3490 TYPE (
time_type),
INTENT(in),
OPTIONAL :: time
3491 INTEGER,
INTENT(in),
OPTIONAL :: is_in
3492 INTEGER,
INTENT(in),
OPTIONAL :: js_in
3493 INTEGER,
INTENT(in),
OPTIONAL :: ks_in
3494 INTEGER,
INTENT(in),
OPTIONAL :: ie_in
3495 INTEGER,
INTENT(in),
OPTIONAL :: je_in
3496 INTEGER,
INTENT(in),
OPTIONAL :: ke_in
3497 LOGICAL,
INTENT(in),
OPTIONAL :: mask(:,:,:,:)
3498 CLASS(*),
INTENT(in),
OPTIONAL :: rmask(:,:,:,:)
3499 CHARACTER(len=*),
INTENT(out),
OPTIONAL :: err_msg
3502 class(*),
allocatable :: rmask_local(:,:,:,:)
3503 logical,
allocatable :: mask_local(:,:,:,:)
3506 IF ( diag_field_id <= 0 )
THEN
3511 if (.not. use_modern_diag) &
3512 call mpp_error(fatal,
"Send_data_4d is only supported when diag_manager_nml::use_modern_diag=.true.")
3515 if (
present(mask)) mask_local = mask
3516 if (
present(rmask)) rmask_local = rmask
3518 call fms_diag_object%fms_diag_accept_data(diag_field_id, field, mask_local, rmask_local, &
3519 time, is_in, js_in, ks_in, ie_in, je_in, ke_in, weight, &
3523 if (
present(err_msg))
then
3524 if (err_msg .ne.
"")
then
3531 if (
allocated(rmask_local))
deallocate(rmask_local)
3532 if (
allocated(mask_local))
deallocate(mask_local)
3537 INTEGER,
INTENT(in) :: id
3538 REAL,
INTENT(in) :: field(:,:)
3539 REAL,
INTENT(in) :: area (:,:)
3541 LOGICAL,
INTENT(in),
OPTIONAL :: mask (:,:)
3543 REAL,
DIMENSION(SIZE(field,1)) :: out(size(field,1))
3557 INTEGER,
INTENT(in) :: diag_field_id
3558 REAL,
DIMENSION(:,:),
INTENT(in) :: x
3559 REAL,
DIMENSION(:,:),
INTENT(in) :: area
3560 LOGICAL,
DIMENSION(:,:),
INTENT(in) :: mask
3561 REAL,
DIMENSION(:),
INTENT(out) :: out
3564 REAL,
DIMENSION(SIZE(x,1)) :: s
3565 REAL :: local_missing_value
3569 IF ( diag_field_id <= 0 )
THEN
3573 CALL error_mesg(
'diag_manager_mod::average_tiles1d',&
3574 &
"diag_field_id less than 0. Contact developers.", fatal)
3578 IF ( input_fields(diag_field_id)%missing_value_present )
THEN
3579 local_missing_value = input_fields(diag_field_id)%missing_value
3581 local_missing_value = 0.0
3588 DO it = 1,
SIZE(area,dim=2)
3589 WHERE ( mask(:,it) )
3590 out(:) = out(:) + x(:,it)*area(:,it)
3591 s(:) = s(:) + area(:,it)
3596 out(:) = out(:)/s(:)
3598 out(:) = local_missing_value
3604 INTEGER,
INTENT(in) :: id
3605 REAL,
INTENT(in) :: field(:,:,:)
3606 REAL,
INTENT(in) :: area (:,:,:)
3608 LOGICAL,
INTENT(in),
OPTIONAL :: mask (:,:,:)
3610 REAL,
DIMENSION(SIZE(field,1),SIZE(field,2)) :: out(size(field,1), size(field,2))
3624 INTEGER,
INTENT(in) :: id
3625 REAL,
DIMENSION(:,:,:,:),
INTENT(in) :: field
3626 REAL,
DIMENSION(:,:,:),
INTENT(in) :: area (:,:,:)
3629 LOGICAL,
DIMENSION(:,:,:),
INTENT(in),
OPTIONAL :: mask
3631 REAL,
DIMENSION(SIZE(field,1),SIZE(field,2),SIZE(field,4)) :: out
3632 LOGICAL,
DIMENSION(SIZE(field,1),SIZE(field,2),SIZE(field,4)) :: mask3
3641 DO it=1,
SIZE(field,4)
3642 CALL average_tiles(id, field(:,:,:,it), area, mask, out(:,:,it) )
3645 mask3(:,:,1) = any(mask,dim=3)
3646 DO it = 2,
SIZE(field,4)
3647 mask3(:,:,it) = mask3(:,:,1)
3655 INTEGER,
INTENT(in) :: diag_field_id
3656 REAL,
DIMENSION(:,:,:),
INTENT(in) :: x
3657 REAL,
DIMENSION(:,:,:),
INTENT(in) :: area
3658 LOGICAL,
DIMENSION(:,:,:),
INTENT(in) :: mask
3659 REAL,
DIMENSION(:,:),
INTENT(out) :: out
3662 REAL,
DIMENSION(SIZE(x,1),SIZE(x,2)) :: s
3663 REAL :: local_missing_value
3667 IF ( diag_field_id <= 0 )
THEN
3671 CALL error_mesg(
'diag_manager_mod::average_tiles',&
3672 &
"diag_field_id less than 0. Contact developers.", fatal)
3676 IF ( input_fields(diag_field_id)%missing_value_present )
THEN
3677 local_missing_value = input_fields(diag_field_id)%missing_value
3679 local_missing_value = 0.0
3686 DO it = 1,
SIZE(area,3)
3687 WHERE ( mask(:,:,it) )
3688 out(:,:) = out(:,:) + x(:,:,it)*area(:,:,it)
3689 s(:,:) = s(:,:) + area(:,:,it)
3693 WHERE ( s(:,:) > 0 )
3694 out(:,:) = out(:,:)/s(:,:)
3696 out(:,:) = local_missing_value
3702 INTEGER,
INTENT(in) :: out_num
3703 LOGICAL,
INTENT(in) :: at_diag_end
3704 CHARACTER(len=*),
INTENT(out) :: error_string
3709 LOGICAL :: time_max, time_min, reduced_k_range, missvalue_present
3710 LOGICAL :: average, time_rms, need_compute, phys_window
3711 INTEGER :: in_num, file_num, freq, units
3712 INTEGER :: b1,b2,b3,b4
3713 INTEGER :: i, j, k, m
3714 REAL :: missvalue, num
3717 need_compute = output_fields(out_num)%need_compute
3719 in_num = output_fields(out_num)%input_field
3720 IF ( input_fields(in_num)%static )
RETURN
3722 missvalue = input_fields(in_num)%missing_value
3723 missvalue_present = input_fields(in_num)%missing_value_present
3724 reduced_k_range = output_fields(out_num)%reduced_k_range
3725 phys_window = output_fields(out_num)%phys_window
3727 average = output_fields(out_num)%time_average
3730 time_rms = output_fields(out_num)%time_rms
3732 time_max = output_fields(out_num)%time_max
3733 time_min = output_fields(out_num)%time_min
3734 file_num = output_fields(out_num)%output_file
3735 freq = files(file_num)%output_freq
3736 units = files(file_num)%output_units
3740 b1=
SIZE(output_fields(out_num)%buffer,1)
3741 b2=
SIZE(output_fields(out_num)%buffer,2)
3742 b3=
SIZE(output_fields(out_num)%buffer,3)
3743 b4=
SIZE(output_fields(out_num)%buffer,4)
3744 IF ( input_fields(in_num)%mask_variant )
THEN
3749 IF ( output_fields(out_num)%counter(i,j,k,m) > 0. )
THEN
3750 output_fields(out_num)%buffer(i,j,k,m) = &
3751 & output_fields(out_num)%buffer(i,j,k,m)/output_fields(out_num)%counter(i,j,k,m)
3752 IF ( time_rms ) output_fields(out_num)%buffer(i,j,k,m) = &
3753 sqrt(output_fields(out_num)%buffer(i,j,k,m))
3755 output_fields(out_num)%buffer(i,j,k,m) = missvalue
3763 IF ( phys_window )
THEN
3764 IF ( need_compute .OR. reduced_k_range )
THEN
3765 num = real(output_fields(out_num)%num_elements(m)/output_fields(out_num)%region_elements)
3767 num = real(output_fields(out_num)%num_elements(m)/output_fields(out_num)%total_elements)
3770 num = output_fields(out_num)%count_0d(m)
3772 IF ( num > 0. )
THEN
3773 IF ( missvalue_present )
THEN
3777 IF ( output_fields(out_num)%buffer(i,j,k,m) /= missvalue )
THEN
3778 output_fields(out_num)%buffer(i,j,k,m) = output_fields(out_num)%buffer(i,j,k,m)/num
3779 IF ( time_rms ) output_fields(out_num)%buffer(i,j,k,m) =&
3780 & sqrt(output_fields(out_num)%buffer(i,j,k,m))
3786 output_fields(out_num)%buffer(:,:,:,m) = output_fields(out_num)%buffer(:,:,:,m)/num
3787 IF ( time_rms ) output_fields(out_num)%buffer(:,:,:,m) =&
3788 & sqrt(output_fields(out_num)%buffer(:,:,:,m))
3790 ELSE IF ( .NOT. at_diag_end )
THEN
3791 IF ( missvalue_present )
THEN
3792 IF(any(output_fields(out_num)%buffer /= missvalue))
THEN
3793 WRITE (error_string,
'(a,"/",a)')&
3794 & trim(input_fields(in_num)%module_name), &
3795 & trim(output_fields(out_num)%output_name)
3803 ELSE IF ( time_min .OR. time_max )
THEN
3804 IF ( missvalue_present )
THEN
3805 WHERE ( abs(output_fields(out_num)%buffer) == min_value )
3806 output_fields(out_num)%buffer = missvalue
3812 IF ( at_diag_end .AND. freq == end_of_run ) output_fields(out_num)%next_output = time
3814 IF ( (output_fields(out_num)%time_ops) .AND. (.NOT. mix_snapshot_average_fields) )
THEN
3815 middle_time = (output_fields(out_num)%last_output+output_fields(out_num)%next_output)/2
3816 if (trim(files(file_num)%filename_time_bounds) ==
"begin")
then
3817 filename_time = output_fields(out_num)%last_output
3818 elseif (trim(files(file_num)%filename_time_bounds) ==
"middle")
then
3819 filename_time = middle_time
3820 elseif (trim(files(file_num)%filename_time_bounds) ==
"end")
then
3821 filename_time = output_fields(out_num)%next_output
3824 CALL diag_data_out(file_num, out_num, output_fields(out_num)%buffer, middle_time, &
3825 & filename_time=filename_time)
3828 & output_fields(out_num)%buffer, output_fields(out_num)%next_output)
3832 IF ( at_diag_end )
RETURN
3835 output_fields(out_num)%last_output = output_fields(out_num)%next_output
3836 IF ( freq == end_of_run )
THEN
3837 output_fields(out_num)%next_output = time
3839 IF ( freq == every_time )
THEN
3840 output_fields(out_num)%next_output = time
3842 output_fields(out_num)%next_output = output_fields(out_num)%next_next_output
3843 output_fields(out_num)%next_next_output = &
3844 & diag_time_inc(output_fields(out_num)%next_next_output, freq, units)
3846 output_fields(out_num)%count_0d(:) = 0.0
3847 output_fields(out_num)%num_elements(:) = 0
3848 IF ( time_max )
THEN
3849 output_fields(out_num)%buffer = max_value
3850 ELSE IF ( time_min )
THEN
3851 output_fields(out_num)%buffer = min_value
3853 output_fields(out_num)%buffer = empty
3855 IF ( input_fields(in_num)%mask_variant .AND. average ) output_fields(out_num)%counter = 0.0
3859 SUBROUTINE diag_manager_set_time_end(Time_end_in)
3860 TYPE (
time_type),
INTENT(in) :: time_end_in
3862 time_end = time_end_in
3863 if (use_modern_diag)
then
3864 call fms_diag_object%set_time_end(time_end_in)
3867 END SUBROUTINE diag_manager_set_time_end
3882 integer :: file, j, freq, in_num, file_num, out_num
3884 DO file = 1, num_files
3885 freq = files(file)%output_freq
3887 DO j = 1, files(file)%num_fields
3888 out_num = files(file)%fields(j)
3889 in_num = output_fields(out_num)%input_field
3890 IF ( (input_fields(in_num)%numthreads == 1) .AND.&
3891 & (input_fields(in_num)%active_omp_level.LE.1) ) cycle
3892 file_num = output_fields(out_num)%output_file
3894 & output_fields(out_num)%buffer, time)
3903 TYPE (
time_type),
INTENT(in) :: time_step
3904 character(len=*),
INTENT(out),
optional :: err_msg
3907 integer :: file, j, out_num, in_num, freq, status
3908 logical :: local_output, need_compute
3909 CHARACTER(len=128) :: error_string
3911 IF ( time_end == time_zero )
THEN
3915 CALL error_mesg(
'diag_manager_mod::diag_send_complete',&
3916 &
"diag_manager_set_time_end must be called before diag_send_complete", fatal)
3919 if (use_modern_diag)
then
3920 call fms_diag_object%fms_diag_send_complete(time_step)
3924 DO file = 1, num_files
3925 freq = files(file)%output_freq
3926 DO j = 1, files(file)%num_fields
3927 out_num = files(file)%fields(j)
3928 in_num = output_fields(out_num)%input_field
3930 IF ( (input_fields(in_num)%numthreads == 1) .AND. (input_fields(in_num)%active_omp_level.LE.1) ) cycle
3931 IF ( output_fields(out_num)%static .OR. freq == end_of_run ) cycle
3932 time = input_fields(in_num)%time
3933 IF ( time >= time_end ) cycle
3936 local_output = output_fields(out_num)%local_output
3938 need_compute = output_fields(out_num)%need_compute
3940 IF ( local_output .AND. (.NOT.need_compute) ) cycle
3941 next_time = time + time_step
3943 IF ( next_time > output_fields(out_num)%next_output )
THEN
3945 IF ( next_time > output_fields(out_num)%next_next_output .AND. freq > 0 )
THEN
3946 IF (
mpp_pe() .EQ. mpp_root_pe() )
THEN
3947 WRITE (error_string,
'(a,"/",a)')&
3948 & trim(input_fields(in_num)%module_name), &
3949 & trim(output_fields(out_num)%output_name)
3951 &
'module/output_field '//trim(error_string)//&
3952 &
' is skipped one time level in output data', err_msg))
RETURN
3956 status =
writing_field(out_num, .false., error_string, next_time)
3957 IF ( status == -1 )
THEN
3958 IF (
mpp_pe() .EQ. mpp_root_pe() )
THEN
3959 IF(
fms_error_handler(
'diag_manager_mod::diag_send_complete',
'module/output_field '//&
3960 & trim(error_string)//
', write EMPTY buffer', err_msg))
RETURN
3976 IF ( do_diag_field_log )
THEN
3977 close (diag_log_unit)
3979 DO file = 1, num_files
3982 if (
allocated(fileobju))
deallocate(fileobju)
3983 if (
allocated(fileobj))
deallocate(fileobj)
3984 if (
allocated(fileobjnd))
deallocate(fileobjnd)
3987 if (use_modern_diag)
then
3988 call fms_diag_object%diag_end(time)
3994 INTEGER,
INTENT(in) :: file
3997 INTEGER :: j, i, input_num, freq, status
3998 INTEGER :: stdout_unit
3999 LOGICAL :: reduced_k_range, need_compute, local_output
4000 CHARACTER(len=128) :: message
4005 DO j = 1, files(file)%num_fields
4006 i = files(file)%fields(j)
4009 local_output = output_fields(i)%local_output
4011 need_compute = output_fields(i)%need_compute
4013 reduced_k_range = output_fields(i)%reduced_k_range
4016 IF ( local_output .AND. (.NOT. need_compute) ) cycle
4018 input_num = output_fields(i)%input_field
4019 IF ( input_fields(input_num)%static ) cycle
4020 IF ( .NOT.input_fields(input_num)%register ) cycle
4021 freq = files(file)%output_freq
4022 IF ( freq /= end_of_run .AND. files(file)%file_unit < 0 &
4023 & .AND. all(output_fields(i)%num_elements(:) == 0)&
4024 & .AND. all(output_fields(i)%count_0d(:) == 0) ) cycle
4027 IF ( time >= output_fields(i)%next_output .OR. freq == end_of_run )
THEN
4028 IF ( time >= output_fields(i)%next_next_output .AND. freq > 0 )
THEN
4029 WRITE (message,
'(a,"/",a)') trim(input_fields(input_num)%module_name), &
4030 & trim(output_fields(i)%output_name)
4035 IF (
mpp_pe() .EQ. mpp_root_pe() ) &
4036 &
CALL error_mesg(
'diag_manager_mod::closing_file',
'module/output_field ' //&
4037 & trim(message)//
', skip one time level, maybe send_data never called', warning)
4042 ELSEIF ( .NOT.output_fields(i)%written_once )
THEN
4047 CALL error_mesg(
'Potential error in diag_manager_end ',&
4048 & trim(output_fields(i)%output_name)//
' NOT available,'//&
4049 &
' check if output interval > runlength. Netcdf fill_values are written', note)
4050 output_fields(i)%buffer = fill_value
4051 CALL diag_data_out(file, i, output_fields(i)%buffer, time, .true.)
4058 IF ( write_bytes_in_file )
THEN
4059 CALL mpp_sum (files(file)%bytes_written)
4060 IF (
mpp_pe() == mpp_root_pe() )&
4061 &
WRITE (stdout_unit,
'(a,i12,a,a)')
'Diag_Manager: ',files(file)%bytes_written, &
4062 &
' bytes of data written to file ',trim(files(file)%name)
4069 INTEGER,
OPTIONAL,
INTENT(IN) :: diag_model_subset
4070 INTEGER,
DIMENSION(6),
OPTIONAL,
INTENT(IN) :: time_init
4071 CHARACTER(len=*),
INTENT(out),
OPTIONAL :: err_msg
4073 CHARACTER(len=*),
PARAMETER :: sep =
'|'
4075 INTEGER,
PARAMETER :: fltkind = r4_kind
4076 INTEGER,
PARAMETER :: dblkind = r8_kind
4077 INTEGER :: diag_subset_output
4079 INTEGER,
ALLOCATABLE,
DIMENSION(:) :: pelist
4080 INTEGER :: stdlog_unit, stdout_unit
4082 CHARACTER(len=256) :: err_msg_local
4084 namelist /diag_manager_nml/ append_pelist_name, mix_snapshot_average_fields, max_output_fields, &
4085 & max_input_fields, max_axes, do_diag_field_log, write_bytes_in_file, debug_diag_manager,&
4086 & max_num_axis_sets, max_files, use_cmor, issue_oor_warnings,&
4087 & oor_warnings_fatal, max_out_per_in_field, flush_nc_files, region_out_use_alt_value, max_field_attributes,&
4088 & max_file_attributes, max_axis_attributes, prepend_date, use_modern_diag, use_clock_average, &
4092 IF ( module_is_initialized )
RETURN
4095 IF (
PRESENT(err_msg) ) err_msg =
''
4100 call diag_data_init()
4103 pack_size =
SIZE(transfer(0.0_dblkind, (/0.0, 0.0, 0.0, 0.0/)))
4104 IF (pack_size .EQ. 1)
then
4105 pack_size_str =
"double"
4106 else if (pack_size .EQ. 2)
then
4107 pack_size_str =
"float"
4109 IF (
fms_error_handler(
'diag_manager_mod::diag_manager_init',
'unknown pack_size. Must be 1, or 2.', &
4114 min_value = huge(0.0_fltkind)
4115 max_value = -min_value
4126 time_end = time_zero
4127 diag_subset_output = diag_all
4128 IF (
PRESENT(diag_model_subset) )
THEN
4129 IF ( diag_model_subset >= diag_other .AND. diag_model_subset <= diag_all )
THEN
4130 diag_subset_output = diag_model_subset
4132 IF (
fms_error_handler(
'diag_manager_mod::diag_manager_init',
'invalid value of diag_model_subset', &
4137 READ (input_nml_file, nml=diag_manager_nml, iostat=mystat)
4140 IF (
check_nml_error(iostat=mystat, nml_name=
'DIAG_MANAGER_NML') < 0 )
THEN
4141 IF (
mpp_pe() == mpp_root_pe() )
THEN
4142 CALL error_mesg(
'diag_manager_mod::diag_manager_init', &
4143 &
'DIAG_MANAGER_NML not found in input nml file. Using defaults.', warning)
4147 IF (.not. use_modern_diag .and. use_clock_average) &
4148 call mpp_error(fatal,
"diag_manager_mod: You cannot set use_modern_diag=.false. and &
4149 & use_clock_average=.true. in diag_manager_nml")
4151 IF (
mpp_pe() == mpp_root_pe() )
THEN
4152 WRITE (stdlog_unit, diag_manager_nml)
4156 IF ( use_cmor )
THEN
4158 WRITE (err_msg_local,
'(ES8.1E2)') cmor_missing_value
4159 CALL error_mesg(
'diag_manager_mod::diag_manager_init',
'Using CMOR missing value ('//trim(err_msg_local)// &
4164 IF ( oor_warnings_fatal )
THEN
4166 CALL error_mesg(
'diag_manager_mod::diag_manager_init',
'Out &
4167 &of Range warnings are fatal.', note)
4168 ELSEIF ( .NOT.issue_oor_warnings )
THEN
4169 CALL error_mesg(
'diag_manager_mod::diag_manager_init',
'Out &
4170 &of Range warnings will be ignored.', note)
4173 IF ( mix_snapshot_average_fields )
THEN
4174 IF ( .not. use_modern_diag )
THEN
4175 CALL error_mesg(
'diag_manager_mod::diag_manager_init',
'Setting diag_manager_nml variable '//&
4176 &
'mix_snapshot_average_fields = .TRUE. will cause ERRORS in the time coordinates '//&
4177 &
'of all time averaged fields. Strongly recommend setting mix_snapshot_average_fields '//&
4178 &
'= .FALSE.', note)
4180 CALL error_mesg(
'diag_manager_mod::diag_manager_init',
'mix_snapshot_average_fields = .TRUE. is not '//&
4181 &
'supported if use_modern_diag = .TRUE. Please set mix_snapshot_average_fields '//&
4182 &
'to .FALSE. and put instantaneous and averaged fields in seperate files!', fatal)
4185 ALLOCATE(output_fields(max_output_fields))
4186 ALLOCATE(input_fields(max_input_fields))
4187 DO j = 1, max_input_fields
4188 ALLOCATE(input_fields(j)%output_fields(max_out_per_in_field))
4191 ALLOCATE(files(max_files))
4192 ALLOCATE(fileobju(max_files))
4193 ALLOCATE(fileobj(max_files))
4194 ALLOCATE(fileobjnd(max_files))
4199 CALL mpp_get_current_pelist(pelist, pelist_name)
4202 IF (
PRESENT(time_init) )
THEN
4203 diag_init_time =
set_date(time_init(1), time_init(2), time_init(3), time_init(4),&
4204 & time_init(5), time_init(6))
4206 diag_init_time = get_base_time()
4207 IF ( prepend_date .EQV. .true. )
THEN
4208 CALL error_mesg(
'diag_manager_mod::diag_manager_init',&
4209 &
'prepend_date only supported when diag_manager_init is called with time_init present.', note)
4210 prepend_date = .false.
4214 if (use_modern_diag)
then
4215 CALL error_mesg(
'diag_manager_mod::diag_manager_init',&
4216 &
'You are using the yaml version of the diag table', note)
4217 CALL fms_diag_object%init(diag_subset_output, time_init)
4219 if (.not. use_modern_diag)
then
4220 CALL error_mesg(
'diag_manager_mod::diag_manager_init',&
4221 &
'You are using the legacy version of the diag table', note)
4222 CALL parse_diag_table(diag_subset=diag_subset_output, istat=mystat, err_msg=err_msg_local)
4223 IF ( mystat /= 0 )
THEN
4225 &
'Error parsing diag_table. '//trim(err_msg_local), err_msg) )
RETURN
4229 files(:)%bytes_written = 0
4232 IF ( do_diag_field_log.AND.
mpp_pe().EQ.mpp_root_pe() )
THEN
4233 open(newunit=diag_log_unit, file=
'diag_field_log.out.'//
string(
mpp_pe()), action=
'WRITE')
4234 WRITE (diag_log_unit,
'(777a)') &
4242 module_is_initialized = .true.
4244 if(.not. use_modern_diag) null_axis_id = diag_axis_init(
'scalar_axis', (/0./),
'none',
'N',
'none')
4251 INTEGER,
INTENT(out) :: year, month, day, hour, minute, second
4254 IF (.NOT.module_is_initialized)
CALL error_mesg (
'diag_manager_mod::get_base_date', &
4255 &
'module has not been initialized', fatal)
4256 year = get_base_year()
4257 month = get_base_month()
4258 day = get_base_day()
4259 hour = get_base_hour()
4260 minute = get_base_minute()
4261 second = get_base_second()
4271 TYPE(
time_type),
INTENT(in) :: next_model_time
4272 INTEGER,
INTENT(in) :: diag_field_id
4274 INTEGER :: i, out_num
4277 IF ( diag_field_id < 0 )
RETURN
4278 DO i = 1, input_fields(diag_field_id)%num_output_fields
4280 out_num = input_fields(diag_field_id)%output_fields(i)
4281 IF ( .NOT.output_fields(out_num)%static )
THEN
4282 IF ( next_model_time > output_fields(out_num)%next_output )
need_data=.true.
4286 IF ( output_fields(out_num)%time_average)
need_data = .true.
4298 INTEGER,
INTENT(in) :: n_samples
4300 REAL :: center_data (n_samples)
4301 REAL :: edges (n_samples+1)
4310 CHARACTER(32) :: name
4311 CHARACTER(128) :: units
4314 WRITE (units,11)
'hours', year, month, day, hour, minute, second
4315 11
FORMAT(a,
' since ',i4.4,
'-',i2.2,
'-',i2.2,
' ',i2.2,
':',i2.2,
':',i2.2)
4319 center_data(i) = 24.0*(real(i)-0.5)/n_samples
4320 edges(i+1) = 24.0* real(i)/n_samples
4325 WRITE (name,
'(a,i2.2)')
'time_of_day_edges_', n_samples
4326 edges_id = get_axis_num(name,
'diurnal')
4327 IF ( edges_id <= 0 )
THEN
4328 edges_id = diag_axis_init(name,edges,units,
'N',
'time of day edges', set_name=
'diurnal')
4333 WRITE (name,
'(a,i2.2)')
'time_of_day_', n_samples
4336 init_diurnal_axis = diag_axis_init(name, center_data, units,
'N',
'time of day', &
4337 set_name=
'diurnal', edges=edges_id)
4342 INTEGER,
INTENT(in) :: diag_field_id
4343 CHARACTER(len=*),
INTENT(in) :: name
4344 INTEGER,
INTENT(in) ::
type
4345 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: cval
4346 INTEGER,
DIMENSION(:),
INTENT(in),
OPTIONAL :: ival
4347 REAL,
DIMENSION(:),
INTENT(in),
OPTIONAL :: rval
4349 INTEGER :: istat, length, i, j, this_attribute, out_field
4351 IF ( .NOT.first_send_data_call )
THEN
4357 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',
'Attempting to add attribute "'&
4358 &//trim(name)//
'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//
'/'&
4359 &//trim(input_fields(diag_field_id)%field_name)//
'" after first send_data call. Too late.', fatal)
4363 IF ( diag_field_id .LE. 0 )
THEN
4366 DO j=1,input_fields(diag_field_id)%num_output_fields
4367 out_field = input_fields(diag_field_id)%output_fields(j)
4374 DO i=1, output_fields(out_field)%num_attributes
4375 IF ( trim(output_fields(out_field)%attributes(i)%name) .EQ. trim(name) )
THEN
4381 IF ( this_attribute.NE.0 .AND. (type.EQ.nf90_int .OR. type.EQ.nf90_float) )
THEN
4386 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',&
4387 &
'Attribute "'//trim(name)//
'" already defined for module/input_field "'&
4388 &//trim(input_fields(diag_field_id)%module_name)//
'/'&
4389 &//trim(input_fields(diag_field_id)%field_name)//
'". Contact the developers.', fatal)
4390 ELSE IF ( this_attribute.NE.0 .AND. type.EQ.nf90_char .AND. debug_diag_manager )
THEN
4395 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',&
4396 &
'Attribute "'//trim(name)//
'" already defined for module/input_field "'&
4397 &//trim(input_fields(diag_field_id)%module_name)//
'/'&
4398 &//trim(input_fields(diag_field_id)%field_name)//
'". Prepending.', note)
4399 ELSE IF ( this_attribute.EQ.0 )
THEN
4402 this_attribute = output_fields(out_field)%num_attributes + 1
4404 IF ( this_attribute .GT. max_field_attributes )
THEN
4410 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',&
4411 &
'Number of attributes exceeds max_field_attributes for attribute "'&
4412 &//trim(name)//
'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//
'/'&
4413 &//trim(input_fields(diag_field_id)%field_name)&
4414 &//
'". Increase diag_manager_nml:max_field_attributes.', fatal)
4416 output_fields(out_field)%num_attributes = this_attribute
4418 output_fields(out_field)%attributes(this_attribute)%name = name
4419 output_fields(out_field)%attributes(this_attribute)%type =
type
4421 output_fields(out_field)%attributes(this_attribute)%catt =
''
4427 IF ( .NOT.
PRESENT(ival) )
THEN
4433 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',&
4434 &
'Attribute type claims INTEGER, but ival not present for attribute "'&
4435 &//trim(name)//
'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//
'/'&
4436 &//trim(input_fields(diag_field_id)%field_name)//
'". Contact then developers.', fatal)
4440 ALLOCATE(output_fields(out_field)%attributes(this_attribute)%iatt(length), stat=istat)
4441 IF ( istat.NE.0 )
THEN
4445 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',
'Unable to allocate iatt for attribute "'&
4446 &//trim(name)//
'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//
'/'&
4447 &//trim(input_fields(diag_field_id)%field_name)//
'"', fatal)
4450 output_fields(out_field)%attributes(this_attribute)%len = length
4451 output_fields(out_field)%attributes(this_attribute)%iatt = ival
4453 IF ( .NOT.
PRESENT(rval) )
THEN
4459 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',&
4460 &
'Attribute type claims REAL, but rval not present for attribute "'&
4461 &//trim(name)//
'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//
'/'&
4462 &//trim(input_fields(diag_field_id)%field_name)//
'". Contact the developers.', fatal)
4466 ALLOCATE(output_fields(out_field)%attributes(this_attribute)%fatt(length), stat=istat)
4467 IF ( istat.NE.0 )
THEN
4471 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',
'Unable to allocate fatt for attribute "'&
4472 &//trim(name)//
'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//
'/'&
4473 &//trim(input_fields(diag_field_id)%field_name)//
'"', fatal)
4476 output_fields(out_field)%attributes(this_attribute)%len = length
4477 output_fields(out_field)%attributes(this_attribute)%fatt = rval
4479 IF ( .NOT.
PRESENT(cval) )
THEN
4485 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',&
4486 &
'Attribute type claims CHARACTER, but cval not present for attribute "'&
4487 &//trim(name)//
'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//
'/'&
4488 &//trim(input_fields(diag_field_id)%field_name)//
'". Contact the developers.', fatal)
4496 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',
'Unknown attribute type for attribute "'&
4497 &//trim(name)//
'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//
'/'&
4498 &//trim(input_fields(diag_field_id)%field_name)//
'". Contact the developers.', fatal)
4506 INTEGER,
INTENT(in) :: diag_field_id
4507 CHARACTER(len=*),
INTENT(in) :: att_name
4508 class(*),
INTENT(in) :: att_value
4510 if (use_modern_diag)
then
4511 select type(att_value)
4512 type is (real(kind=r4_kind))
4513 call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, (/att_value /))
4514 type is (real(kind=r8_kind))
4515 call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, (/att_value /))
4516 type is (
integer(kind=i4_kind))
4517 call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, (/att_value /))
4518 type is (
character(len=*))
4519 call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, (/att_value /))
4521 call mpp_error(fatal,
"Diag_field_add_attribute 0d:: unsupported type. The acceptable types "//&
4522 "are float, double, integer, and string")
4525 select type(att_value)
4526 type is (real(kind=r4_kind))
4528 type is (real(kind=r8_kind))
4530 type is (
integer(kind=i4_kind))
4532 type is (
character(len=*))
4535 call mpp_error(fatal,
"Diag_field_add_attribute 0d:: unsupported type. The acceptable types "//&
4536 "are float, double, integer, and string")
4544 INTEGER,
INTENT(in) :: diag_field_id
4545 CHARACTER(len=*),
INTENT(in) :: att_name
4546 class(*),
INTENT(in) :: att_value(:)
4548 if (use_modern_diag)
then
4549 call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, att_value)
4551 select type(att_value)
4552 type is (real(kind=r4_kind))
4554 type is (real(kind=r8_kind))
4556 type is (
integer(kind=i4_kind))
4559 call mpp_error(fatal,
"Diag_field_add_attribute 1d:: unsupported type. The acceptable types "//&
4560 "are float, double, and integer")
4571 INTEGER,
INTENT(in) :: diag_field_id
4572 INTEGER,
INTENT(in),
OPTIONAL :: area
4573 INTEGER,
INTENT(in),
OPTIONAL :: volume
4577 IF ( diag_field_id.GT.0 )
THEN
4578 IF ( .NOT.
PRESENT(area) .AND. .NOT.
present(volume) )
THEN
4579 CALL error_mesg(
'diag_manager_mod::diag_field_add_cell_measures', &
4580 &
'either area or volume arguments must be present', fatal )
4583 if (use_modern_diag)
then
4584 call fms_diag_object%fms_diag_field_add_cell_measures(diag_field_id, area, volume)
4588 DO j=1, input_fields(diag_field_id)%num_output_fields
4589 ind = input_fields(diag_field_id)%output_fields(j)
4597 class(*),
intent(in) :: data_in(:,:,:)
4598 character(len=*),
intent(in) :: field_name
4599 class(*),
allocatable,
intent(out) :: data_out(:,:,:,:)
4602 select type(data_in)
4603 type is (real(kind=r8_kind))
4604 allocate(real(kind=r8_kind) :: data_out(1:
size(data_in,1), 1:
size(data_in,2), 1:
size(data_in,3), 1))
4605 select type (data_out)
4606 type is (real(kind=r8_kind))
4607 data_out(:,:,:,1) = data_in
4609 call mpp_error(fatal,
"The copy of "//trim(field_name)//&
4610 " was not allocated to the correct type (r8_kind). This shouldn't have happened")
4612 type is (real(kind=r4_kind))
4613 allocate(real(kind=r4_kind) :: data_out(1:
size(data_in,1), 1:
size(data_in,2), 1:
size(data_in,3), 1))
4614 select type (data_out)
4615 type is (real(kind=r4_kind))
4616 data_out(:,:,:,1) = data_in
4618 call mpp_error(fatal,
"The copy of "//trim(field_name)//&
4619 " was not allocated to the correct type (r4_kind). This shouldn't have happened")
4622 call mpp_error(fatal,
"The data for "//trim(field_name)//&
4623 &
" is not a valid type. Currently only r4 and r8 are supported")
4627 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.