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
386 & long_name, units, missing_value, range, standard_name, do_not_log, err_msg,&
387 & area, volume, realm, multiple_send_data)
388 CHARACTER(len=*),
INTENT(in) :: module_name
389 CHARACTER(len=*),
INTENT(in) :: field_name
390 TYPE(
time_type),
OPTIONAL,
INTENT(in) :: init_time
391 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: long_name
392 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: units
393 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: standard_name
394 CLASS(*),
OPTIONAL,
INTENT(in) :: missing_value
395 CLASS(*),
OPTIONAL,
INTENT(in) :: range(:)
396 LOGICAL,
OPTIONAL,
INTENT(in) :: do_not_log
397 CHARACTER(len=*),
OPTIONAL,
INTENT(out):: err_msg
398 INTEGER,
OPTIONAL,
INTENT(in) :: area
399 INTEGER,
OPTIONAL,
INTENT(in) :: volume
400 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: realm
401 LOGICAL,
OPTIONAL,
INTENT(in) :: multiple_send_data
405 IF (
PRESENT(range) )
THEN
406 IF (
SIZE(range) .NE. 2 )
THEN
408 CALL error_mesg (
'diag_manager_mod::register_diag_field',
'extent of range should be 2', fatal)
411 if (use_modern_diag)
then
412 if( do_diag_field_log)
then
413 if (
PRESENT(do_not_log) )
THEN
414 if(.not. do_not_log)
call log_diag_field_info(module_name, field_name, (/null_axis_id/), long_name,&
415 & units, missing_value, range, dynamic=.true.)
418 & missing_value, range, dynamic=.true.)
422 & module_name, field_name, init_time, long_name=long_name, units=units, &
423 & missing_value=missing_value, var_range=range, standard_name=standard_name, &
424 & do_not_log=do_not_log, err_msg=err_msg, area=area, volume=volume, realm=realm, &
425 multiple_send_data=multiple_send_data)
428 & long_name=long_name, units=units, missing_value=missing_value, range=range, standard_name=standard_name, &
429 & do_not_log=do_not_log, err_msg=err_msg, area=area, volume=volume, realm=realm)
436 & long_name, units, missing_value, range, mask_variant, standard_name, verbose,&
437 & do_not_log, err_msg, interp_method, tile_count, area, volume, realm, multiple_send_data)
438 CHARACTER(len=*),
INTENT(in) :: module_name
439 CHARACTER(len=*),
INTENT(in) :: field_name
440 INTEGER,
INTENT(in) :: axes(:)
441 TYPE(
time_type),
OPTIONAL,
INTENT(in) :: init_time
442 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: long_name
443 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: units
444 CLASS(*),
OPTIONAL,
INTENT(in) :: missing_value
445 CLASS(*),
OPTIONAL,
INTENT(in) :: range(:)
446 LOGICAL,
OPTIONAL,
INTENT(in) :: mask_variant
447 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: standard_name
448 LOGICAL,
OPTIONAL,
INTENT(in) :: verbose
449 LOGICAL,
OPTIONAL,
INTENT(in) :: do_not_log
450 CHARACTER(len=*),
OPTIONAL,
INTENT(out):: err_msg
451 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: interp_method
455 INTEGER,
OPTIONAL,
INTENT(in) :: tile_count
456 INTEGER,
OPTIONAL,
INTENT(in) :: area
457 INTEGER,
OPTIONAL,
INTENT(in) :: volume
458 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: realm
459 LOGICAL,
OPTIONAL,
INTENT(in) :: multiple_send_data
462 if (use_modern_diag)
then
463 if( do_diag_field_log)
then
464 if (
PRESENT(do_not_log) )
THEN
466 & units, missing_value, range, dynamic=.true.)
469 & missing_value, range, dynamic=.true.)
473 & module_name, field_name, axes, init_time, long_name=long_name, &
474 & units=units, missing_value=missing_value, var_range=range, mask_variant=mask_variant, &
475 & standard_name=standard_name, verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
476 & interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm, &
477 multiple_send_data=multiple_send_data)
480 & long_name=long_name, units=units, missing_value=missing_value, range=range, mask_variant=mask_variant, &
481 & standard_name=standard_name, verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
482 & interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm)
489 & missing_value, range, mask_variant, standard_name, DYNAMIC, do_not_log, interp_method,&
490 & tile_count, area, volume, realm)
491 CHARACTER(len=*),
INTENT(in) :: module_name
492 CHARACTER(len=*),
INTENT(in) :: field_name
493 INTEGER,
DIMENSION(:),
INTENT(in) :: axes
494 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: long_name
495 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: units
496 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: standard_name
497 CLASS(*),
OPTIONAL,
INTENT(in) :: missing_value
498 CLASS(*),
DIMENSION(:),
OPTIONAL,
INTENT(in) :: range
499 LOGICAL,
OPTIONAL,
INTENT(in) :: mask_variant
500 LOGICAL,
OPTIONAL,
INTENT(in) :: dynamic
501 LOGICAL,
OPTIONAL,
INTENT(in) :: do_not_log
502 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: interp_method
506 INTEGER,
OPTIONAL,
INTENT(in) :: tile_count
507 INTEGER,
OPTIONAL,
INTENT(in) :: area
509 INTEGER,
OPTIONAL,
INTENT(in) :: volume
511 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: realm
515 IF ( .NOT.module_is_initialized )
THEN
517 CALL error_mesg (
'diag_manager_mod::register_static_field',
'diag_manager has NOT been initialized', fatal)
520 if (use_modern_diag)
then
521 if( do_diag_field_log)
then
522 if (
PRESENT(do_not_log) )
THEN
524 & units, missing_value, range, dynamic=.false.)
527 & missing_value, range, dynamic=.false.)
531 & long_name=long_name, units=units, missing_value=missing_value, range=range, mask_variant=mask_variant, &
532 & standard_name=standard_name, dynamic=dynamic, do_not_log=do_not_log, interp_method=interp_method,&
533 & tile_count=tile_count, area=area, volume=volume, realm=realm)
536 & long_name=long_name, units=units, missing_value=missing_value, range=range, mask_variant=mask_variant, &
537 & standard_name=standard_name, dynamic=dynamic, do_not_log=do_not_log, interp_method=interp_method,&
538 & tile_count=tile_count, area=area, volume=volume, realm=realm)
545 & long_name, units, missing_value, range, standard_name, do_not_log, err_msg,&
546 & area, volume, realm)
547 CHARACTER(len=*),
INTENT(in) :: module_name
548 CHARACTER(len=*),
INTENT(in) :: field_name
549 TYPE(
time_type),
OPTIONAL,
INTENT(in) :: init_time
550 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: long_name
551 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: units
552 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: standard_name
553 CLASS(*),
OPTIONAL,
INTENT(in) :: missing_value
554 CLASS(*),
OPTIONAL,
INTENT(in) :: range(:)
555 LOGICAL,
OPTIONAL,
INTENT(in) :: do_not_log
556 CHARACTER(len=*),
OPTIONAL,
INTENT(out):: err_msg
557 INTEGER,
OPTIONAL,
INTENT(in) :: area
558 INTEGER,
OPTIONAL,
INTENT(in) :: volume
559 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: realm
561 IF (
PRESENT(err_msg) ) err_msg =
''
563 IF (
PRESENT(init_time) )
THEN
565 & (/null_axis_id/), init_time,long_name, units, missing_value, range, &
566 & standard_name=standard_name, do_not_log=do_not_log, err_msg=err_msg,&
567 & area=area, volume=volume, realm=realm)
570 & (/null_axis_id/),long_name, units, missing_value, range,&
571 & standard_name=standard_name, do_not_log=do_not_log, realm=realm)
578 & long_name, units, missing_value, range, mask_variant, standard_name, verbose,&
579 & do_not_log, err_msg, interp_method, tile_count, area, volume, realm)
580 CHARACTER(len=*),
INTENT(in) :: module_name, field_name
581 INTEGER,
INTENT(in) :: axes(:)
583 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: long_name, units, standard_name
584 CLASS(*),
OPTIONAL,
INTENT(in) :: missing_value
585 CLASS(*),
DIMENSION(:),
OPTIONAL,
INTENT(in) :: range
586 LOGICAL,
OPTIONAL,
INTENT(in) :: mask_variant,verbose
587 LOGICAL,
OPTIONAL,
INTENT(in) :: do_not_log
588 CHARACTER(len=*),
OPTIONAL,
INTENT(out):: err_msg
589 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: interp_method
593 INTEGER,
OPTIONAL,
INTENT(in) :: tile_count
594 INTEGER,
OPTIONAL,
INTENT(in) :: area
595 INTEGER,
OPTIONAL,
INTENT(in) :: volume
596 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: realm
598 INTEGER :: field, j, ind, file_num, freq
599 INTEGER :: output_units
600 INTEGER :: stdout_unit
601 LOGICAL :: mask_variant1, verbose1
602 CHARACTER(len=128) :: msg
608 IF (
PRESENT(mask_variant) )
THEN
609 mask_variant1 = mask_variant
611 mask_variant1 = .false.
614 IF (
PRESENT(verbose) )
THEN
620 IF (
PRESENT(err_msg) ) err_msg =
''
623 IF (
PRESENT(range) )
THEN
624 IF (
SIZE(range) .NE. 2 )
THEN
626 CALL error_mesg (
'diag_manager_mod::register_diag_field',
'extent of range should be 2', fatal)
632 & long_name, units, missing_value, range, mask_variant1, standard_name=standard_name,&
633 & dynamic=.true., do_not_log=do_not_log, interp_method=interp_method, tile_count=tile_count, realm=realm)
635 IF ( .NOT.first_send_data_call )
THEN
640 IF (
mpp_pe() == mpp_root_pe() ) &
641 &
CALL error_mesg (
'diag_manager_mod::register_diag_field',
'module/output_field '&
642 &//trim(module_name)//
'/'// trim(field_name)//&
643 &
' registered AFTER first send_data call, TOO LATE', warning)
650 IF ( debug_diag_manager .OR. verbose1 )
THEN
651 IF (
mpp_pe() == mpp_root_pe() ) &
652 &
CALL error_mesg (
'diag_manager_mod::register_diag_field',
'module/output_field '&
653 &//trim(module_name)//
'/'// trim(field_name)//
' NOT found in diag_table',&
662 IF (
PRESENT(volume).AND.
PRESENT(area) )
THEN
663 IF ( area.EQ.volume )
THEN
664 IF (
PRESENT(err_msg))
THEN
665 err_msg =
'diag_manager_mod::register_diag_field: module/output_field '&
666 &//trim(module_name)//
'/'// trim(field_name)//
' AREA and VOLUME CANNOT be the same variable.&
667 & Contact the developers.'
671 CALL error_mesg (
'diag_manager_mod::register_diag_field',
'module/output_field '&
672 &//trim(module_name)//
'/'// trim(field_name)//
' AREA and VOLUME CANNOT be the same variable.&
673 & Contact the developers.',&
680 IF (
PRESENT(area) )
THEN
682 IF (
PRESENT(err_msg))
THEN
683 err_msg =
'diag_manager_mod::register_diag_field: module/output_field '&
684 &//trim(module_name)//
'/'// trim(field_name)//
' AREA measures field NOT found in diag_table.&
685 & Contact the model liaison.'
689 CALL error_mesg (
'diag_manager_mod::register_diag_field',
'module/output_field '&
690 &//trim(module_name)//
'/'// trim(field_name)//
' AREA measures field NOT found in diag_table.&
691 & Contact the model liaison.',&
696 IF (
PRESENT(volume) )
THEN
697 IF ( volume < 0 )
THEN
698 IF (
PRESENT(err_msg))
THEN
699 err_msg =
'diag_manager_mod::register_diag_field: module/output_field '&
700 &//trim(module_name)//
'/'// trim(field_name)//
' VOLUME measures field NOT found in diag_table.&
701 & Contact the model liaison.'
705 CALL error_mesg (
'diag_manager_mod::register_diag_field',
'module/output_field '&
706 &//trim(module_name)//
'/'// trim(field_name)//
' VOLUME measures field NOT found in diag_table.&
707 & Contact the model liaison.',&
713 IF (
PRESENT(standard_name) ) input_fields(field)%standard_name = standard_name
715 DO j = 1, input_fields(field)%num_output_fields
716 ind = input_fields(field)%output_fields(j)
717 output_fields(ind)%static = .false.
720 file_num = output_fields(ind)%output_file
721 IF ( file_num == max_files ) cycle
722 IF ( output_fields(ind)%local_output )
THEN
723 IF ( output_fields(ind)%need_compute)
THEN
724 files(file_num)%local = .true.
732 IF ( msg /=
'' )
THEN
733 IF (
fms_error_handler(
'diag_manager_mod::register_diag_field', trim(msg), err_msg) )
RETURN
736 freq = files(file_num)%output_freq
738 output_units = files(file_num)%output_units
739 output_fields(ind)%last_output = diag_file_init_time
740 output_fields(ind)%next_output = diag_time_inc(diag_file_init_time, freq, output_units, err_msg=msg)
741 IF ( msg /=
'' )
THEN
743 &
' file='//trim(files(file_num)%name)//
': '//trim(msg),err_msg))
RETURN
745 output_fields(ind)%next_next_output = &
746 & diag_time_inc(output_fields(ind)%next_output, freq, output_units, err_msg=msg)
747 IF ( msg /=
'' )
THEN
749 &
' file='//trim(files(file_num)%name)//
': '//trim(msg),err_msg) )
RETURN
751 IF ( debug_diag_manager .AND.
mpp_pe() == mpp_root_pe() .AND. output_fields(ind)%local_output )
THEN
752 WRITE (msg,
'(" lon(",F5.1,", ",F5.1,"), lat(",F5.1,", ",F5.1,"), dep(",F5.1,", ",F5.1,")")') &
753 & output_fields(ind)%output_grid%start(1),output_fields(ind)%output_grid%end(1),&
754 & output_fields(ind)%output_grid%start(2),output_fields(ind)%output_grid%end(2),&
755 & output_fields(ind)%output_grid%start(3),output_fields(ind)%output_grid%end(3)
756 WRITE(stdout_unit,* )
'module/output_field '//trim(module_name)//
'/'//trim(field_name)// &
757 &
' will be output in region:'//trim(msg)
762 IF ( len_trim(err_msg).GT.0 )
THEN
763 CALL error_mesg (
'diag_manager_mod::register_diag_field',&
764 & trim(err_msg)//
' for module/field '//trim(module_name)//
'/'//trim(field_name),&
775 & missing_value, range, mask_variant, standard_name, DYNAMIC, do_not_log, interp_method,&
776 & tile_count, area, volume, realm)
777 CHARACTER(len=*),
INTENT(in) :: module_name, field_name
778 INTEGER,
DIMENSION(:),
INTENT(in) :: axes
779 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: long_name, units, standard_name
780 CLASS(*),
OPTIONAL,
INTENT(in) :: missing_value
781 CLASS(*),
DIMENSION(:),
OPTIONAL,
INTENT(in) :: range
782 LOGICAL,
OPTIONAL,
INTENT(in) :: mask_variant
783 LOGICAL,
OPTIONAL,
INTENT(in) :: dynamic
784 LOGICAL,
OPTIONAL,
INTENT(in) :: do_not_log
785 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: interp_method
789 INTEGER,
OPTIONAL,
INTENT(in) :: tile_count
790 INTEGER,
OPTIONAL,
INTENT(in) :: area
791 INTEGER,
OPTIONAL,
INTENT(in) :: volume
792 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: realm
794 REAL :: missing_value_use
795 REAL,
DIMENSION(2) :: range_use
796 INTEGER :: field, num_axes, j, out_num, k
797 INTEGER,
DIMENSION(3) :: siz, local_siz, local_start, local_end
798 INTEGER :: tile, file_num
799 LOGICAL :: mask_variant1, dynamic1, allow_log
800 CHARACTER(len=128) :: msg
801 INTEGER :: domain_type, i
802 character(len=256) :: axis_name
805 IF ( .NOT.module_is_initialized )
THEN
807 CALL error_mesg (
'diag_manager_mod::register_static_field_old',
'diag_manager has NOT been initialized', fatal)
811 IF (
PRESENT(missing_value) )
THEN
813 missing_value_use = cmor_missing_value
815 SELECT TYPE (missing_value)
816 TYPE IS (real(kind=r4_kind))
817 missing_value_use = missing_value
818 TYPE IS (real(kind=r8_kind))
819 missing_value_use = real(missing_value)
821 CALL error_mesg (
'diag_manager_mod::register_static_field',&
822 &
'The missing_value is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
827 IF (
PRESENT(mask_variant) )
THEN
828 mask_variant1 = mask_variant
830 mask_variant1 = .false.
833 IF (
PRESENT(dynamic) )
THEN
839 IF (
PRESENT(tile_count) )
THEN
845 IF (
PRESENT(do_not_log) )
THEN
846 allow_log = .NOT.do_not_log
852 IF (
PRESENT(range) )
THEN
853 IF (
SIZE(range) .NE. 2 )
THEN
855 CALL error_mesg (
'diag_manager_mod::register_static_field',
'extent of range should be 2', fatal)
861 IF ( do_diag_field_log.AND.allow_log )
THEN
863 & long_name, units, missing_value=missing_value, range=range, &
873 domain_type = axis_compatible_check(axes,field_name)
876 IF ( .NOT.input_fields(field)%register )
THEN
881 CALL error_mesg (
'diag_manager_mod::register_diag_field',
'module/output_field '//trim(module_name)//
'/'//&
882 & trim(field_name)//
' is not registered for tile_count = 1, should not register for tile_count > 1',&
888 DO j = 1, input_fields(field)%num_output_fields
889 out_num = input_fields(field)%output_fields(j)
890 file_num = output_fields(out_num)%output_file
891 IF(input_fields(field)%local)
THEN
892 CALL init_output_field(module_name, field_name,output_fields(out_num)%output_name,&
893 & files(file_num)%name,output_fields(out_num)%time_method, output_fields(out_num)%pack,&
894 & tile, input_fields(field)%local_coord)
896 CALL init_output_field(module_name, field_name,output_fields(out_num)%output_name,&
897 & files(file_num)%name,output_fields(out_num)%time_method, output_fields(out_num)%pack, tile)
907 input_fields(field)%static = .true.
909 IF ( input_fields(field)%register .AND.
mpp_pe() == mpp_root_pe() )
THEN
914 CALL error_mesg (
'diag_manager_mod::register_diag_field',
'module/output_field '//trim(module_name)//
'/'//&
915 & trim(field_name)//
' ALREADY registered, should not register twice', fatal)
919 IF (
PRESENT(volume).AND.
PRESENT(area) )
THEN
920 IF ( area.EQ.volume )
THEN
921 CALL error_mesg (
'diag_manager_mod::register_static_field_old',
'module/output_field '&
922 &//trim(module_name)//
'/'// trim(field_name)//
' AREA and VOLUME CANNOT be the same variable.&
923 & Contact the developers.',&
929 IF (
PRESENT(area) )
THEN
931 CALL error_mesg (
'diag_manager_mod::register_static_field_old',
'module/output_field '&
932 &//trim(module_name)//
'/'// trim(field_name)//
' AREA measures field NOT found in diag_table.&
933 & Contact the model liaison.n',&
937 IF (
PRESENT(volume) )
THEN
938 IF ( volume < 0 )
THEN
939 CALL error_mesg (
'diag_manager_mod::register_static_field_old',
'module/output_field '&
940 &//trim(module_name)//
'/'// trim(field_name)//
' VOLUME measures field NOT found in diag_table&
941 & Contact the model liaison.',&
947 input_fields(field)%register = .true.
949 input_fields(field)%mask_variant = mask_variant1
951 input_fields(field)%issued_mask_ignore_warning = .false.
954 IF (
PRESENT(long_name) )
THEN
955 input_fields(field)%long_name = trim(long_name)
957 input_fields(field)%long_name = input_fields(field)%field_name
960 IF (
PRESENT(standard_name) ) input_fields(field)%standard_name = standard_name
962 IF (
PRESENT(units) )
THEN
963 input_fields(field)%units = trim(units)
965 input_fields(field)%units =
'none'
968 IF (
PRESENT(missing_value) )
THEN
969 input_fields(field)%missing_value = missing_value_use
970 input_fields(field)%missing_value_present = .true.
972 input_fields(field)%missing_value_present = .false.
975 IF (
PRESENT(range) )
THEN
977 TYPE IS (real(kind=r4_kind))
979 TYPE IS (real(kind=r8_kind))
980 range_use = real(range)
982 CALL error_mesg (
'diag_manager_mod::register_static_field',&
983 &
'The range is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
985 input_fields(field)%range = range_use
987 input_fields(field)%range_present = range_use(2) .gt. range_use(1)
989 input_fields(field)%range = (/ 1., 0. /)
990 input_fields(field)%range_present = .false.
993 IF (
PRESENT(interp_method) )
THEN
994 IF ( trim(interp_method) .NE.
'conserve_order1' .AND.&
995 & trim(interp_method) .NE.
'conserve_order2' .AND.&
996 & trim(interp_method) .NE.
'none' )
THEN
1002 CALL error_mesg (
'diag_manager_mod::register_diag_field',&
1003 &
'when registering module/output_field '//trim(module_name)//
'/'//&
1004 & trim(field_name)//
', the optional argument interp_method = '//trim(interp_method)//&
1005 &
', but it should be "conserve_order1", "conserve_order2", or "none"', fatal)
1007 input_fields(field)%interp_method = trim(interp_method)
1009 input_fields(field)%interp_method =
''
1013 num_axes =
SIZE(axes(:))
1014 input_fields(field)%axes(1:num_axes) = axes
1015 input_fields(field)%num_axes = num_axes
1019 IF ( axes(j) .LE. 0 )
THEN
1023 CALL error_mesg (
'diag_manager_mod::register_diag_field',
'module/output_field '//trim(module_name)//
'/'//&
1024 & trim(field_name)//
' has non-positive axis_id', fatal)
1026 siz(j) = get_axis_length(axes(j))
1031 input_fields(field)%size(j) = siz(j)
1038 DO j = 1, input_fields(field)%num_output_fields
1039 out_num = input_fields(field)%output_fields(j)
1041 IF ( output_fields(out_num)%pack>=4 .AND. .NOT.input_fields(field)%range_present )
THEN
1042 IF(
mpp_pe() .EQ. mpp_root_pe())
THEN
1046 CALL error_mesg (
'diag_manager_mod::register_diag_field ',
'output_field '//trim(field_name)// &
1047 ' has pack >=4, range is REQUIRED in register_diag_field', fatal)
1052 IF ( .NOT.dynamic1 ) output_fields(out_num)%n_diurnal_samples = 1
1056 file_num = output_fields(out_num)%output_file
1057 if (domain_type .eq. diag_axis_2ddomain)
then
1058 if (files(file_num)%use_domainUG)
then
1059 call error_mesg(
"diag_manager_mod::register_static_field_old", &
1060 "Diagnostics living on a structured grid" &
1061 //
" and an unstructured grid cannot exist" &
1062 //
" in the same file (" &
1063 //trim(files(file_num)%name)//
")", &
1065 elseif (.not. files(file_num)%use_domain2D)
then
1066 files(file_num)%use_domain2D = .true.
1069 if (files(file_num)%use_domain2D)
then
1070 call error_mesg(
"diag_manager_mod::register_static_field_old", &
1071 "Diagnostics living on a structured grid" &
1072 //
" and an unstructured grid cannot exist" &
1073 //
" in the same file (" &
1074 //trim(files(file_num)%name)//
")", &
1076 elseif (.not. files(file_num)%use_domainUG)
then
1077 files(file_num)%use_domainUG = .true.
1083 IF ( output_fields(out_num)%reduced_k_range )
THEN
1092 local_start(2) = output_fields(out_num)%output_grid%l_start_indx(2)
1093 local_end(2) = output_fields(out_num)%output_grid%l_end_indx(2)
1094 local_siz(2) = local_end(2) - local_start(2) + 1
1095 allocate(output_fields(out_num)%buffer(siz(1),local_siz(2),siz(3), &
1096 output_fields(out_num)%n_diurnal_samples))
1097 output_fields(out_num)%region_elements = siz(1)*local_siz(2)*siz(3)
1098 output_fields(out_num)%reduced_k_unstruct = .true.
1100 local_start(3) = output_fields(out_num)%output_grid%l_start_indx(3)
1101 local_end(3) = output_fields(out_num)%output_grid%l_end_indx(3)
1102 local_siz(3) = local_end(3) - local_start(3) + 1
1103 allocate(output_fields(out_num)%buffer(siz(1),siz(2),local_siz(3), &
1104 output_fields(out_num)%n_diurnal_samples))
1105 output_fields(out_num)%region_elements = siz(1)*siz(2)*local_siz(3)
1106 output_fields(out_num)%reduced_k_unstruct = .false.
1108 output_fields(out_num)%total_elements = siz(1)*siz(2)*siz(3)
1111 IF ( output_fields(out_num)%time_max )
THEN
1112 output_fields(out_num)%buffer = max_value
1113 ELSE IF ( output_fields(out_num)%time_min )
THEN
1114 output_fields(out_num)%buffer = min_value
1116 output_fields(out_num)%buffer = empty
1118 ELSE IF ( output_fields(out_num)%local_output )
THEN
1119 IF (
SIZE(axes(:)) .LE. 1 )
THEN
1121 CALL error_mesg (
'diag_manager_mod::register_diag_field',
'axes of '//trim(field_name)//&
1122 &
' must >= 2 for local output', fatal)
1125 IF ( output_fields(out_num)%need_compute )
THEN
1127 local_start(k) = output_fields(out_num)%output_grid%l_start_indx(k)
1128 local_end(k) = output_fields(out_num)%output_grid%l_end_indx(k)
1129 local_siz(k) = local_end(k) - local_start(k) +1
1131 ALLOCATE(output_fields(out_num)%buffer(local_siz(1), local_siz(2), local_siz(3),&
1132 & output_fields(out_num)%n_diurnal_samples))
1133 IF(output_fields(out_num)%time_max)
THEN
1134 output_fields(out_num)%buffer = max_value
1135 ELSE IF(output_fields(out_num)%time_min)
THEN
1136 output_fields(out_num)%buffer = min_value
1138 output_fields(out_num)%buffer = empty
1140 output_fields(out_num)%region_elements = local_siz(1)*local_siz(2)*local_siz(3)
1141 output_fields(out_num)%total_elements = siz(1)*siz(2)*siz(3)
1142 files(output_fields(out_num)%output_file)%local = .true.
1146 ALLOCATE(output_fields(out_num)%buffer(siz(1), siz(2), siz(3),&
1147 & output_fields(out_num)%n_diurnal_samples))
1148 IF(output_fields(out_num)%time_max)
THEN
1149 output_fields(out_num)%buffer = max_value
1150 ELSE IF(output_fields(out_num)%time_min)
THEN
1151 output_fields(out_num)%buffer = min_value
1153 output_fields(out_num)%buffer = empty
1155 output_fields(out_num)%total_elements = siz(1)*siz(2)*siz(3)
1159 output_fields(out_num)%static = .true.
1161 IF ( .NOT.dynamic1 .AND. output_fields(out_num)%time_ops )
THEN
1162 WRITE (msg,
'(a,"/",a)') trim(module_name), trim(field_name)
1163 IF (
mpp_pe() .EQ. mpp_root_pe() )
THEN
1170 CALL error_mesg (
'diag_manager_mod::register_static_field_old',&
1171 &
'module/field '//trim(msg)//
' is STATIC. Cannot perform time operations&
1172 & average, maximum, or minimum on static fields. Setting the time operation&
1173 & to "NONE" for this field.', warning)
1175 output_fields(out_num)%time_ops = .false.
1176 output_fields(out_num)%time_average = .false.
1177 output_fields(out_num)%time_method =
'point'
1182 output_fields(out_num)%num_axes = input_fields(field)%num_axes
1184 IF ( .NOT.output_fields(out_num)%local_output )
THEN
1185 output_fields(out_num)%axes(1:input_fields(field)%num_axes) =&
1186 & input_fields(field)%axes(1:input_fields(field)%num_axes)
1188 output_fields(out_num)%axes(1:input_fields(field)%num_axes) =&
1189 & output_fields(out_num)%output_grid%subaxes(1:input_fields(field)%num_axes)
1194 IF ( output_fields(out_num)%n_diurnal_samples > 1 )
THEN
1195 output_fields(out_num)%axes(output_fields(out_num)%num_axes+1) =&
1197 output_fields(out_num)%num_axes = output_fields(out_num)%num_axes+1
1200 IF ( output_fields(out_num)%reduced_k_range )
THEN
1204 output_fields(out_num)%axes(2) = output_fields(out_num)%output_grid%subaxes(2)
1206 output_fields(out_num)%axes(3) = output_fields(out_num)%output_grid%subaxes(3)
1212 output_fields(out_num)%Time_of_prev_field_data = time_zero
1216 IF ( len_trim(msg).GT.0 )
THEN
1217 CALL error_mesg (
'diag_manager_mod::register_static_field_old',&
1218 & trim(msg)//
' for module/field '//trim(module_name)//
'/'//trim(field_name),&
1223 IF (
PRESENT(realm) )
THEN
1224 CALL prepend_attribute(output_fields(out_num),
'modeling_realm', lowercase(trim(realm)))
1228 IF ( input_fields(field)%mask_variant )
THEN
1229 DO j = 1, input_fields(field)%num_output_fields
1230 out_num = input_fields(field)%output_fields(j)
1231 IF(output_fields(out_num)%time_average)
THEN
1237 if (output_fields(out_num)%reduced_k_range .and. &
1239 allocate(output_fields(out_num)%counter(siz(1),local_siz(2),siz(3), &
1240 output_fields(out_num)%n_diurnal_samples))
1242 allocate(output_fields(out_num)%counter(siz(1),siz(2),siz(3), &
1243 output_fields(out_num)%n_diurnal_samples))
1246 output_fields(out_num)%counter = 0.0
1257 CHARACTER(len=*),
INTENT(in) :: module_name
1258 CHARACTER(len=*),
INTENT(in) :: field_name
1263 if (use_modern_diag)
then
1264 get_diag_field_id = fms_diag_object%fms_get_diag_field_id_from_name(module_name, field_name)
1275 INTEGER,
INTENT(in) :: field
1277 INTEGER,
INTENT(out) :: out_field_id
1278 INTEGER,
INTENT(out) :: out_file_id
1280 INTEGER :: i, cm_ind, cm_file_num
1284 rel_file = rel_field%output_file
1292 DO i = 1, input_fields(field)%num_output_fields
1293 cm_ind = input_fields(field)%output_fields(i)
1294 cm_file_num = output_fields(cm_ind)%output_file
1296 IF ( cm_file_num.EQ.rel_file.AND.&
1297 & (( (output_fields(cm_ind)%time_ops.EQV.rel_field%time_ops) .AND.&
1298 & (output_fields(cm_ind)%next_output.EQ.rel_field%next_output) .AND.&
1299 & (output_fields(cm_ind)%last_output.EQ.rel_field%last_output) ).OR.&
1300 & (output_fields(cm_ind)%static.OR.rel_field%static) ) )
THEN
1302 out_field_id = cm_ind
1303 out_file_id = cm_file_num
1310 DO i = 1, input_fields(field)%num_output_fields
1311 cm_ind = input_fields(field)%output_fields(i)
1312 cm_file_num = output_fields(cm_ind)%output_file
1323 IF ( output_fields(cm_ind)%static.OR.rel_field%static )
THEN
1325 out_field_id = cm_ind
1326 out_file_id = cm_file_num
1336 INTEGER,
INTENT(in),
OPTIONAL :: area
1337 INTEGER,
INTENT(in),
OPTIONAL :: volume
1338 CHARACTER(len=*),
INTENT(out),
OPTIONAL :: err_msg
1340 INTEGER :: cm_ind, cm_file_num, file_num
1342 IF (
PRESENT(err_msg) )
THEN
1347 IF (
PRESENT(area) )
THEN
1348 IF ( area.LE.0 )
THEN
1350 &
'AREA field not in diag_table for field '//trim(input_fields(output_field%input_field)%module_name)//&
1351 &
'/'//trim(input_fields(output_field%input_field)%field_name), err_msg) )
RETURN
1355 IF (
PRESENT(volume) )
THEN
1356 IF ( volume.LE.0 )
THEN
1358 &
'VOLUME field not in diag_table for field '//trim(input_fields(output_field%input_field)%module_name)//&
1359 &
'/'//trim(input_fields(output_field%input_field)%field_name), err_msg) )
RETURN
1364 file_num = output_field%output_file
1367 IF (
PRESENT(area) )
THEN
1370 &
'area: '//trim(output_fields(cm_ind)%output_name))
1371 IF ( cm_file_num.NE.file_num )
THEN
1377 &
'AREA measures field "'//trim(input_fields(area)%module_name)//
'/'//&
1378 & trim(input_fields(area)%field_name)//&
1379 &
'" NOT in diag_table with correct output frequency for field '//&
1380 & trim(input_fields(output_field%input_field)%module_name)//&
1381 &
'/'//trim(input_fields(output_field%input_field)%field_name), err_msg) )
RETURN
1386 IF (
PRESENT(volume) )
THEN
1389 &
'volume: '//trim(output_fields(cm_ind)%output_name))
1390 IF ( cm_file_num.NE.file_num )
THEN
1396 &
'VOLUME measures field "'//trim(input_fields(volume)%module_name)//
'/'//&
1397 & trim(input_fields(volume)%field_name)//&
1398 &
'" NOT in diag_table with correct output frequency for field '//&
1399 & trim(input_fields(output_field%input_field)%module_name)//&
1400 &
'/'//trim(input_fields(output_field%input_field)%field_name), err_msg) )
RETURN
1411 INTEGER,
intent(in) :: file_num
1412 INTEGER,
intent(in) :: cm_file_num
1413 INTEGER,
intent(in) :: cm_ind
1415 INTEGER :: year, month, day, hour, minute, second
1417 CHARACTER(len=25) :: date_prefix
1418 CHARACTER(len=FMS_FILE_LEN) :: asso_file_name
1421 IF ( prepend_date )
THEN
1422 CALL get_date(diag_init_time, year, month, day, hour, minute, second)
1423 WRITE (date_prefix,
'(1I20.4, 2I2.2,".")') year, month, day
1424 date_prefix=adjustl(date_prefix)
1432 IF ( len_trim(files(cm_file_num)%name)+17 > len(asso_file_name) )
THEN
1433 CALL error_mesg (
'diag_manager_mod::add_associated_files',&
1434 &
'Length of asso_file_name is not long enough to hold the associated file name. '&
1435 & //
'Contact the developer', fatal)
1437 asso_file_name = trim(files(cm_file_num)%name)
1448 n = max(len_trim(asso_file_name),3)
1449 if (asso_file_name(n-2:n).NE.
'.nc') asso_file_name = trim(asso_file_name)//
'.nc'
1453 & trim(output_fields(cm_ind)%output_name)//
': '//&
1454 & trim(date_prefix)//trim(asso_file_name))
1459 INTEGER,
INTENT(in) :: diag_field_id
1460 CLASS(*),
INTENT(in) :: field
1461 TYPE(
time_type),
INTENT(in),
OPTIONAL :: time
1462 CHARACTER(len=*),
INTENT(out),
OPTIONAL :: err_msg
1464 CLASS(*),
allocatable :: field_out(:, :, :)
1467 IF ( diag_field_id <= 0 )
THEN
1474 TYPE IS (real(kind=r4_kind))
1475 allocate(real(r4_kind) :: field_out(1,1,1))
1476 select type(field_out)
1477 type is (real(r4_kind))
1478 field_out(1, 1, 1) = field
1480 call error_mesg(
'diag_manager_mod::send_data_0d', &
1481 &
'Error allocating field out as real(r4_kind)', fatal)
1483 TYPE IS (real(kind=r8_kind))
1484 allocate(real(r8_kind) :: field_out(1,1,1))
1485 select type(field_out)
1486 type is (real(r8_kind))
1487 field_out(1, 1, 1) = field
1489 call error_mesg(
'diag_manager_mod::send_data_0d', &
1490 &
'Error allocating field out as real(r8_kind)', fatal)
1493 CALL error_mesg (
'diag_manager_mod::send_data_0d',&
1494 &
'The field is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
1501 LOGICAL FUNCTION send_data_1d(diag_field_id, field, time, is_in, mask, rmask, ie_in, weight, err_msg)
1502 INTEGER,
INTENT(in) :: diag_field_id
1503 CLASS(*),
DIMENSION(:),
INTENT(in) :: field
1504 CLASS(*),
INTENT(in),
OPTIONAL :: weight
1505 CLASS(*),
INTENT(in),
DIMENSION(:),
OPTIONAL :: rmask
1506 TYPE (
time_type),
INTENT(in),
OPTIONAL :: time
1507 INTEGER,
INTENT(in),
OPTIONAL :: is_in, ie_in
1508 LOGICAL,
INTENT(in),
DIMENSION(:),
OPTIONAL :: mask
1509 CHARACTER(len=*),
INTENT(out),
OPTIONAL :: err_msg
1511 CLASS(*),
ALLOCATABLE :: field_out(:,:,:)
1512 LOGICAL,
DIMENSION(SIZE(field(:)), 1, 1) :: mask_out
1515 IF ( diag_field_id <= 0 )
THEN
1523 TYPE IS (real(kind=r4_kind))
1524 allocate(real(r4_kind) :: field_out(
SIZE(field),1,1))
1525 select type(field_out)
1526 type is (real(r4_kind))
1527 field_out(:, 1, 1) = field
1529 call error_mesg(
'diag_manager_mod::send_data_1d', &
1530 &
'Error allocating field out as real(r4_kind)', fatal)
1532 TYPE IS (real(kind=r8_kind))
1533 allocate(real(r8_kind) :: field_out(
SIZE(field),1,1))
1534 select type(field_out)
1535 type is (real(r8_kind))
1536 field_out(:, 1, 1) = field
1538 call error_mesg(
'diag_manager_mod::send_data_1d', &
1539 &
'Error allocating field out as real(r8_kind)', fatal)
1542 CALL error_mesg (
'diag_manager_mod::send_data_1d',&
1543 &
'The field is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
1547 IF (
PRESENT(mask) )
THEN
1548 mask_out(:, 1, 1) = mask
1553 IF (
PRESENT(rmask) )
THEN
1555 TYPE IS (real(kind=r4_kind))
1556 WHERE (rmask < 0.5_r4_kind) mask_out(:, 1, 1) = .false.
1557 TYPE IS (real(kind=r8_kind))
1558 WHERE (rmask < 0.5_r8_kind) mask_out(:, 1, 1) = .false.
1560 CALL error_mesg (
'diag_manager_mod::send_data_1d',&
1561 &
'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
1565 IF (
PRESENT(mask) .OR.
PRESENT(rmask) )
THEN
1566 IF (
PRESENT(is_in) .OR.
PRESENT(ie_in) )
THEN
1568 & mask=mask_out, ie_in=ie_in, je_in=1, ke_in=1, weight=weight, err_msg=err_msg)
1571 & weight=weight, err_msg=err_msg)
1574 IF (
PRESENT(is_in) .OR.
PRESENT(ie_in) )
THEN
1576 & ie_in=ie_in, je_in=1, ke_in=1, weight=weight, err_msg=err_msg)
1585 & mask, rmask, ie_in, je_in, weight, err_msg)
1586 INTEGER,
INTENT(in) :: diag_field_id
1587 CLASS(*),
INTENT(in),
DIMENSION(:,:) :: field
1588 CLASS(*),
INTENT(in),
OPTIONAL :: weight
1589 TYPE (
time_type),
INTENT(in),
OPTIONAL :: time
1590 INTEGER,
INTENT(in),
OPTIONAL :: is_in, js_in, ie_in, je_in
1591 LOGICAL,
INTENT(in),
DIMENSION(:,:),
OPTIONAL :: mask
1592 CLASS(*),
INTENT(in),
DIMENSION(:,:),
OPTIONAL :: rmask
1593 CHARACTER(len=*),
INTENT(out),
OPTIONAL :: err_msg
1595 CLASS(*),
ALLOCATABLE :: field_out(:,:,:)
1596 LOGICAL,
DIMENSION(SIZE(field,1),SIZE(field,2),1) :: mask_out
1599 IF ( diag_field_id <= 0 )
THEN
1606 TYPE IS (real(kind=r4_kind))
1607 allocate(real(r4_kind) :: field_out(
SIZE(field,1),
SIZE(field,2),1))
1608 select type(field_out)
1609 type is (real(r4_kind))
1610 field_out(:, :, 1) = field
1612 call error_mesg(
'diag_manager_mod::send_data_2d', &
1613 &
'Error allocating field out as real(r4_kind)', fatal)
1615 TYPE IS (real(kind=r8_kind))
1616 allocate(real(r8_kind) :: field_out(
SIZE(field,1),
SIZE(field,2),1))
1617 select type(field_out)
1618 type is (real(r8_kind))
1619 field_out(:, :, 1) = field
1621 call error_mesg(
'diag_manager_mod::send_data_2d', &
1622 &
'Error allocating field out as real(r8_kind)', fatal)
1625 CALL error_mesg (
'diag_manager_mod::send_data_2d',&
1626 &
'The field is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
1630 IF (
PRESENT(mask) )
THEN
1631 mask_out(:, :, 1) = mask
1636 IF (
PRESENT(rmask) )
THEN
1638 TYPE IS (real(kind=r4_kind))
1639 WHERE ( rmask < 0.5_r4_kind ) mask_out(:, :, 1) = .false.
1640 TYPE IS (real(kind=r8_kind))
1641 WHERE ( rmask < 0.5_r8_kind ) mask_out(:, :, 1) = .false.
1643 CALL error_mesg (
'diag_manager_mod::send_data_2d',&
1644 &
'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
1648 IF (
PRESENT(mask) .OR.
PRESENT(rmask) )
THEN
1650 & mask=mask_out, ie_in=ie_in, je_in=je_in, ke_in=1, weight=weight, err_msg=err_msg)
1653 & ie_in=ie_in, je_in=je_in, ke_in=1, weight=weight, err_msg=err_msg)
1658 LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
1659 & mask, rmask, ie_in, je_in, ke_in, weight, err_msg)
1660 INTEGER,
INTENT(in) :: diag_field_id
1661 CLASS(*),
DIMENSION(:,:,:),
INTENT(in) :: field
1662 CLASS(*),
INTENT(in),
OPTIONAL :: weight
1663 TYPE (
time_type),
INTENT(in),
OPTIONAL :: time
1664 INTEGER,
INTENT(in),
OPTIONAL :: is_in, js_in, ks_in,ie_in,je_in, ke_in
1665 LOGICAL,
DIMENSION(:,:,:),
INTENT(in),
OPTIONAL :: mask
1666 CLASS(*),
DIMENSION(:,:,:),
INTENT(in),
OPTIONAL :: rmask
1667 CHARACTER(len=*),
INTENT(out),
OPTIONAL :: err_msg
1669 if (
present(mask) .and.
present(rmask))
then
1671 mask=mask, rmask=rmask, ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, &
1673 elseif (
present(rmask))
then
1675 rmask=rmask, ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, err_msg=err_msg)
1676 elseif (
present(mask))
then
1678 mask=mask, ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, err_msg=err_msg)
1681 ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, err_msg=err_msg)
1688 & mask, rmask, ie_in, je_in, ke_in, weight, err_msg)
1689 INTEGER,
INTENT(in) :: diag_field_id
1690 CLASS(*),
DIMENSION(:,:,:),
INTENT(in),
TARGET,
CONTIGUOUS :: field
1691 CLASS(*),
INTENT(in),
OPTIONAL :: weight
1692 TYPE (
time_type),
INTENT(in),
OPTIONAL :: time
1693 INTEGER,
INTENT(in),
OPTIONAL :: is_in, js_in, ks_in,ie_in,je_in, ke_in
1694 LOGICAL,
DIMENSION(:,:,:),
INTENT(in),
OPTIONAL,
contiguous,
target :: mask
1695 CLASS(*),
DIMENSION(:,:,:),
INTENT(in),
OPTIONAL,
contiguous,
target :: rmask
1696 CHARACTER(len=*),
INTENT(out),
OPTIONAL :: err_msg
1700 INTEGER :: pow_value
1702 INTEGER :: i, out_num, file_num, n1, n2, n3, number_of_outputs, ii,f1,f2,f3,f4
1703 INTEGER :: freq, units, is, js, ks, ie, je, ke, i1, j1,k1, j, k
1704 INTEGER,
DIMENSION(3) :: l_start
1705 INTEGER,
DIMENSION(3) :: l_end
1715 INTEGER :: numthreads
1716 INTEGER :: active_omp_level
1717 #if defined(_OPENMP)
1718 INTEGER :: omp_get_num_threads
1719 INTEGER :: omp_get_level
1721 LOGICAL :: average, phys_window, need_compute
1722 LOGICAL :: reduced_k_range, local_output
1723 LOGICAL :: time_max, time_min, time_rms, time_sum
1724 LOGICAL :: missvalue_present
1725 LOGICAL,
ALLOCATABLE,
DIMENSION(:,:,:) :: oor_mask
1726 CHARACTER(len=256) :: err_msg_local
1727 CHARACTER(len=128) :: error_string, error_string1
1729 REAL,
ALLOCATABLE,
DIMENSION(:,:,:) :: field_out
1730 class(*),
allocatable,
dimension(:,:,:,:) :: field_remap
1731 logical,
allocatable,
dimension(:,:,:,:) :: mask_remap
1732 class(*),
allocatable,
dimension(:,:,:,:) :: rmask_remap
1733 REAL(kind=r4_kind),
POINTER,
DIMENSION(:,:,:) :: rmask_ptr_r4
1734 REAL(kind=r8_kind),
POINTER,
DIMENSION(:,:,:) :: rmask_ptr_r8
1738 LOGICAL :: mf_result
1740 REAL :: rmask_threshold
1742 character(len=:),
allocatable :: field_name
1745 IF ( diag_field_id <= 0 )
THEN
1752 IF (
PRESENT(err_msg) ) err_msg =
''
1753 IF ( .NOT.module_is_initialized )
THEN
1754 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d',
'diag_manager NOT initialized', err_msg) )
RETURN
1767 ALLOCATE(field_out(
SIZE(field,1),
SIZE(field,2),
SIZE(field,3)), stat=status)
1768 IF ( status .NE. 0 )
THEN
1769 WRITE (err_msg_local, fmt=
'("Unable to allocate field_out(",I5,",",I5,",",I5,"). (STAT: ",I5,")")')&
1770 &
SIZE(field,1),
SIZE(field,2),
SIZE(field,3), status
1771 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
RETURN
1774 TYPE IS (real(kind=r4_kind))
1776 TYPE IS (real(kind=r8_kind))
1777 field_out = real(field)
1779 CALL error_mesg (
'diag_manager_mod::send_data_3d',&
1780 &
'The field is not one of the supported types (real(kind=4) or real(kind=8)). '//&
1781 &
'If using an integer, please set use_modern_diag=.t. in the diag_manager_nml.', fatal)
1784 modern_if:
iF (use_modern_diag)
then
1785 field_name = fms_diag_object%fms_get_field_name_from_id(diag_field_id)
1786 call copy_3d_to_4d(field, field_remap, trim(field_name)//
"'s data")
1787 if (
present(rmask))
call copy_3d_to_4d(rmask, rmask_remap, trim(field_name)//
"'s mask")
1788 if (
present(mask))
then
1789 allocate(mask_remap(1:
size(mask,1), 1:
size(mask,2), 1:
size(mask,3), 1))
1790 mask_remap(:,:,:,1) = mask
1792 diag_send_data = fms_diag_object%fms_diag_accept_data(diag_field_id, field_remap, mask_remap, rmask_remap, &
1793 time, is_in, js_in, ks_in, ie_in, je_in, ke_in, weight, &
1795 deallocate (field_remap)
1796 if (
allocated(mask_remap))
deallocate(mask_remap)
1797 if (
allocated(rmask_remap))
deallocate(rmask_remap)
1800 ALLOCATE(oor_mask(
SIZE(field,1),
SIZE(field,2),
SIZE(field,3)), stat=status)
1801 IF ( status .NE. 0 )
THEN
1802 WRITE (err_msg_local, fmt=
'("Unable to allocate oor_mask(",I5,",",I5,",",I5,"). (STAT: ",I5,")")')&
1803 &
SIZE(field,1),
SIZE(field,2),
SIZE(field,3), status
1804 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
RETURN
1807 IF (
PRESENT(mask) )
THEN
1813 rmask_ptr_r4 => null()
1814 rmask_ptr_r8 => null()
1815 IF (
PRESENT(rmask) )
THEN
1817 TYPE IS (real(kind=r4_kind))
1818 WHERE ( rmask < 0.5_r4_kind ) oor_mask = .false.
1819 rmask_threshold = 0.5_r4_kind
1820 rmask_ptr_r4 => rmask
1821 TYPE IS (real(kind=r8_kind))
1822 WHERE ( rmask < 0.5_r8_kind ) oor_mask = .false.
1823 rmask_threshold = 0.5_r8_kind
1824 rmask_ptr_r8 => rmask
1826 CALL error_mesg (
'diag_manager_mod::send_data_3d',&
1827 &
'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
1842 IF (
PRESENT(ie_in) )
THEN
1843 IF ( .NOT.
PRESENT(is_in) )
THEN
1844 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d',
'ie_in present without is_in', err_msg) )
THEN
1845 DEALLOCATE(field_out)
1846 DEALLOCATE(oor_mask)
1850 IF (
PRESENT(js_in) .AND. .NOT.
PRESENT(je_in) )
THEN
1852 &
'is_in and ie_in present, but js_in present without je_in', err_msg) )
THEN
1853 DEALLOCATE(field_out)
1854 DEALLOCATE(oor_mask)
1859 IF (
PRESENT(je_in) )
THEN
1860 IF ( .NOT.
PRESENT(js_in) )
THEN
1861 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d',
'je_in present without js_in', err_msg) )
THEN
1862 DEALLOCATE(field_out)
1863 DEALLOCATE(oor_mask)
1867 IF (
PRESENT(is_in) .AND. .NOT.
PRESENT(ie_in) )
THEN
1869 &
'js_in and je_in present, but is_in present without ie_in', err_msg))
THEN
1870 DEALLOCATE(field_out)
1871 DEALLOCATE(oor_mask)
1881 IF (
PRESENT(is_in) ) is = is_in
1882 IF (
PRESENT(js_in) ) js = js_in
1883 IF (
PRESENT(ks_in) ) ks = ks_in
1890 IF (
PRESENT(ie_in) ) ie = ie_in
1891 IF (
PRESENT(je_in) ) je = je_in
1892 IF (
PRESENT(ke_in) ) ke = ke_in
1893 twohi = n1-(ie-is+1)
1894 IF ( mod(twohi,2) /= 0 )
THEN
1895 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d',
'non-symmetric halos in first dimension', &
1897 DEALLOCATE(field_out)
1898 DEALLOCATE(oor_mask)
1902 twohj = n2-(je-js+1)
1903 IF ( mod(twohj,2) /= 0 )
THEN
1904 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d',
'non-symmetric halos in second dimension', &
1906 DEALLOCATE(field_out)
1907 DEALLOCATE(oor_mask)
1916 IF (
PRESENT(ie_in) .AND.
PRESENT(je_in) )
THEN
1930 IF (
PRESENT(weight) )
THEN
1931 SELECT TYPE (weight)
1932 TYPE IS (real(kind=r4_kind))
1934 TYPE IS (real(kind=r8_kind))
1935 weight1 = real(weight)
1937 CALL error_mesg (
'diag_manager_mod::send_data_3d',&
1938 &
'The weight is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
1945 missvalue_present = input_fields(diag_field_id)%missing_value_present
1946 IF ( missvalue_present ) missvalue = input_fields(diag_field_id)%missing_value
1948 number_of_outputs = input_fields(diag_field_id)%num_output_fields
1950 input_fields(diag_field_id)%numthreads = 1
1952 #if defined(_OPENMP)
1953 input_fields(diag_field_id)%numthreads = omp_get_num_threads()
1954 input_fields(diag_field_id)%active_omp_level = omp_get_level()
1956 numthreads = input_fields(diag_field_id)%numthreads
1957 active_omp_level = input_fields(diag_field_id)%active_omp_level
1960 if(
present(time)) input_fields(diag_field_id)%time = time
1963 IF ( input_fields(diag_field_id)%range_present )
THEN
1964 IF ( issue_oor_warnings .OR. oor_warnings_fatal )
THEN
1965 WRITE (error_string,
'("[",ES14.5E3,",",ES14.5E3,"]")')&
1966 & input_fields(diag_field_id)%range(1:2)
1967 WRITE (error_string1,
'("(Min: ",ES14.5E3,", Max: ",ES14.5E3, ")")')&
1968 & minval(field_out(f1:f2,f3:f4,ks:ke),mask=oor_mask(f1:f2,f3:f4,ks:ke)),&
1969 & maxval(field_out(f1:f2,f3:f4,ks:ke),mask=oor_mask(f1:f2,f3:f4,ks:ke))
1970 IF ( missvalue_present )
THEN
1971 IF ( any(oor_mask(f1:f2,f3:f4,ks:ke) .AND.&
1972 & ((field_out(f1:f2,f3:f4,ks:ke) < input_fields(diag_field_id)%range(1) .OR.&
1973 & field_out(f1:f2,f3:f4,ks:ke) > input_fields(diag_field_id)%range(2)).AND.&
1974 & field_out(f1:f2,f3:f4,ks:ke) .NE. missvalue)) )
THEN
1980 CALL error_mesg(
'diag_manager_mod::send_data_3d',&
1982 &trim(input_fields(diag_field_id)%module_name)//
' in field '//&
1983 &trim(input_fields(diag_field_id)%field_name)//
' '&
1984 &//trim(error_string1)//&
1985 &
' is outside the range '//trim(error_string)//
',&
1986 & and not equal to the missing value.',&
1990 IF ( any(oor_mask(f1:f2,f3:f4,ks:ke) .AND.&
1991 & (field_out(f1:f2,f3:f4,ks:ke) < input_fields(diag_field_id)%range(1) .OR.&
1992 & field_out(f1:f2,f3:f4,ks:ke) > input_fields(diag_field_id)%range(2))) )
THEN
1997 CALL error_mesg(
'diag_manager_mod::send_data_3d',&
1999 &trim(input_fields(diag_field_id)%module_name)//
' in field '//&
2000 &trim(input_fields(diag_field_id)%field_name)//
' '&
2001 &//trim(error_string1)//&
2002 &
' is outside the range '//trim(error_string)//
'.',&
2010 num_out_fields:
DO ii = 1, number_of_outputs
2012 out_num = input_fields(diag_field_id)%output_fields(ii)
2015 local_output = output_fields(out_num)%local_output
2017 need_compute = output_fields(out_num)%need_compute
2019 reduced_k_range = output_fields(out_num)%reduced_k_range
2022 IF ( local_output .AND. (.NOT.need_compute) ) cycle
2025 file_num = output_fields(out_num)%output_file
2026 IF(file_num == max_files) cycle
2028 freq = files(file_num)%output_freq
2029 units = files(file_num)%output_units
2031 average = output_fields(out_num)%time_average
2034 time_rms = output_fields(out_num)%time_rms
2036 pow_value = output_fields(out_num)%pow_value
2038 time_max = output_fields(out_num)%time_max
2039 time_min = output_fields(out_num)%time_min
2041 time_sum = output_fields(out_num)%time_sum
2042 IF ( output_fields(out_num)%total_elements >
SIZE(field_out(f1:f2,f3:f4,ks:ke)) )
THEN
2043 output_fields(out_num)%phys_window = .true.
2045 output_fields(out_num)%phys_window = .false.
2047 phys_window = output_fields(out_num)%phys_window
2048 IF ( need_compute )
THEN
2049 l_start = output_fields(out_num)%output_grid%l_start_indx
2050 l_end = output_fields(out_num)%output_grid%l_end_indx
2055 IF (
PRESENT(time) )
THEN
2056 CALL get_time(time,second,day,tick)
2058 & * output_fields(out_num)%n_diurnal_samples/seconds_per_day) + 1
2062 IF ( reduced_k_range )
THEN
2065 if (output_fields(out_num)%reduced_k_unstruct)
then
2066 js = output_fields(out_num)%output_grid%l_start_indx(2)
2067 je = output_fields(out_num)%output_grid%l_end_indx(2)
2069 l_start(3) = output_fields(out_num)%output_grid%l_start_indx(3)
2070 l_end(3) = output_fields(out_num)%output_grid%l_end_indx(3)
2077 IF ( freq == every_time .AND. .NOT.output_fields(out_num)%static )
THEN
2078 IF (output_fields(out_num)%next_output == output_fields(out_num)%last_output)
THEN
2079 IF(
PRESENT(time))
THEN
2080 output_fields(out_num)%next_output = time
2082 WRITE (error_string,
'(a,"/",a)')&
2083 & trim(input_fields(diag_field_id)%module_name),&
2084 & trim(output_fields(out_num)%output_name)
2085 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d',
'module/output_field '//trim(error_string)//&
2086 &
', time must be present when output frequency = EVERY_TIME', err_msg))
THEN
2087 DEALLOCATE(field_out)
2088 DEALLOCATE(oor_mask)
2094 IF ( .NOT.output_fields(out_num)%static .AND. .NOT.
PRESENT(time) )
THEN
2095 WRITE (error_string,
'(a,"/",a)')&
2096 & trim(input_fields(diag_field_id)%module_name), &
2097 & trim(output_fields(out_num)%output_name)
2098 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d',
'module/output_field '//trim(error_string)//&
2099 &
', time must be present for nonstatic field', err_msg))
THEN
2100 DEALLOCATE(field_out)
2101 DEALLOCATE(oor_mask)
2109 IF ( (numthreads == 1) .AND. (active_omp_level.LE.1) )
then
2110 IF ( .NOT.output_fields(out_num)%static .AND. freq /= end_of_run )
THEN
2111 IF ( time > output_fields(out_num)%next_output )
THEN
2113 IF ( time > output_fields(out_num)%next_next_output .AND. freq > 0 )
THEN
2114 IF (
mpp_pe() .EQ. mpp_root_pe() )
THEN
2115 WRITE (error_string,
'(a,"/",a)')&
2116 & trim(input_fields(diag_field_id)%module_name), &
2117 & trim(output_fields(out_num)%output_name)
2118 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d',
'module/output_field '//&
2119 & trim(error_string)//
' is skipped one time level in output data', err_msg))
THEN
2120 DEALLOCATE(field_out)
2121 DEALLOCATE(oor_mask)
2127 status =
writing_field(out_num, .false., error_string, time)
2128 IF(status == -1)
THEN
2129 IF (
mpp_pe() .EQ. mpp_root_pe() )
THEN
2130 IF(
fms_error_handler(
'diag_manager_mod::send_data_3d',
'module/output_field '//trim(error_string)&
2131 & //
', write EMPTY buffer', err_msg))
THEN
2132 DEALLOCATE(field_out)
2133 DEALLOCATE(oor_mask)
2143 if (
present(time))
then
2145 if (output_fields(out_num)%last_output > time) cycle
2148 IF ( .NOT.output_fields(out_num)%static .AND. .NOT.need_compute .AND. debug_diag_manager )
THEN
2150 IF ( err_msg_local /=
'' )
THEN
2151 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
2152 DEALLOCATE(field_out)
2153 DEALLOCATE(oor_mask)
2159 IF (use_refactored_send)
THEN
2160 ALLOCATE( ofield_index_cfg )
2161 CALL ofield_index_cfg%initialize( is, js, ks, ie, je, ke, &
2162 & hi, hj, f1, f2, f3, f4)
2164 ALLOCATE( ofield_cfg )
2165 CALL ofield_cfg%initialize( input_fields(diag_field_id), output_fields(out_num),
PRESENT(mask), freq)
2169 mf_result =
fieldbuff_update(ofield_cfg, ofield_index_cfg, field_out, sample, &
2170 & output_fields(out_num)%buffer, output_fields(out_num)%counter ,output_fields(out_num)%buff_bounds,&
2171 & output_fields(out_num)%count_0d(sample), output_fields(out_num)%num_elements(sample), &
2172 & mask, weight1 ,missvalue, &
2173 & input_fields(diag_field_id)%numthreads, input_fields(diag_field_id)%active_omp_level,&
2174 & input_fields(diag_field_id)%issued_mask_ignore_warning, &
2175 & l_start, l_end, err_msg, err_msg_local )
2176 IF (mf_result .eqv. .false.)
THEN
2177 DEALLOCATE(ofield_index_cfg)
2178 DEALLOCATE(ofield_cfg)
2179 DEALLOCATE(field_out)
2180 DEALLOCATE(oor_mask)
2185 & output_fields(out_num)%buffer, output_fields(out_num)%buff_bounds , &
2186 & output_fields(out_num)%count_0d(sample), &
2187 & mask, missvalue, l_start, l_end, err_msg, err_msg_local)
2188 IF (mf_result .eqv. .false.)
THEN
2189 DEALLOCATE(ofield_index_cfg)
2190 DEALLOCATE(ofield_cfg)
2191 DEALLOCATE(field_out)
2192 DEALLOCATE(oor_mask)
2197 IF ( output_fields(out_num)%static .AND. .NOT.need_compute .AND. debug_diag_manager )
THEN
2199 IF ( err_msg_local /=
'' )
THEN
2200 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg))
THEN
2201 DEALLOCATE(field_out)
2202 DEALLOCATE(oor_mask)
2229 IF(
ALLOCATED(ofield_index_cfg))
THEN
2230 DEALLOCATE(ofield_index_cfg)
2232 IF(
ALLOCATED(ofield_cfg))
THEN
2233 DEALLOCATE(ofield_cfg)
2240 IF ( input_fields(diag_field_id)%mask_variant )
THEN
2241 IF ( need_compute )
THEN
2242 WRITE (error_string,
'(a,"/",a)') &
2243 & trim(input_fields(diag_field_id)%module_name), &
2244 & trim(output_fields(out_num)%output_name)
2245 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d',
'module/output_field '//trim(error_string)//&
2246 &
', regional output NOT supported with mask_variant', err_msg))
THEN
2247 DEALLOCATE(field_out)
2248 DEALLOCATE(oor_mask)
2255 IF (
PRESENT(mask) )
THEN
2256 IF ( missvalue_present )
THEN
2257 IF ( debug_diag_manager )
THEN
2258 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
2260 IF ( err_msg_local /=
'' )
THEN
2261 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
2262 DEALLOCATE(field_out)
2263 DEALLOCATE(oor_mask)
2268 IF( numthreads>1 .AND. phys_window )
then
2269 IF ( reduced_k_range )
THEN
2274 IF ( mask(i-is+1+hi, j-js+1+hj, k) )
THEN
2275 IF ( pow_value /= 1 )
THEN
2276 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2277 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2278 & (field_out(i-is+1+hi, j-js+1+hj, k) * weight1)**(pow_value)
2280 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2281 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2282 & field_out(i-is+1+hi, j-js+1+hj, k) * weight1
2284 output_fields(out_num)%counter(i-hi,j-hj,k1,sample) =&
2285 & output_fields(out_num)%counter(i-hi,j-hj,k1,sample) + weight1
2294 IF ( mask(i-is+1+hi, j-js+1+hj, k) )
THEN
2295 IF ( pow_value /= 1 )
THEN
2296 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2297 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2298 & (field_out(i-is+1+hi,j-js+1+hj,k)*weight1)**(pow_value)
2300 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2301 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2302 & field_out(i-is+1+hi,j-js+1+hj,k)*weight1
2304 output_fields(out_num)%counter(i-hi,j-hj,k,sample) =&
2305 &output_fields(out_num)%counter(i-hi,j-hj,k,sample) + weight1
2313 IF ( reduced_k_range )
THEN
2318 IF ( mask(i-is+1+hi, j-js+1+hj, k) )
THEN
2319 IF ( pow_value /= 1 )
THEN
2320 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2321 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2322 & (field_out(i-is+1+hi, j-js+1+hj, k) * weight1)**(pow_value)
2324 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2325 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2326 & field_out(i-is+1+hi, j-js+1+hj, k) * weight1
2328 output_fields(out_num)%counter(i-hi,j-hj,k1,sample) =&
2329 & output_fields(out_num)%counter(i-hi,j-hj,k1,sample) + weight1
2338 IF ( mask(i-is+1+hi, j-js+1+hj, k) )
THEN
2339 IF ( pow_value /= 1 )
THEN
2340 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2341 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2342 & (field_out(i-is+1+hi,j-js+1+hj,k)*weight1)**(pow_value)
2344 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2345 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2346 & field_out(i-is+1+hi,j-js+1+hj,k)*weight1
2348 output_fields(out_num)%counter(i-hi,j-hj,k,sample) =&
2349 &output_fields(out_num)%counter(i-hi,j-hj,k,sample) + weight1
2358 WRITE (error_string,
'(a,"/",a)')&
2359 & trim(input_fields(diag_field_id)%module_name), &
2360 & trim(output_fields(out_num)%output_name)
2361 IF(
fms_error_handler(
'diag_manager_mod::send_data_3d',
'module/output_field '//trim(error_string)//&
2362 &
', variable mask but no missing value defined', err_msg))
THEN
2363 DEALLOCATE(field_out)
2364 DEALLOCATE(oor_mask)
2369 WRITE (error_string,
'(a,"/",a)')&
2370 & trim(input_fields(diag_field_id)%module_name), &
2371 & trim(output_fields(out_num)%output_name)
2372 IF(
fms_error_handler(
'diag_manager_mod::send_data_3d',
'module/output_field '//trim(error_string)//&
2373 &
', variable mask but no mask given', err_msg))
THEN
2374 DEALLOCATE(field_out)
2375 DEALLOCATE(oor_mask)
2380 IF (
PRESENT(mask) )
THEN
2381 IF ( missvalue_present )
THEN
2382 IF ( need_compute )
THEN
2383 IF (numthreads>1 .AND. phys_window)
then
2384 DO k = l_start(3), l_end(3)
2388 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2389 & j <= l_end(2)+hj )
THEN
2390 i1 = i-l_start(1)-hi+1
2391 j1= j-l_start(2)-hj+1
2392 IF ( mask(i-is+1+hi, j-js+1+hj, k) )
THEN
2393 IF ( pow_value /= 1 )
THEN
2394 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2395 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2396 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2398 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2399 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2400 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2403 output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
2411 DO k = l_start(3), l_end(3)
2415 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2416 & j <= l_end(2)+hj )
THEN
2417 i1 = i-l_start(1)-hi+1
2418 j1= j-l_start(2)-hj+1
2419 IF ( mask(i-is+1+hi, j-js+1+hj, k) )
THEN
2420 IF ( pow_value /= 1 )
THEN
2421 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2422 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2423 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2425 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2426 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2427 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2430 output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
2441 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2442 & j <= l_end(2)+hj )
THEN
2443 output_fields(out_num)%num_elements(sample) = &
2444 output_fields(out_num)%num_elements(sample) + l_end(3) - l_start(3) + 1
2449 ELSE IF ( reduced_k_range )
THEN
2450 IF (numthreads>1 .AND. phys_window)
then
2455 IF ( mask(i-is+1+hi,j-js+1+hj,k) )
THEN
2456 IF ( pow_value /= 1 )
THEN
2457 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2458 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2459 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2461 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2462 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2463 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2466 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue
2477 IF ( mask(i-is+1+hi,j-js+1+hj,k) )
THEN
2478 IF ( pow_value /= 1 )
THEN
2479 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2480 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2481 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2483 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2484 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2485 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2488 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue
2496 IF ( debug_diag_manager )
THEN
2497 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
2499 IF ( err_msg_local /=
'' )
THEN
2500 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
2501 DEALLOCATE(field_out)
2502 DEALLOCATE(oor_mask)
2507 IF (numthreads>1 .AND. phys_window)
then
2511 IF ( mask(i-is+1+hi,j-js+1+hj,k) )
THEN
2512 IF ( pow_value /= 1 )
THEN
2513 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2514 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2515 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2517 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2518 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2519 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2522 output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue
2532 IF ( mask(i-is+1+hi,j-js+1+hj,k) )
THEN
2533 IF ( pow_value /= 1 )
THEN
2534 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2535 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2536 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2538 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2539 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2540 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2543 output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue
2552 IF ( need_compute .AND. .NOT.phys_window )
THEN
2553 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))) ) &
2554 & output_fields(out_num)%count_0d(sample) =&
2555 & output_fields(out_num)%count_0d(sample) + weight1
2557 IF ( any(mask(f1:f2,f3:f4,ks:ke)) ) output_fields(out_num)%count_0d(sample) =&
2558 & output_fields(out_num)%count_0d(sample)+weight1
2563 IF ( (.NOT.all(mask(f1:f2,f3:f4,ks:ke)) .AND.
mpp_pe() .EQ. mpp_root_pe()).AND.&
2564 & .NOT.input_fields(diag_field_id)%issued_mask_ignore_warning )
THEN
2569 CALL error_mesg(
'diag_manager_mod::send_data_3d',&
2570 &
'Mask will be ignored since missing values were not specified for field '//&
2571 & trim(input_fields(diag_field_id)%field_name)//
' in module '//&
2572 & trim(input_fields(diag_field_id)%module_name), warning)
2573 input_fields(diag_field_id)%issued_mask_ignore_warning = .true.
2575 IF ( need_compute )
THEN
2576 IF (numthreads>1 .AND. phys_window)
then
2579 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2580 & j <= l_end(2)+hj )
THEN
2581 i1 = i-l_start(1)-hi+1
2582 j1 = j-l_start(2)-hj+1
2583 IF ( pow_value /= 1 )
THEN
2584 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2585 & output_fields(out_num)%buffer(i1,j1,:,sample)+ &
2586 & (field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value)
2588 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2589 & output_fields(out_num)%buffer(i1,j1,:,sample)+ &
2590 & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
2599 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2600 & j <= l_end(2)+hj )
THEN
2601 i1 = i-l_start(1)-hi+1
2602 j1 = j-l_start(2)-hj+1
2603 IF ( pow_value /= 1 )
THEN
2604 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2605 & output_fields(out_num)%buffer(i1,j1,:,sample)+ &
2606 & (field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value)
2608 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2609 & output_fields(out_num)%buffer(i1,j1,:,sample)+ &
2610 & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
2620 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2621 & j <= l_end(2)+hj )
THEN
2622 output_fields(out_num)%num_elements(sample)=&
2623 & output_fields(out_num)%num_elements(sample)+l_end(3)-l_start(3)+1
2629 ELSE IF ( reduced_k_range )
THEN
2630 IF (numthreads>1 .AND. phys_window)
then
2633 IF ( pow_value /= 1 )
THEN
2634 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2635 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) +&
2636 & (field_out(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value)
2638 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2639 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) +&
2640 & field_out(f1:f2,f3:f4,ksr:ker)*weight1
2646 IF ( pow_value /= 1 )
THEN
2647 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2648 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) +&
2649 & (field_out(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value)
2651 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2652 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) +&
2653 & field_out(f1:f2,f3:f4,ksr:ker)*weight1
2658 IF ( debug_diag_manager )
THEN
2659 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
2661 IF ( err_msg_local /=
'')
THEN
2662 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
2663 DEALLOCATE(field_out)
2664 DEALLOCATE(oor_mask)
2669 IF (numthreads>1 .AND. phys_window)
then
2670 IF ( pow_value /= 1 )
THEN
2671 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
2672 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
2673 & (field_out(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value)
2675 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
2676 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
2677 & field_out(f1:f2,f3:f4,ks:ke)*weight1
2681 IF ( pow_value /= 1 )
THEN
2682 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
2683 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
2684 & (field_out(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value)
2686 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
2687 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
2688 & field_out(f1:f2,f3:f4,ks:ke)*weight1
2694 IF ( .NOT.phys_window ) output_fields(out_num)%count_0d(sample) =&
2695 & output_fields(out_num)%count_0d(sample) + weight1
2699 IF ( missvalue_present )
THEN
2700 IF ( need_compute )
THEN
2701 if( numthreads>1 .AND. phys_window )
then
2702 DO k = l_start(3), l_end(3)
2703 k1 = k - l_start(3) + 1
2706 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2707 & j <= l_end(2)+hj)
THEN
2708 i1 = i-l_start(1)-hi+1
2709 j1= j-l_start(2)-hj+1
2710 IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue )
THEN
2711 IF ( pow_value /= 1 )
THEN
2712 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2713 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2714 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2716 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2717 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2718 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2721 output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
2729 DO k = l_start(3), l_end(3)
2730 k1 = k - l_start(3) + 1
2733 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2734 & j <= l_end(2)+hj)
THEN
2735 i1 = i-l_start(1)-hi+1
2736 j1= j-l_start(2)-hj+1
2737 IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue )
THEN
2738 IF ( pow_value /= 1 )
THEN
2739 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2740 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2741 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2743 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2744 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2745 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2748 output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
2759 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2760 & j <= l_end(2)+hj)
THEN
2761 output_fields(out_num)%num_elements(sample) =&
2762 & output_fields(out_num)%num_elements(sample) + l_end(3) - l_start(3) + 1
2766 IF ( .NOT.phys_window )
THEN
2767 outer0:
DO k = l_start(3), l_end(3)
2768 DO j=l_start(2)+hj, l_end(2)+hj
2769 DO i=l_start(1)+hi, l_end(1)+hi
2770 IF ( field_out(i,j,k) /= missvalue )
THEN
2771 output_fields(out_num)%count_0d(sample) = output_fields(out_num)%count_0d(sample)&
2780 ELSE IF ( reduced_k_range )
THEN
2781 if( numthreads>1 .AND. phys_window )
then
2788 IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue )
THEN
2789 IF ( pow_value /= 1 )
THEN
2790 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2791 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2792 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2794 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2795 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2796 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2799 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) = missvalue
2812 IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue )
THEN
2813 IF ( pow_value /= 1 )
THEN
2814 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2815 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2816 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2818 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2819 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2820 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2823 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) = missvalue
2831 outer3:
DO k = ksr, ker
2835 IF ( field_out(i,j,k) /= missvalue )
THEN
2836 output_fields(out_num)%count_0d(sample) = output_fields(out_num)%count_0d(sample) &
2845 IF ( debug_diag_manager )
THEN
2846 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
2848 IF ( err_msg_local /=
'' )
THEN
2849 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
2850 DEALLOCATE(field_out)
2851 DEALLOCATE(oor_mask)
2856 IF( numthreads > 1 .AND. phys_window )
then
2860 IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue )
THEN
2861 IF ( pow_value /= 1 )
THEN
2862 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2863 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2864 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2866 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2867 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2868 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2871 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) = missvalue
2881 IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue )
THEN
2882 IF ( pow_value /= 1 )
THEN
2883 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2884 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2885 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2887 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2888 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2889 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2892 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) = missvalue
2903 IF ( field_out(i,j,k) /= missvalue )
THEN
2904 output_fields(out_num)%count_0d(sample) = output_fields(out_num)%count_0d(sample) &
2914 IF ( need_compute )
THEN
2915 IF( numthreads > 1 .AND. phys_window )
then
2918 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2919 & j <= l_end(2)+hj )
THEN
2920 i1 = i-l_start(1)-hi+1
2921 j1= j-l_start(2)-hj+1
2922 IF ( pow_value /= 1 )
THEN
2923 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2924 & output_fields(out_num)%buffer(i1,j1,:,sample) +&
2925 & (field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value)
2927 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2928 & output_fields(out_num)%buffer(i1,j1,:,sample) +&
2929 & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
2938 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2939 & j <= l_end(2)+hj )
THEN
2940 i1 = i-l_start(1)-hi+1
2941 j1= j-l_start(2)-hj+1
2942 IF ( pow_value /= 1 )
THEN
2943 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2944 & output_fields(out_num)%buffer(i1,j1,:,sample) +&
2945 & (field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value)
2947 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2948 & output_fields(out_num)%buffer(i1,j1,:,sample) +&
2949 & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
2960 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2961 & j <= l_end(2)+hj )
THEN
2962 output_fields(out_num)%num_elements(sample) =&
2963 & output_fields(out_num)%num_elements(sample)+l_end(3)-l_start(3)+1
2969 ELSE IF ( reduced_k_range )
THEN
2972 IF( numthreads > 1 .AND. phys_window )
then
2973 IF ( pow_value /= 1 )
THEN
2974 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2975 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
2976 & (field_out(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value)
2978 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2979 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
2980 & field_out(f1:f2,f3:f4,ksr:ker)*weight1
2984 IF ( pow_value /= 1 )
THEN
2985 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2986 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
2987 & (field_out(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value)
2989 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2990 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
2991 & field_out(f1:f2,f3:f4,ksr:ker)*weight1
2996 IF ( debug_diag_manager )
THEN
2997 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
2999 IF ( err_msg_local /=
'' )
THEN
3000 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3001 DEALLOCATE(field_out)
3002 DEALLOCATE(oor_mask)
3007 IF( numthreads > 1 .AND. phys_window )
then
3008 IF ( pow_value /= 1 )
THEN
3009 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
3010 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
3011 & (field_out(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value)
3013 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
3014 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
3015 & field_out(f1:f2,f3:f4,ks:ke)*weight1
3019 IF ( pow_value /= 1 )
THEN
3020 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
3021 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
3022 & (field_out(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value)
3024 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
3025 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
3026 & field_out(f1:f2,f3:f4,ks:ke)*weight1
3032 IF ( .NOT.phys_window ) output_fields(out_num)%count_0d(sample) =&
3033 & output_fields(out_num)%count_0d(sample) + weight1
3039 IF ( .NOT.need_compute .AND. .NOT.reduced_k_range )&
3040 & output_fields(out_num)%num_elements(sample) =&
3041 & output_fields(out_num)%num_elements(sample) + (ie-is+1)*(je-js+1)*(ke-ks+1)
3042 IF ( reduced_k_range ) &
3043 & output_fields(out_num)%num_elements(sample) = output_fields(out_num)%num_elements(sample) +&
3044 & (ie-is+1)*(je-js+1)*(ker-ksr+1)
3047 ELSE IF ( time_max )
THEN
3048 IF (
PRESENT(mask) )
THEN
3049 IF ( need_compute )
THEN
3050 DO k = l_start(3), l_end(3)
3051 k1 = k - l_start(3) + 1
3054 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
3055 & j <= l_end(2)+hj )
THEN
3056 i1 = i-l_start(1)-hi+1
3057 j1= j-l_start(2)-hj+1
3058 IF ( mask(i-is+1+hi,j-js+1+hj,k) .AND. field_out(i-is+1+hi,j-js+1+hj,k)>&
3059 & output_fields(out_num)%buffer(i1,j1,k1,sample) )
THEN
3060 output_fields(out_num)%buffer(i1,j1,k1,sample) = field_out(i-is+1+hi,j-js+1+hj,k)
3067 ELSE IF ( reduced_k_range )
THEN
3070 WHERE ( mask(f1:f2,f3:f4,ksr:ker) .AND. field_out(f1:f2,f3:f4,ksr:ker) >&
3071 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) )&
3072 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker)
3074 IF ( debug_diag_manager )
THEN
3075 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3077 IF ( err_msg_local /=
'' )
THEN
3078 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3079 DEALLOCATE(field_out)
3080 DEALLOCATE(oor_mask)
3085 WHERE ( mask(f1:f2,f3:f4,ks:ke) .AND. field_out(f1:f2,f3:f4,ks:ke)>&
3086 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) )&
3087 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke)
3090 IF ( need_compute )
THEN
3091 DO k = l_start(3), l_end(3)
3092 k1 = k - l_start(3) + 1
3095 IF(l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
3096 & j <= l_end(2)+hj )
THEN
3097 i1 = i-l_start(1)-hi+1
3098 j1 = j-l_start(2)-hj+1
3099 IF ( field_out(i-is+1+hi,j-js+1+hj,k)>output_fields(out_num)%buffer(i1,j1,k1,sample) )
THEN
3100 output_fields(out_num)%buffer(i1,j1,k1,sample) = field_out(i-is+1+hi,j-js+1+hj,k)
3107 ELSE IF ( reduced_k_range )
THEN
3110 WHERE ( field_out(f1:f2,f3:f4,ksr:ker) >&
3111 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) ) &
3112 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker)
3114 IF ( debug_diag_manager )
THEN
3115 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3117 IF ( err_msg_local /=
'' )
THEN
3118 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3119 DEALLOCATE(field_out)
3120 DEALLOCATE(oor_mask)
3125 WHERE ( field_out(f1:f2,f3:f4,ks:ke) >&
3126 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) ) &
3127 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke)
3130 output_fields(out_num)%count_0d(sample) = 1
3131 ELSE IF ( time_min )
THEN
3132 IF (
PRESENT(mask) )
THEN
3133 IF ( need_compute )
THEN
3134 DO k = l_start(3), l_end(3)
3135 k1 = k - l_start(3) + 1
3138 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
3139 & j <= l_end(2)+hj )
THEN
3140 i1 = i-l_start(1)-hi+1
3141 j1 = j-l_start(2)-hj+1
3142 IF ( mask(i-is+1+hi,j-js+1+hj,k) .AND. field_out(i-is+1+hi,j-js+1+hj,k) <&
3143 & output_fields(out_num)%buffer(i1,j1,k1,sample) )
THEN
3144 output_fields(out_num)%buffer(i1,j1,k1,sample) = field_out(i-is+1+hi,j-js+1+hj,k)
3151 ELSE IF ( reduced_k_range )
THEN
3154 WHERE ( mask(f1:f2,f3:f4,ksr:ker) .AND. field_out(f1:f2,f3:f4,ksr:ker) <&
3155 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) ) &
3156 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker)
3158 IF ( debug_diag_manager )
THEN
3159 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3161 IF ( err_msg_local /=
'' )
THEN
3162 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3163 DEALLOCATE(field_out)
3164 DEALLOCATE(oor_mask)
3169 WHERE ( mask(f1:f2,f3:f4,ks:ke) .AND. field_out(f1:f2,f3:f4,ks:ke) <&
3170 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) ) &
3171 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke)
3174 IF ( need_compute )
THEN
3175 DO k = l_start(3), l_end(3)
3176 k1 = k - l_start(3) + 1
3179 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
3180 i1 = i-l_start(1)-hi+1
3181 j1= j-l_start(2)-hj+1
3182 IF ( field_out(i-is+1+hi,j-js+1+hj,k) <&
3183 & output_fields(out_num)%buffer(i1,j1,k1,sample) )
THEN
3184 output_fields(out_num)%buffer(i1,j1,k1,sample) = field_out(i-is+1+hi,j-js+1+hj,k)
3191 ELSE IF ( reduced_k_range )
THEN
3194 WHERE ( field_out(f1:f2,f3:f4,ksr:ker) <&
3195 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) ) &
3196 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker)
3198 IF ( debug_diag_manager )
THEN
3199 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3201 IF ( err_msg_local /=
'' )
THEN
3202 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3203 DEALLOCATE(field_out)
3204 DEALLOCATE(oor_mask)
3209 WHERE ( field_out(f1:f2,f3:f4,ks:ke) <&
3210 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) )&
3211 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke)
3214 output_fields(out_num)%count_0d(sample) = 1
3215 ELSE IF ( time_sum )
THEN
3216 IF (
PRESENT(mask) )
THEN
3217 IF ( need_compute )
THEN
3218 DO k = l_start(3), l_end(3)
3219 k1 = k - l_start(3) + 1
3222 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
3223 & j <= l_end(2)+hj )
THEN
3224 i1 = i-l_start(1)-hi+1
3225 j1 = j-l_start(2)-hj+1
3226 IF ( mask(i-is+1+hi,j-js+1+hj,k) )
THEN
3227 output_fields(out_num)%buffer(i1,j1,k1,sample) = &
3228 output_fields(out_num)%buffer(i1,j1,k1,sample) + &
3229 field_out(i-is+1+hi,j-js+1+hj,k)
3236 ELSE IF ( reduced_k_range )
THEN
3239 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = &
3240 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
3241 & field_out(f1:f2,f3:f4,ksr:ker)
3243 IF ( debug_diag_manager )
THEN
3244 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3246 IF ( err_msg_local /=
'' )
THEN
3247 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3248 DEALLOCATE(field_out)
3249 DEALLOCATE(oor_mask)
3254 WHERE ( mask(f1:f2,f3:f4,ks:ke) ) &
3255 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = &
3256 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) + &
3257 & field_out(f1:f2,f3:f4,ks:ke)
3260 IF ( need_compute )
THEN
3261 DO k = l_start(3), l_end(3)
3262 k1 = k - l_start(3) + 1
3265 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
3266 i1 = i-l_start(1)-hi+1
3267 j1= j-l_start(2)-hj+1
3268 output_fields(out_num)%buffer(i1,j1,k1,sample) = &
3269 & output_fields(out_num)%buffer(i1,j1,k1,sample) + &
3270 & field_out(i-is+1+hi,j-js+1+hj,k)
3275 ELSE IF ( reduced_k_range )
THEN
3278 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = &
3279 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
3280 & field_out(f1:f2,f3:f4,ksr:ker)
3282 IF ( debug_diag_manager )
THEN
3283 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3285 IF ( err_msg_local /=
'' )
THEN
3286 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3287 DEALLOCATE(field_out)
3288 DEALLOCATE(oor_mask)
3293 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = &
3294 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) + &
3295 & field_out(f1:f2,f3:f4,ks:ke)
3298 output_fields(out_num)%count_0d(sample) = 1
3300 output_fields(out_num)%count_0d(sample) = 1
3301 IF ( need_compute )
THEN
3304 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
3305 i1 = i-l_start(1)-hi+1
3306 j1 = j-l_start(2)-hj+1
3307 output_fields(out_num)%buffer(i1,j1,:,sample) =&
3308 & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))
3313 ELSE IF ( reduced_k_range )
THEN
3316 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker)
3318 IF ( debug_diag_manager )
THEN
3319 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3321 IF ( err_msg_local /=
'' )
THEN
3322 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3323 DEALLOCATE(field_out)
3324 DEALLOCATE(oor_mask)
3329 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke)
3332 IF (
PRESENT(mask) .AND. missvalue_present )
THEN
3333 IF ( need_compute )
THEN
3334 DO k = l_start(3), l_end(3)
3335 k1 = k - l_start(3) + 1
3338 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
3339 & j <= l_end(2)+hj )
THEN
3340 i1 = i-l_start(1)-hi+1
3341 j1 = j-l_start(2)-hj+1
3342 IF ( .NOT.mask(i-is+1+hi,j-js+1+hj,k) )&
3343 & output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
3348 ELSE IF ( reduced_k_range )
THEN
3355 IF ( .NOT.mask(i-is+1+hi,j-js+1+hj,k) ) &
3356 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue
3364 IF ( .NOT.mask(i-is+1+hi,j-js+1+hj,k) )&
3365 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue
3373 IF ( output_fields(out_num)%static .AND. .NOT.need_compute .AND. debug_diag_manager )
THEN
3375 IF ( err_msg_local /=
'' )
THEN
3376 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg))
THEN
3377 DEALLOCATE(field_out)
3378 DEALLOCATE(oor_mask)
3387 IF (
PRESENT(rmask) .AND. missvalue_present )
THEN
3388 IF ( need_compute )
THEN
3390 TYPE IS (real(kind=r4_kind))
3391 DO k = l_start(3), l_end(3)
3392 k1 = k - l_start(3) + 1
3395 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND.&
3396 & j <= l_end(2)+hj )
THEN
3397 i1 = i-l_start(1)-hi+1
3398 j1 = j-l_start(2)-hj+1
3399 IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r4_kind ) &
3400 & output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
3405 TYPE IS (real(kind=r8_kind))
3406 DO k = l_start(3), l_end(3)
3407 k1 = k - l_start(3) + 1
3410 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND.&
3411 & j <= l_end(2)+hj )
THEN
3412 i1 = i-l_start(1)-hi+1
3413 j1 = j-l_start(2)-hj+1
3414 IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r8_kind ) &
3415 & output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
3421 CALL error_mesg (
'diag_manager_mod::send_data_3d',&
3422 &
'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
3424 ELSE IF ( reduced_k_range )
THEN
3428 TYPE IS (real(kind=r4_kind))
3433 IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r4_kind ) &
3434 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue
3438 TYPE IS (real(kind=r8_kind))
3443 IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r8_kind ) &
3444 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue
3449 CALL error_mesg (
'diag_manager_mod::send_data_3d',&
3450 &
'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
3454 TYPE IS (real(kind=r4_kind))
3458 IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r4_kind ) &
3459 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue
3463 TYPE IS (real(kind=r8_kind))
3467 IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r8_kind ) &
3468 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue
3473 CALL error_mesg (
'diag_manager_mod::send_data_3d',&
3474 &
'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
3479 END DO num_out_fields
3481 DEALLOCATE(field_out)
3482 DEALLOCATE(oor_mask)
3488 LOGICAL FUNCTION send_data_4d(diag_field_id, field, time, is_in, js_in, ks_in, &
3489 & mask, rmask, ie_in, je_in, ke_in, weight, err_msg)
3490 INTEGER,
INTENT(in) :: diag_field_id
3491 CLASS(*),
INTENT(in) :: field(:,:,:,:)
3492 CLASS(*),
INTENT(in),
OPTIONAL :: weight
3493 TYPE (
time_type),
INTENT(in),
OPTIONAL :: time
3494 INTEGER,
INTENT(in),
OPTIONAL :: is_in
3495 INTEGER,
INTENT(in),
OPTIONAL :: js_in
3496 INTEGER,
INTENT(in),
OPTIONAL :: ks_in
3497 INTEGER,
INTENT(in),
OPTIONAL :: ie_in
3498 INTEGER,
INTENT(in),
OPTIONAL :: je_in
3499 INTEGER,
INTENT(in),
OPTIONAL :: ke_in
3500 LOGICAL,
INTENT(in),
OPTIONAL :: mask(:,:,:,:)
3501 CLASS(*),
INTENT(in),
OPTIONAL :: rmask(:,:,:,:)
3502 CHARACTER(len=*),
INTENT(out),
OPTIONAL :: err_msg
3505 class(*),
allocatable :: rmask_local(:,:,:,:)
3506 logical,
allocatable :: mask_local(:,:,:,:)
3509 IF ( diag_field_id <= 0 )
THEN
3514 if (.not. use_modern_diag) &
3515 call mpp_error(fatal,
"Send_data_4d is only supported when diag_manager_nml::use_modern_diag=.true.")
3518 if (
present(mask)) mask_local = mask
3519 if (
present(rmask)) rmask_local = rmask
3521 send_data_4d = fms_diag_object%fms_diag_accept_data(diag_field_id, field, mask_local, rmask_local, &
3522 time, is_in, js_in, ks_in, ie_in, je_in, ke_in, weight, &
3525 if (
present(err_msg))
then
3526 if (err_msg .ne.
"")
then
3533 if (
allocated(rmask_local))
deallocate(rmask_local)
3534 if (
allocated(mask_local))
deallocate(mask_local)
3539 INTEGER,
INTENT(in) :: id
3540 REAL,
INTENT(in) :: field(:,:)
3541 REAL,
INTENT(in) :: area (:,:)
3543 LOGICAL,
INTENT(in),
OPTIONAL :: mask (:,:)
3545 REAL,
DIMENSION(SIZE(field,1)) :: out(size(field,1))
3559 INTEGER,
INTENT(in) :: diag_field_id
3560 REAL,
DIMENSION(:,:),
INTENT(in) :: x
3561 REAL,
DIMENSION(:,:),
INTENT(in) :: area
3562 LOGICAL,
DIMENSION(:,:),
INTENT(in) :: mask
3563 REAL,
DIMENSION(:),
INTENT(out) :: out
3566 REAL,
DIMENSION(SIZE(x,1)) :: s
3567 REAL :: local_missing_value
3571 IF ( diag_field_id <= 0 )
THEN
3575 CALL error_mesg(
'diag_manager_mod::average_tiles1d',&
3576 &
"diag_field_id less than 0. Contact developers.", fatal)
3580 IF ( input_fields(diag_field_id)%missing_value_present )
THEN
3581 local_missing_value = input_fields(diag_field_id)%missing_value
3583 local_missing_value = 0.0
3590 DO it = 1,
SIZE(area,dim=2)
3591 WHERE ( mask(:,it) )
3592 out(:) = out(:) + x(:,it)*area(:,it)
3593 s(:) = s(:) + area(:,it)
3598 out(:) = out(:)/s(:)
3600 out(:) = local_missing_value
3606 INTEGER,
INTENT(in) :: id
3607 REAL,
INTENT(in) :: field(:,:,:)
3608 REAL,
INTENT(in) :: area (:,:,:)
3610 LOGICAL,
INTENT(in),
OPTIONAL :: mask (:,:,:)
3612 REAL,
DIMENSION(SIZE(field,1),SIZE(field,2)) :: out(size(field,1), size(field,2))
3626 INTEGER,
INTENT(in) :: id
3627 REAL,
DIMENSION(:,:,:,:),
INTENT(in) :: field
3628 REAL,
DIMENSION(:,:,:),
INTENT(in) :: area (:,:,:)
3631 LOGICAL,
DIMENSION(:,:,:),
INTENT(in),
OPTIONAL :: mask
3633 REAL,
DIMENSION(SIZE(field,1),SIZE(field,2),SIZE(field,4)) :: out
3634 LOGICAL,
DIMENSION(SIZE(field,1),SIZE(field,2),SIZE(field,4)) :: mask3
3643 DO it=1,
SIZE(field,4)
3644 CALL average_tiles(id, field(:,:,:,it), area, mask, out(:,:,it) )
3647 mask3(:,:,1) = any(mask,dim=3)
3648 DO it = 2,
SIZE(field,4)
3649 mask3(:,:,it) = mask3(:,:,1)
3657 INTEGER,
INTENT(in) :: diag_field_id
3658 REAL,
DIMENSION(:,:,:),
INTENT(in) :: x
3659 REAL,
DIMENSION(:,:,:),
INTENT(in) :: area
3660 LOGICAL,
DIMENSION(:,:,:),
INTENT(in) :: mask
3661 REAL,
DIMENSION(:,:),
INTENT(out) :: out
3664 REAL,
DIMENSION(SIZE(x,1),SIZE(x,2)) :: s
3665 REAL :: local_missing_value
3669 IF ( diag_field_id <= 0 )
THEN
3673 CALL error_mesg(
'diag_manager_mod::average_tiles',&
3674 &
"diag_field_id less than 0. Contact developers.", fatal)
3678 IF ( input_fields(diag_field_id)%missing_value_present )
THEN
3679 local_missing_value = input_fields(diag_field_id)%missing_value
3681 local_missing_value = 0.0
3688 DO it = 1,
SIZE(area,3)
3689 WHERE ( mask(:,:,it) )
3690 out(:,:) = out(:,:) + x(:,:,it)*area(:,:,it)
3691 s(:,:) = s(:,:) + area(:,:,it)
3695 WHERE ( s(:,:) > 0 )
3696 out(:,:) = out(:,:)/s(:,:)
3698 out(:,:) = local_missing_value
3704 INTEGER,
INTENT(in) :: out_num
3705 LOGICAL,
INTENT(in) :: at_diag_end
3706 CHARACTER(len=*),
INTENT(out) :: error_string
3711 LOGICAL :: time_max, time_min, reduced_k_range, missvalue_present
3712 LOGICAL :: average, time_rms, need_compute, phys_window
3713 INTEGER :: in_num, file_num, freq, units
3714 INTEGER :: b1,b2,b3,b4
3715 INTEGER :: i, j, k, m
3716 REAL :: missvalue, num
3719 need_compute = output_fields(out_num)%need_compute
3721 in_num = output_fields(out_num)%input_field
3722 IF ( input_fields(in_num)%static )
RETURN
3724 missvalue = input_fields(in_num)%missing_value
3725 missvalue_present = input_fields(in_num)%missing_value_present
3726 reduced_k_range = output_fields(out_num)%reduced_k_range
3727 phys_window = output_fields(out_num)%phys_window
3729 average = output_fields(out_num)%time_average
3732 time_rms = output_fields(out_num)%time_rms
3734 time_max = output_fields(out_num)%time_max
3735 time_min = output_fields(out_num)%time_min
3736 file_num = output_fields(out_num)%output_file
3737 freq = files(file_num)%output_freq
3738 units = files(file_num)%output_units
3742 b1=
SIZE(output_fields(out_num)%buffer,1)
3743 b2=
SIZE(output_fields(out_num)%buffer,2)
3744 b3=
SIZE(output_fields(out_num)%buffer,3)
3745 b4=
SIZE(output_fields(out_num)%buffer,4)
3746 IF ( input_fields(in_num)%mask_variant )
THEN
3751 IF ( output_fields(out_num)%counter(i,j,k,m) > 0. )
THEN
3752 output_fields(out_num)%buffer(i,j,k,m) = &
3753 & output_fields(out_num)%buffer(i,j,k,m)/output_fields(out_num)%counter(i,j,k,m)
3754 IF ( time_rms ) output_fields(out_num)%buffer(i,j,k,m) = &
3755 sqrt(output_fields(out_num)%buffer(i,j,k,m))
3757 output_fields(out_num)%buffer(i,j,k,m) = missvalue
3765 IF ( phys_window )
THEN
3766 IF ( need_compute .OR. reduced_k_range )
THEN
3767 num = real(output_fields(out_num)%num_elements(m)/output_fields(out_num)%region_elements)
3769 num = real(output_fields(out_num)%num_elements(m)/output_fields(out_num)%total_elements)
3772 num = output_fields(out_num)%count_0d(m)
3774 IF ( num > 0. )
THEN
3775 IF ( missvalue_present )
THEN
3779 IF ( output_fields(out_num)%buffer(i,j,k,m) /= missvalue )
THEN
3780 output_fields(out_num)%buffer(i,j,k,m) = output_fields(out_num)%buffer(i,j,k,m)/num
3781 IF ( time_rms ) output_fields(out_num)%buffer(i,j,k,m) =&
3782 & sqrt(output_fields(out_num)%buffer(i,j,k,m))
3788 output_fields(out_num)%buffer(:,:,:,m) = output_fields(out_num)%buffer(:,:,:,m)/num
3789 IF ( time_rms ) output_fields(out_num)%buffer(:,:,:,m) =&
3790 & sqrt(output_fields(out_num)%buffer(:,:,:,m))
3792 ELSE IF ( .NOT. at_diag_end )
THEN
3793 IF ( missvalue_present )
THEN
3794 IF(any(output_fields(out_num)%buffer /= missvalue))
THEN
3795 WRITE (error_string,
'(a,"/",a)')&
3796 & trim(input_fields(in_num)%module_name), &
3797 & trim(output_fields(out_num)%output_name)
3805 ELSE IF ( time_min .OR. time_max )
THEN
3806 IF ( missvalue_present )
THEN
3807 WHERE ( abs(output_fields(out_num)%buffer) == min_value )
3808 output_fields(out_num)%buffer = missvalue
3814 IF ( at_diag_end .AND. freq == end_of_run ) output_fields(out_num)%next_output = time
3816 IF ( (output_fields(out_num)%time_ops) .AND. (.NOT. mix_snapshot_average_fields) )
THEN
3817 middle_time = (output_fields(out_num)%last_output+output_fields(out_num)%next_output)/2
3818 if (trim(files(file_num)%filename_time_bounds) ==
"begin")
then
3819 filename_time = output_fields(out_num)%last_output
3820 elseif (trim(files(file_num)%filename_time_bounds) ==
"middle")
then
3821 filename_time = middle_time
3822 elseif (trim(files(file_num)%filename_time_bounds) ==
"end")
then
3823 filename_time = output_fields(out_num)%next_output
3826 CALL diag_data_out(file_num, out_num, output_fields(out_num)%buffer, middle_time, &
3827 & filename_time=filename_time)
3830 & output_fields(out_num)%buffer, output_fields(out_num)%next_output)
3834 IF ( at_diag_end )
RETURN
3837 output_fields(out_num)%last_output = output_fields(out_num)%next_output
3838 IF ( freq == end_of_run )
THEN
3839 output_fields(out_num)%next_output = time
3841 IF ( freq == every_time )
THEN
3842 output_fields(out_num)%next_output = time
3844 output_fields(out_num)%next_output = output_fields(out_num)%next_next_output
3845 output_fields(out_num)%next_next_output = &
3846 & diag_time_inc(output_fields(out_num)%next_next_output, freq, units)
3848 output_fields(out_num)%count_0d(:) = 0.0
3849 output_fields(out_num)%num_elements(:) = 0
3850 IF ( time_max )
THEN
3851 output_fields(out_num)%buffer = max_value
3852 ELSE IF ( time_min )
THEN
3853 output_fields(out_num)%buffer = min_value
3855 output_fields(out_num)%buffer = empty
3857 IF ( input_fields(in_num)%mask_variant .AND. average ) output_fields(out_num)%counter = 0.0
3861 SUBROUTINE diag_manager_set_time_end(Time_end_in)
3862 TYPE (
time_type),
INTENT(in) :: time_end_in
3864 time_end = time_end_in
3866 END SUBROUTINE diag_manager_set_time_end
3881 integer :: file, j, freq, in_num, file_num, out_num
3883 DO file = 1, num_files
3884 freq = files(file)%output_freq
3886 DO j = 1, files(file)%num_fields
3887 out_num = files(file)%fields(j)
3888 in_num = output_fields(out_num)%input_field
3889 IF ( (input_fields(in_num)%numthreads == 1) .AND.&
3890 & (input_fields(in_num)%active_omp_level.LE.1) ) cycle
3891 file_num = output_fields(out_num)%output_file
3893 & output_fields(out_num)%buffer, time)
3902 TYPE (
time_type),
INTENT(in) :: time_step
3903 character(len=*),
INTENT(out),
optional :: err_msg
3906 integer :: file, j, out_num, in_num, freq, status
3907 logical :: local_output, need_compute
3908 CHARACTER(len=128) :: error_string
3910 IF ( time_end == time_zero )
THEN
3914 CALL error_mesg(
'diag_manager_mod::diag_send_complete',&
3915 &
"diag_manager_set_time_end must be called before diag_send_complete", fatal)
3918 if (use_modern_diag)
then
3919 call fms_diag_object%fms_diag_send_complete(time_step)
3923 DO file = 1, num_files
3924 freq = files(file)%output_freq
3925 DO j = 1, files(file)%num_fields
3926 out_num = files(file)%fields(j)
3927 in_num = output_fields(out_num)%input_field
3929 IF ( (input_fields(in_num)%numthreads == 1) .AND. (input_fields(in_num)%active_omp_level.LE.1) ) cycle
3930 IF ( output_fields(out_num)%static .OR. freq == end_of_run ) cycle
3931 time = input_fields(in_num)%time
3932 IF ( time >= time_end ) cycle
3935 local_output = output_fields(out_num)%local_output
3937 need_compute = output_fields(out_num)%need_compute
3939 IF ( local_output .AND. (.NOT.need_compute) ) cycle
3940 next_time = time + time_step
3942 IF ( next_time > output_fields(out_num)%next_output )
THEN
3944 IF ( next_time > output_fields(out_num)%next_next_output .AND. freq > 0 )
THEN
3945 IF (
mpp_pe() .EQ. mpp_root_pe() )
THEN
3946 WRITE (error_string,
'(a,"/",a)')&
3947 & trim(input_fields(in_num)%module_name), &
3948 & trim(output_fields(out_num)%output_name)
3950 &
'module/output_field '//trim(error_string)//&
3951 &
' is skipped one time level in output data', err_msg))
RETURN
3955 status =
writing_field(out_num, .false., error_string, next_time)
3956 IF ( status == -1 )
THEN
3957 IF (
mpp_pe() .EQ. mpp_root_pe() )
THEN
3958 IF(
fms_error_handler(
'diag_manager_mod::diag_send_complete',
'module/output_field '//&
3959 & trim(error_string)//
', write EMPTY buffer', err_msg))
RETURN
3975 IF ( do_diag_field_log )
THEN
3976 close (diag_log_unit)
3978 DO file = 1, num_files
3981 if (
allocated(fileobju))
deallocate(fileobju)
3982 if (
allocated(fileobj))
deallocate(fileobj)
3983 if (
allocated(fileobjnd))
deallocate(fileobjnd)
3986 if (use_modern_diag)
then
3987 call fms_diag_object%diag_end(time)
3993 INTEGER,
INTENT(in) :: file
3996 INTEGER :: j, i, input_num, freq, status
3997 INTEGER :: stdout_unit
3998 LOGICAL :: reduced_k_range, need_compute, local_output
3999 CHARACTER(len=128) :: message
4004 DO j = 1, files(file)%num_fields
4005 i = files(file)%fields(j)
4008 local_output = output_fields(i)%local_output
4010 need_compute = output_fields(i)%need_compute
4012 reduced_k_range = output_fields(i)%reduced_k_range
4015 IF ( local_output .AND. (.NOT. need_compute) ) cycle
4017 input_num = output_fields(i)%input_field
4018 IF ( input_fields(input_num)%static ) cycle
4019 IF ( .NOT.input_fields(input_num)%register ) cycle
4020 freq = files(file)%output_freq
4021 IF ( freq /= end_of_run .AND. files(file)%file_unit < 0 &
4022 & .AND. all(output_fields(i)%num_elements(:) == 0)&
4023 & .AND. all(output_fields(i)%count_0d(:) == 0) ) cycle
4026 IF ( time >= output_fields(i)%next_output .OR. freq == end_of_run )
THEN
4027 IF ( time >= output_fields(i)%next_next_output .AND. freq > 0 )
THEN
4028 WRITE (message,
'(a,"/",a)') trim(input_fields(input_num)%module_name), &
4029 & trim(output_fields(i)%output_name)
4034 IF (
mpp_pe() .EQ. mpp_root_pe() ) &
4035 &
CALL error_mesg(
'diag_manager_mod::closing_file',
'module/output_field ' //&
4036 & trim(message)//
', skip one time level, maybe send_data never called', warning)
4041 ELSEIF ( .NOT.output_fields(i)%written_once )
THEN
4046 CALL error_mesg(
'Potential error in diag_manager_end ',&
4047 & trim(output_fields(i)%output_name)//
' NOT available,'//&
4048 &
' check if output interval > runlength. Netcdf fill_values are written', note)
4049 output_fields(i)%buffer = fill_value
4050 CALL diag_data_out(file, i, output_fields(i)%buffer, time, .true.)
4057 IF ( write_bytes_in_file )
THEN
4058 CALL mpp_sum (files(file)%bytes_written)
4059 IF (
mpp_pe() == mpp_root_pe() )&
4060 &
WRITE (stdout_unit,
'(a,i12,a,a)')
'Diag_Manager: ',files(file)%bytes_written, &
4061 &
' bytes of data written to file ',trim(files(file)%name)
4068 INTEGER,
OPTIONAL,
INTENT(IN) :: diag_model_subset
4069 INTEGER,
DIMENSION(6),
OPTIONAL,
INTENT(IN) :: time_init
4070 CHARACTER(len=*),
INTENT(out),
OPTIONAL :: err_msg
4072 CHARACTER(len=*),
PARAMETER :: sep =
'|'
4074 INTEGER,
PARAMETER :: fltkind = r4_kind
4075 INTEGER,
PARAMETER :: dblkind = r8_kind
4076 INTEGER :: diag_subset_output
4078 INTEGER,
ALLOCATABLE,
DIMENSION(:) :: pelist
4079 INTEGER :: stdlog_unit, stdout_unit
4081 CHARACTER(len=256) :: err_msg_local
4083 namelist /diag_manager_nml/ append_pelist_name, mix_snapshot_average_fields, max_output_fields, &
4084 & max_input_fields, max_axes, do_diag_field_log, write_bytes_in_file, debug_diag_manager,&
4085 & max_num_axis_sets, max_files, use_cmor, issue_oor_warnings,&
4086 & oor_warnings_fatal, max_out_per_in_field, flush_nc_files, region_out_use_alt_value, max_field_attributes,&
4087 & max_file_attributes, max_axis_attributes, prepend_date, use_modern_diag, use_clock_average, &
4091 IF ( module_is_initialized )
RETURN
4094 IF (
PRESENT(err_msg) ) err_msg =
''
4099 call diag_data_init()
4102 pack_size =
SIZE(transfer(0.0_dblkind, (/0.0, 0.0, 0.0, 0.0/)))
4103 IF (pack_size .EQ. 1)
then
4104 pack_size_str =
"double"
4105 else if (pack_size .EQ. 2)
then
4106 pack_size_str =
"float"
4108 IF (
fms_error_handler(
'diag_manager_mod::diag_manager_init',
'unknown pack_size. Must be 1, or 2.', &
4113 min_value = huge(0.0_fltkind)
4114 max_value = -min_value
4125 time_end = time_zero
4126 diag_subset_output = diag_all
4127 IF (
PRESENT(diag_model_subset) )
THEN
4128 IF ( diag_model_subset >= diag_other .AND. diag_model_subset <= diag_all )
THEN
4129 diag_subset_output = diag_model_subset
4131 IF (
fms_error_handler(
'diag_manager_mod::diag_manager_init',
'invalid value of diag_model_subset', &
4136 READ (input_nml_file, nml=diag_manager_nml, iostat=mystat)
4139 IF (
check_nml_error(iostat=mystat, nml_name=
'DIAG_MANAGER_NML') < 0 )
THEN
4140 IF (
mpp_pe() == mpp_root_pe() )
THEN
4141 CALL error_mesg(
'diag_manager_mod::diag_manager_init', &
4142 &
'DIAG_MANAGER_NML not found in input nml file. Using defaults.', warning)
4146 IF (.not. use_modern_diag .and. use_clock_average) &
4147 call mpp_error(fatal,
"diag_manager_mod: You cannot set use_modern_diag=.false. and &
4148 & use_clock_average=.true. in diag_manager_nml")
4150 IF (
mpp_pe() == mpp_root_pe() )
THEN
4151 WRITE (stdlog_unit, diag_manager_nml)
4155 IF ( use_cmor )
THEN
4157 WRITE (err_msg_local,
'(ES8.1E2)') cmor_missing_value
4158 CALL error_mesg(
'diag_manager_mod::diag_manager_init',
'Using CMOR missing value ('//trim(err_msg_local)// &
4163 IF ( oor_warnings_fatal )
THEN
4165 CALL error_mesg(
'diag_manager_mod::diag_manager_init',
'Out &
4166 &of Range warnings are fatal.', note)
4167 ELSEIF ( .NOT.issue_oor_warnings )
THEN
4168 CALL error_mesg(
'diag_manager_mod::diag_manager_init',
'Out &
4169 &of Range warnings will be ignored.', note)
4172 IF ( mix_snapshot_average_fields )
THEN
4173 IF ( .not. use_modern_diag )
THEN
4174 CALL error_mesg(
'diag_manager_mod::diag_manager_init',
'Setting diag_manager_nml variable '//&
4175 &
'mix_snapshot_average_fields = .TRUE. will cause ERRORS in the time coordinates '//&
4176 &
'of all time averaged fields. Strongly recommend setting mix_snapshot_average_fields '//&
4177 &
'= .FALSE.', note)
4179 CALL error_mesg(
'diag_manager_mod::diag_manager_init',
'mix_snapshot_average_fields = .TRUE. is not '//&
4180 &
'supported if use_modern_diag = .TRUE. Please set mix_snapshot_average_fields '//&
4181 &
'to .FALSE. and put instantaneous and averaged fields in seperate files!', fatal)
4184 ALLOCATE(output_fields(max_output_fields))
4185 ALLOCATE(input_fields(max_input_fields))
4186 DO j = 1, max_input_fields
4187 ALLOCATE(input_fields(j)%output_fields(max_out_per_in_field))
4190 ALLOCATE(files(max_files))
4191 ALLOCATE(fileobju(max_files))
4192 ALLOCATE(fileobj(max_files))
4193 ALLOCATE(fileobjnd(max_files))
4198 CALL mpp_get_current_pelist(pelist, pelist_name)
4201 IF (
PRESENT(time_init) )
THEN
4202 diag_init_time =
set_date(time_init(1), time_init(2), time_init(3), time_init(4),&
4203 & time_init(5), time_init(6))
4205 diag_init_time = get_base_time()
4206 IF ( prepend_date .EQV. .true. )
THEN
4207 CALL error_mesg(
'diag_manager_mod::diag_manager_init',&
4208 &
'prepend_date only supported when diag_manager_init is called with time_init present.', note)
4209 prepend_date = .false.
4213 if (use_modern_diag)
then
4214 CALL fms_diag_object%init(diag_subset_output, time_init)
4216 if (.not. use_modern_diag)
then
4217 CALL parse_diag_table(diag_subset=diag_subset_output, istat=mystat, err_msg=err_msg_local)
4218 IF ( mystat /= 0 )
THEN
4220 &
'Error parsing diag_table. '//trim(err_msg_local), err_msg) )
RETURN
4224 files(:)%bytes_written = 0
4227 IF ( do_diag_field_log.AND.
mpp_pe().EQ.mpp_root_pe() )
THEN
4228 open(newunit=diag_log_unit, file=
'diag_field_log.out.'//
string(
mpp_pe()), action=
'WRITE')
4229 WRITE (diag_log_unit,
'(777a)') &
4237 module_is_initialized = .true.
4239 if(.not. use_modern_diag) null_axis_id = diag_axis_init(
'scalar_axis', (/0./),
'none',
'N',
'none')
4246 INTEGER,
INTENT(out) :: year, month, day, hour, minute, second
4249 IF (.NOT.module_is_initialized)
CALL error_mesg (
'diag_manager_mod::get_base_date', &
4250 &
'module has not been initialized', fatal)
4251 year = get_base_year()
4252 month = get_base_month()
4253 day = get_base_day()
4254 hour = get_base_hour()
4255 minute = get_base_minute()
4256 second = get_base_second()
4266 TYPE(
time_type),
INTENT(in) :: next_model_time
4267 INTEGER,
INTENT(in) :: diag_field_id
4269 INTEGER :: i, out_num
4272 IF ( diag_field_id < 0 )
RETURN
4273 DO i = 1, input_fields(diag_field_id)%num_output_fields
4275 out_num = input_fields(diag_field_id)%output_fields(i)
4276 IF ( .NOT.output_fields(out_num)%static )
THEN
4277 IF ( next_model_time > output_fields(out_num)%next_output )
need_data=.true.
4281 IF ( output_fields(out_num)%time_average)
need_data = .true.
4293 INTEGER,
INTENT(in) :: n_samples
4295 REAL :: center_data (n_samples)
4296 REAL :: edges (n_samples+1)
4305 CHARACTER(32) :: name
4306 CHARACTER(128) :: units
4309 WRITE (units,11)
'hours', year, month, day, hour, minute, second
4310 11
FORMAT(a,
' since ',i4.4,
'-',i2.2,
'-',i2.2,
' ',i2.2,
':',i2.2,
':',i2.2)
4314 center_data(i) = 24.0*(real(i)-0.5)/n_samples
4315 edges(i+1) = 24.0* real(i)/n_samples
4320 WRITE (name,
'(a,i2.2)')
'time_of_day_edges_', n_samples
4321 edges_id = get_axis_num(name,
'diurnal')
4322 IF ( edges_id <= 0 )
THEN
4323 edges_id = diag_axis_init(name,edges,units,
'N',
'time of day edges', set_name=
'diurnal')
4328 WRITE (name,
'(a,i2.2)')
'time_of_day_', n_samples
4331 init_diurnal_axis = diag_axis_init(name, center_data, units,
'N',
'time of day', &
4332 set_name=
'diurnal', edges=edges_id)
4337 INTEGER,
INTENT(in) :: diag_field_id
4338 CHARACTER(len=*),
INTENT(in) :: name
4339 INTEGER,
INTENT(in) ::
type
4340 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: cval
4341 INTEGER,
DIMENSION(:),
INTENT(in),
OPTIONAL :: ival
4342 REAL,
DIMENSION(:),
INTENT(in),
OPTIONAL :: rval
4344 INTEGER :: istat, length, i, j, this_attribute, out_field
4346 IF ( .NOT.first_send_data_call )
THEN
4352 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',
'Attempting to add attribute "'&
4353 &//trim(name)//
'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//
'/'&
4354 &//trim(input_fields(diag_field_id)%field_name)//
'" after first send_data call. Too late.', fatal)
4358 IF ( diag_field_id .LE. 0 )
THEN
4361 DO j=1,input_fields(diag_field_id)%num_output_fields
4362 out_field = input_fields(diag_field_id)%output_fields(j)
4369 DO i=1, output_fields(out_field)%num_attributes
4370 IF ( trim(output_fields(out_field)%attributes(i)%name) .EQ. trim(name) )
THEN
4376 IF ( this_attribute.NE.0 .AND. (type.EQ.nf90_int .OR. type.EQ.nf90_float) )
THEN
4381 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',&
4382 &
'Attribute "'//trim(name)//
'" already defined for module/input_field "'&
4383 &//trim(input_fields(diag_field_id)%module_name)//
'/'&
4384 &//trim(input_fields(diag_field_id)%field_name)//
'". Contact the developers.', fatal)
4385 ELSE IF ( this_attribute.NE.0 .AND. type.EQ.nf90_char .AND. debug_diag_manager )
THEN
4390 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',&
4391 &
'Attribute "'//trim(name)//
'" already defined for module/input_field "'&
4392 &//trim(input_fields(diag_field_id)%module_name)//
'/'&
4393 &//trim(input_fields(diag_field_id)%field_name)//
'". Prepending.', note)
4394 ELSE IF ( this_attribute.EQ.0 )
THEN
4397 this_attribute = output_fields(out_field)%num_attributes + 1
4399 IF ( this_attribute .GT. max_field_attributes )
THEN
4405 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',&
4406 &
'Number of attributes exceeds max_field_attributes for attribute "'&
4407 &//trim(name)//
'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//
'/'&
4408 &//trim(input_fields(diag_field_id)%field_name)&
4409 &//
'". Increase diag_manager_nml:max_field_attributes.', fatal)
4411 output_fields(out_field)%num_attributes = this_attribute
4413 output_fields(out_field)%attributes(this_attribute)%name = name
4414 output_fields(out_field)%attributes(this_attribute)%type =
type
4416 output_fields(out_field)%attributes(this_attribute)%catt =
''
4422 IF ( .NOT.
PRESENT(ival) )
THEN
4428 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',&
4429 &
'Attribute type claims INTEGER, but ival not present for attribute "'&
4430 &//trim(name)//
'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//
'/'&
4431 &//trim(input_fields(diag_field_id)%field_name)//
'". Contact then developers.', fatal)
4435 ALLOCATE(output_fields(out_field)%attributes(this_attribute)%iatt(length), stat=istat)
4436 IF ( istat.NE.0 )
THEN
4440 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',
'Unable to allocate iatt for attribute "'&
4441 &//trim(name)//
'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//
'/'&
4442 &//trim(input_fields(diag_field_id)%field_name)//
'"', fatal)
4445 output_fields(out_field)%attributes(this_attribute)%len = length
4446 output_fields(out_field)%attributes(this_attribute)%iatt = ival
4448 IF ( .NOT.
PRESENT(rval) )
THEN
4454 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',&
4455 &
'Attribute type claims REAL, but rval not present for attribute "'&
4456 &//trim(name)//
'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//
'/'&
4457 &//trim(input_fields(diag_field_id)%field_name)//
'". Contact the developers.', fatal)
4461 ALLOCATE(output_fields(out_field)%attributes(this_attribute)%fatt(length), stat=istat)
4462 IF ( istat.NE.0 )
THEN
4466 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',
'Unable to allocate fatt for attribute "'&
4467 &//trim(name)//
'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//
'/'&
4468 &//trim(input_fields(diag_field_id)%field_name)//
'"', fatal)
4471 output_fields(out_field)%attributes(this_attribute)%len = length
4472 output_fields(out_field)%attributes(this_attribute)%fatt = rval
4474 IF ( .NOT.
PRESENT(cval) )
THEN
4480 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',&
4481 &
'Attribute type claims CHARACTER, but cval not present for attribute "'&
4482 &//trim(name)//
'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//
'/'&
4483 &//trim(input_fields(diag_field_id)%field_name)//
'". Contact the developers.', fatal)
4491 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',
'Unknown attribute type for attribute "'&
4492 &//trim(name)//
'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//
'/'&
4493 &//trim(input_fields(diag_field_id)%field_name)//
'". Contact the developers.', fatal)
4501 INTEGER,
INTENT(in) :: diag_field_id
4502 CHARACTER(len=*),
INTENT(in) :: att_name
4503 REAL,
INTENT(in) :: att_value
4505 if (use_modern_diag)
then
4506 call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, (/att_value /))
4514 INTEGER,
INTENT(in) :: diag_field_id
4515 CHARACTER(len=*),
INTENT(in) :: att_name
4516 INTEGER,
INTENT(in) :: att_value
4518 if (use_modern_diag)
then
4519 call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, (/att_value /))
4527 INTEGER,
INTENT(in) :: diag_field_id
4528 CHARACTER(len=*),
INTENT(in) :: att_name
4529 CHARACTER(len=*),
INTENT(in) :: att_value
4531 if (use_modern_diag)
then
4532 call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, (/att_value /))
4540 INTEGER,
INTENT(in) :: diag_field_id
4541 CHARACTER(len=*),
INTENT(in) :: att_name
4542 REAL,
DIMENSION(:),
INTENT(in) :: att_value
4544 if (use_modern_diag)
then
4545 call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, att_value)
4553 INTEGER,
INTENT(in) :: diag_field_id
4554 CHARACTER(len=*),
INTENT(in) :: att_name
4555 INTEGER,
DIMENSION(:),
INTENT(in) :: att_value
4557 if (use_modern_diag)
then
4558 call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, att_value)
4570 INTEGER,
INTENT(in) :: diag_field_id
4571 INTEGER,
INTENT(in),
OPTIONAL :: area
4572 INTEGER,
INTENT(in),
OPTIONAL :: volume
4576 IF ( diag_field_id.GT.0 )
THEN
4577 IF ( .NOT.
PRESENT(area) .AND. .NOT.
present(volume) )
THEN
4578 CALL error_mesg(
'diag_manager_mod::diag_field_add_cell_measures', &
4579 &
'either area or volume arguments must be present', fatal )
4582 if (use_modern_diag)
then
4583 call fms_diag_object%fms_diag_field_add_cell_measures(diag_field_id, area, volume)
4587 DO j=1, input_fields(diag_field_id)%num_output_fields
4588 ind = input_fields(diag_field_id)%output_fields(j)
4596 class(*),
intent(in) :: data_in(:,:,:)
4597 character(len=*),
intent(in) :: field_name
4598 class(*),
allocatable,
intent(out) :: data_out(:,:,:,:)
4601 select type(data_in)
4602 type is (real(kind=r8_kind))
4603 allocate(real(kind=r8_kind) :: data_out(1:
size(data_in,1), 1:
size(data_in,2), 1:
size(data_in,3), 1))
4604 select type (data_out)
4605 type is (real(kind=r8_kind))
4606 data_out(:,:,:,1) = data_in
4608 call mpp_error(fatal,
"The copy of "//trim(field_name)//&
4609 " was not allocated to the correct type (r8_kind). This shouldn't have happened")
4611 type is (real(kind=r4_kind))
4612 allocate(real(kind=r4_kind) :: data_out(1:
size(data_in,1), 1:
size(data_in,2), 1:
size(data_in,3), 1))
4613 select type (data_out)
4614 type is (real(kind=r4_kind))
4615 data_out(:,:,:,1) = data_in
4617 call mpp_error(fatal,
"The copy of "//trim(field_name)//&
4618 " was not allocated to the correct type (r4_kind). This shouldn't have happened")
4621 call mpp_error(fatal,
"The data for "//trim(field_name)//&
4622 &
" is not a valid type. Currently only r4 and r8 are supported")
4626 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.
subroutine diag_field_add_attribute_r1d(diag_field_id, att_name, att_value)
Add a real 1D array attribute to the diag field corresponding to a given id.
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.
subroutine diag_field_add_attribute_i1d(diag_field_id, att_name, att_value)
Add an integer 1D array attribute to the diag field corresponding to a given id.
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 diag_field_add_attribute_scalar_i(diag_field_id, att_name, att_value)
Add a scalar integer attribute to the diag field corresponding to a given id.
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.
subroutine diag_field_add_attribute_scalar_r(diag_field_id, att_name, att_value)
Add a scalar real attribute to the diag field corresponding to a given id.
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)
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_scalar_c(diag_field_id, att_name, att_value)
Add a scalar character 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.