145 MODULE diag_manager_mod
209 &
OPERATOR(<),
OPERATOR(==),
OPERATOR(/=),
OPERATOR(/),
OPERATOR(+),
ASSIGNMENT(=),
get_date, &
213 USE mpp_mod,
ONLY: input_nml_file,
mpp_error
226 & end_of_run, diag_seconds, diag_minutes, diag_hours, diag_days, diag_months, diag_years,
num_files,&
230 & output_fields, time_zero, append_pelist_name, mix_snapshot_average_fields,&
231 & first_send_data_call, do_diag_field_log, write_bytes_in_file, debug_diag_manager,&
242 use fms_diag_object_mod,
only:fms_diag_object
244 USE constants_mod,
ONLY: seconds_per_day
248 USE fms_string_utils_mod,
ONLY:
string
250 USE netcdf,
ONLY: nf90_int, nf90_float, nf90_char
263 &
need_data, diag_all, diag_ocean, diag_other, get_date_dif, diag_seconds,&
267 PUBLIC :: center, north, east
273 PUBLIC :: diag_field_not_found
277 #include<file_version.h>
279 type(time_type) :: Time_end
382 & long_name, units, missing_value, range, standard_name, do_not_log, err_msg,&
383 & area, volume, realm, multiple_send_data)
384 CHARACTER(len=*),
INTENT(in) :: module_name
385 CHARACTER(len=*),
INTENT(in) :: field_name
386 TYPE(
time_type),
OPTIONAL,
INTENT(in) :: init_time
387 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: long_name
388 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: units
389 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: standard_name
390 CLASS(*),
OPTIONAL,
INTENT(in) :: missing_value
391 CLASS(*),
OPTIONAL,
INTENT(in) :: range(:)
392 LOGICAL,
OPTIONAL,
INTENT(in) :: do_not_log
393 CHARACTER(len=*),
OPTIONAL,
INTENT(out):: err_msg
394 INTEGER,
OPTIONAL,
INTENT(in) :: area
395 INTEGER,
OPTIONAL,
INTENT(in) :: volume
396 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: realm
397 LOGICAL,
OPTIONAL,
INTENT(in) :: multiple_send_data
401 IF (
PRESENT(range) )
THEN
402 IF (
SIZE(range) .NE. 2 )
THEN
404 CALL error_mesg (
'diag_manager_mod::register_diag_field',
'extent of range should be 2', fatal)
407 if (use_modern_diag)
then
408 if( do_diag_field_log)
then
409 if (
PRESENT(do_not_log) )
THEN
410 if(.not. do_not_log)
call log_diag_field_info(module_name, field_name, (/null_axis_id/), long_name,&
411 & units, missing_value, range, dynamic=.true.)
414 & missing_value, range, dynamic=.true.)
418 & module_name, field_name, init_time, long_name=long_name, units=units, &
419 & missing_value=missing_value, var_range=range, standard_name=standard_name, &
420 & do_not_log=do_not_log, err_msg=err_msg, area=area, volume=volume, realm=realm, &
421 multiple_send_data=multiple_send_data)
424 & long_name=long_name, units=units, missing_value=missing_value, range=range, standard_name=standard_name, &
425 & do_not_log=do_not_log, err_msg=err_msg, area=area, volume=volume, realm=realm)
432 & long_name, units, missing_value, range, mask_variant, standard_name, verbose,&
433 & do_not_log, err_msg, interp_method, tile_count, area, volume, realm, multiple_send_data)
434 CHARACTER(len=*),
INTENT(in) :: module_name
435 CHARACTER(len=*),
INTENT(in) :: field_name
436 INTEGER,
INTENT(in) :: axes(:)
437 TYPE(
time_type),
OPTIONAL,
INTENT(in) :: init_time
438 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: long_name
439 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: units
440 CLASS(*),
OPTIONAL,
INTENT(in) :: missing_value
441 CLASS(*),
OPTIONAL,
INTENT(in) :: range(:)
442 LOGICAL,
OPTIONAL,
INTENT(in) :: mask_variant
443 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: standard_name
444 LOGICAL,
OPTIONAL,
INTENT(in) :: verbose
445 LOGICAL,
OPTIONAL,
INTENT(in) :: do_not_log
446 CHARACTER(len=*),
OPTIONAL,
INTENT(out):: err_msg
447 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: interp_method
451 INTEGER,
OPTIONAL,
INTENT(in) :: tile_count
452 INTEGER,
OPTIONAL,
INTENT(in) :: area
453 INTEGER,
OPTIONAL,
INTENT(in) :: volume
454 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: realm
455 LOGICAL,
OPTIONAL,
INTENT(in) :: multiple_send_data
458 if (use_modern_diag)
then
459 if( do_diag_field_log)
then
460 if (
PRESENT(do_not_log) )
THEN
462 & units, missing_value, range, dynamic=.true.)
465 & missing_value, range, dynamic=.true.)
469 & module_name, field_name, axes, init_time, long_name=long_name, &
470 & units=units, missing_value=missing_value, var_range=range, mask_variant=mask_variant, &
471 & standard_name=standard_name, verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
472 & interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm, &
473 multiple_send_data=multiple_send_data)
476 & long_name=long_name, units=units, missing_value=missing_value, range=range, mask_variant=mask_variant, &
477 & standard_name=standard_name, verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
478 & interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm)
485 & missing_value, range, mask_variant, standard_name, DYNAMIC, do_not_log, interp_method,&
486 & tile_count, area, volume, realm)
487 CHARACTER(len=*),
INTENT(in) :: module_name
488 CHARACTER(len=*),
INTENT(in) :: field_name
489 INTEGER,
DIMENSION(:),
INTENT(in) :: axes
490 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: long_name
491 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: units
492 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: standard_name
493 CLASS(*),
OPTIONAL,
INTENT(in) :: missing_value
494 CLASS(*),
DIMENSION(:),
OPTIONAL,
INTENT(in) :: range
495 LOGICAL,
OPTIONAL,
INTENT(in) :: mask_variant
496 LOGICAL,
OPTIONAL,
INTENT(in) :: dynamic
497 LOGICAL,
OPTIONAL,
INTENT(in) :: do_not_log
498 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: interp_method
502 INTEGER,
OPTIONAL,
INTENT(in) :: tile_count
503 INTEGER,
OPTIONAL,
INTENT(in) :: area
505 INTEGER,
OPTIONAL,
INTENT(in) :: volume
507 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: realm
511 IF ( .NOT.module_is_initialized )
THEN
513 CALL error_mesg (
'diag_manager_mod::register_static_field',
'diag_manager has NOT been initialized', fatal)
516 if (use_modern_diag)
then
517 if( do_diag_field_log)
then
518 if (
PRESENT(do_not_log) )
THEN
520 & units, missing_value, range, dynamic=.false.)
523 & missing_value, range, dynamic=.false.)
527 & long_name=long_name, units=units, missing_value=missing_value, range=range, mask_variant=mask_variant, &
528 & standard_name=standard_name, dynamic=dynamic, do_not_log=do_not_log, interp_method=interp_method,&
529 & tile_count=tile_count, area=area, volume=volume, realm=realm)
532 & long_name=long_name, units=units, missing_value=missing_value, range=range, mask_variant=mask_variant, &
533 & standard_name=standard_name, dynamic=dynamic, do_not_log=do_not_log, interp_method=interp_method,&
534 & tile_count=tile_count, area=area, volume=volume, realm=realm)
541 & long_name, units, missing_value, range, standard_name, do_not_log, err_msg,&
542 & area, volume, realm)
543 CHARACTER(len=*),
INTENT(in) :: module_name
544 CHARACTER(len=*),
INTENT(in) :: field_name
545 TYPE(
time_type),
OPTIONAL,
INTENT(in) :: init_time
546 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: long_name
547 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: units
548 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: standard_name
549 CLASS(*),
OPTIONAL,
INTENT(in) :: missing_value
550 CLASS(*),
OPTIONAL,
INTENT(in) :: range(:)
551 LOGICAL,
OPTIONAL,
INTENT(in) :: do_not_log
552 CHARACTER(len=*),
OPTIONAL,
INTENT(out):: err_msg
553 INTEGER,
OPTIONAL,
INTENT(in) :: area
554 INTEGER,
OPTIONAL,
INTENT(in) :: volume
555 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: realm
557 IF (
PRESENT(err_msg) ) err_msg =
''
559 IF (
PRESENT(init_time) )
THEN
561 & (/null_axis_id/), init_time,long_name, units, missing_value, range, &
562 & standard_name=standard_name, do_not_log=do_not_log, err_msg=err_msg,&
563 & area=area, volume=volume, realm=realm)
566 & (/null_axis_id/),long_name, units, missing_value, range,&
567 & standard_name=standard_name, do_not_log=do_not_log, realm=realm)
574 & long_name, units, missing_value, range, mask_variant, standard_name, verbose,&
575 & do_not_log, err_msg, interp_method, tile_count, area, volume, realm)
576 CHARACTER(len=*),
INTENT(in) :: module_name, field_name
577 INTEGER,
INTENT(in) :: axes(:)
579 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: long_name, units, standard_name
580 CLASS(*),
OPTIONAL,
INTENT(in) :: missing_value
581 CLASS(*),
DIMENSION(:),
OPTIONAL,
INTENT(in) :: range
582 LOGICAL,
OPTIONAL,
INTENT(in) :: mask_variant,verbose
583 LOGICAL,
OPTIONAL,
INTENT(in) :: do_not_log
584 CHARACTER(len=*),
OPTIONAL,
INTENT(out):: err_msg
585 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: interp_method
589 INTEGER,
OPTIONAL,
INTENT(in) :: tile_count
590 INTEGER,
OPTIONAL,
INTENT(in) :: area
591 INTEGER,
OPTIONAL,
INTENT(in) :: volume
592 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: realm
594 INTEGER :: field, j, ind, file_num, freq
595 INTEGER :: output_units
596 INTEGER :: stdout_unit
597 LOGICAL :: mask_variant1, verbose1
598 CHARACTER(len=128) :: msg
604 IF (
PRESENT(mask_variant) )
THEN
605 mask_variant1 = mask_variant
607 mask_variant1 = .false.
610 IF (
PRESENT(verbose) )
THEN
616 IF (
PRESENT(err_msg) ) err_msg =
''
619 IF (
PRESENT(range) )
THEN
620 IF (
SIZE(range) .NE. 2 )
THEN
622 CALL error_mesg (
'diag_manager_mod::register_diag_field',
'extent of range should be 2', fatal)
628 & long_name, units, missing_value, range, mask_variant1, standard_name=standard_name,&
629 & dynamic=.true., do_not_log=do_not_log, interp_method=interp_method, tile_count=tile_count, realm=realm)
631 IF ( .NOT.first_send_data_call )
THEN
636 IF (
mpp_pe() == mpp_root_pe() ) &
637 &
CALL error_mesg (
'diag_manager_mod::register_diag_field',
'module/output_field '&
638 &//trim(module_name)//
'/'// trim(field_name)//&
639 &
' registered AFTER first send_data call, TOO LATE', warning)
646 IF ( debug_diag_manager .OR. verbose1 )
THEN
647 IF (
mpp_pe() == mpp_root_pe() ) &
648 &
CALL error_mesg (
'diag_manager_mod::register_diag_field',
'module/output_field '&
649 &//trim(module_name)//
'/'// trim(field_name)//
' NOT found in diag_table',&
658 IF (
PRESENT(volume).AND.
PRESENT(area) )
THEN
659 IF ( area.EQ.volume )
THEN
660 IF (
PRESENT(err_msg))
THEN
661 err_msg =
'diag_manager_mod::register_diag_field: module/output_field '&
662 &//trim(module_name)//
'/'// trim(field_name)//
' AREA and VOLUME CANNOT be the same variable.&
663 & Contact the developers.'
667 CALL error_mesg (
'diag_manager_mod::register_diag_field',
'module/output_field '&
668 &//trim(module_name)//
'/'// trim(field_name)//
' AREA and VOLUME CANNOT be the same variable.&
669 & Contact the developers.',&
676 IF (
PRESENT(area) )
THEN
678 IF (
PRESENT(err_msg))
THEN
679 err_msg =
'diag_manager_mod::register_diag_field: module/output_field '&
680 &//trim(module_name)//
'/'// trim(field_name)//
' AREA measures field NOT found in diag_table.&
681 & Contact the model liaison.'
685 CALL error_mesg (
'diag_manager_mod::register_diag_field',
'module/output_field '&
686 &//trim(module_name)//
'/'// trim(field_name)//
' AREA measures field NOT found in diag_table.&
687 & Contact the model liaison.',&
692 IF (
PRESENT(volume) )
THEN
693 IF ( volume < 0 )
THEN
694 IF (
PRESENT(err_msg))
THEN
695 err_msg =
'diag_manager_mod::register_diag_field: module/output_field '&
696 &//trim(module_name)//
'/'// trim(field_name)//
' VOLUME measures field NOT found in diag_table.&
697 & Contact the model liaison.'
701 CALL error_mesg (
'diag_manager_mod::register_diag_field',
'module/output_field '&
702 &//trim(module_name)//
'/'// trim(field_name)//
' VOLUME measures field NOT found in diag_table.&
703 & Contact the model liaison.',&
709 IF (
PRESENT(standard_name) ) input_fields(field)%standard_name = standard_name
711 DO j = 1, input_fields(field)%num_output_fields
712 ind = input_fields(field)%output_fields(j)
713 output_fields(ind)%static = .false.
716 file_num = output_fields(ind)%output_file
717 IF ( file_num == max_files ) cycle
718 IF ( output_fields(ind)%local_output )
THEN
719 IF ( output_fields(ind)%need_compute)
THEN
720 files(file_num)%local = .true.
728 IF ( msg /=
'' )
THEN
729 IF (
fms_error_handler(
'diag_manager_mod::register_diag_field', trim(msg), err_msg) )
RETURN
732 freq = files(file_num)%output_freq
734 output_units = files(file_num)%output_units
735 output_fields(ind)%last_output = diag_file_init_time
736 output_fields(ind)%next_output = diag_time_inc(diag_file_init_time, freq, output_units, err_msg=msg)
737 IF ( msg /=
'' )
THEN
739 &
' file='//trim(files(file_num)%name)//
': '//trim(msg),err_msg))
RETURN
741 output_fields(ind)%next_next_output = &
742 & diag_time_inc(output_fields(ind)%next_output, freq, output_units, err_msg=msg)
743 IF ( msg /=
'' )
THEN
745 &
' file='//trim(files(file_num)%name)//
': '//trim(msg),err_msg) )
RETURN
747 IF ( debug_diag_manager .AND.
mpp_pe() == mpp_root_pe() .AND. output_fields(ind)%local_output )
THEN
748 WRITE (msg,
'(" lon(",F5.1,", ",F5.1,"), lat(",F5.1,", ",F5.1,"), dep(",F5.1,", ",F5.1,")")') &
749 & output_fields(ind)%output_grid%start(1),output_fields(ind)%output_grid%end(1),&
750 & output_fields(ind)%output_grid%start(2),output_fields(ind)%output_grid%end(2),&
751 & output_fields(ind)%output_grid%start(3),output_fields(ind)%output_grid%end(3)
752 WRITE(stdout_unit,* )
'module/output_field '//trim(module_name)//
'/'//trim(field_name)// &
753 &
' will be output in region:'//trim(msg)
758 IF ( len_trim(err_msg).GT.0 )
THEN
759 CALL error_mesg (
'diag_manager_mod::register_diag_field',&
760 & trim(err_msg)//
' for module/field '//trim(module_name)//
'/'//trim(field_name),&
771 & missing_value, range, mask_variant, standard_name, DYNAMIC, do_not_log, interp_method,&
772 & tile_count, area, volume, realm)
773 CHARACTER(len=*),
INTENT(in) :: module_name, field_name
774 INTEGER,
DIMENSION(:),
INTENT(in) :: axes
775 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: long_name, units, standard_name
776 CLASS(*),
OPTIONAL,
INTENT(in) :: missing_value
777 CLASS(*),
DIMENSION(:),
OPTIONAL,
INTENT(in) :: range
778 LOGICAL,
OPTIONAL,
INTENT(in) :: mask_variant
779 LOGICAL,
OPTIONAL,
INTENT(in) :: dynamic
780 LOGICAL,
OPTIONAL,
INTENT(in) :: do_not_log
781 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: interp_method
785 INTEGER,
OPTIONAL,
INTENT(in) :: tile_count
786 INTEGER,
OPTIONAL,
INTENT(in) :: area
787 INTEGER,
OPTIONAL,
INTENT(in) :: volume
788 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: realm
790 REAL :: missing_value_use
791 REAL,
DIMENSION(2) :: range_use
792 INTEGER :: field, num_axes, j, out_num, k
793 INTEGER,
DIMENSION(3) :: siz, local_siz, local_start, local_end
794 INTEGER :: tile, file_num
795 LOGICAL :: mask_variant1, dynamic1, allow_log
796 CHARACTER(len=128) :: msg
797 INTEGER :: domain_type, i
798 character(len=256) :: axis_name
801 IF ( .NOT.module_is_initialized )
THEN
803 CALL error_mesg (
'diag_manager_mod::register_static_field_old',
'diag_manager has NOT been initialized', fatal)
807 IF (
PRESENT(missing_value) )
THEN
809 missing_value_use = cmor_missing_value
811 SELECT TYPE (missing_value)
812 TYPE IS (real(kind=r4_kind))
813 missing_value_use = missing_value
814 TYPE IS (real(kind=r8_kind))
815 missing_value_use = real(missing_value)
817 CALL error_mesg (
'diag_manager_mod::register_static_field',&
818 &
'The missing_value is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
823 IF (
PRESENT(mask_variant) )
THEN
824 mask_variant1 = mask_variant
826 mask_variant1 = .false.
829 IF (
PRESENT(dynamic) )
THEN
835 IF (
PRESENT(tile_count) )
THEN
841 IF (
PRESENT(do_not_log) )
THEN
842 allow_log = .NOT.do_not_log
848 IF (
PRESENT(range) )
THEN
849 IF (
SIZE(range) .NE. 2 )
THEN
851 CALL error_mesg (
'diag_manager_mod::register_static_field',
'extent of range should be 2', fatal)
857 IF ( do_diag_field_log.AND.allow_log )
THEN
859 & long_name, units, missing_value=missing_value, range=range, &
869 domain_type = axis_compatible_check(axes,field_name)
872 IF ( .NOT.input_fields(field)%register )
THEN
877 CALL error_mesg (
'diag_manager_mod::register_diag_field',
'module/output_field '//trim(module_name)//
'/'//&
878 & trim(field_name)//
' is not registered for tile_count = 1, should not register for tile_count > 1',&
884 DO j = 1, input_fields(field)%num_output_fields
885 out_num = input_fields(field)%output_fields(j)
886 file_num = output_fields(out_num)%output_file
887 IF(input_fields(field)%local)
THEN
888 CALL init_output_field(module_name, field_name,output_fields(out_num)%output_name,&
889 & files(file_num)%name,output_fields(out_num)%time_method, output_fields(out_num)%pack,&
890 & tile, input_fields(field)%local_coord)
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, tile)
903 input_fields(field)%static = .true.
905 IF ( input_fields(field)%register .AND.
mpp_pe() == mpp_root_pe() )
THEN
910 CALL error_mesg (
'diag_manager_mod::register_diag_field',
'module/output_field '//trim(module_name)//
'/'//&
911 & trim(field_name)//
' ALREADY registered, should not register twice', fatal)
915 IF (
PRESENT(volume).AND.
PRESENT(area) )
THEN
916 IF ( area.EQ.volume )
THEN
917 CALL error_mesg (
'diag_manager_mod::register_static_field_old',
'module/output_field '&
918 &//trim(module_name)//
'/'// trim(field_name)//
' AREA and VOLUME CANNOT be the same variable.&
919 & Contact the developers.',&
925 IF (
PRESENT(area) )
THEN
927 CALL error_mesg (
'diag_manager_mod::register_static_field_old',
'module/output_field '&
928 &//trim(module_name)//
'/'// trim(field_name)//
' AREA measures field NOT found in diag_table.&
929 & Contact the model liaison.n',&
933 IF (
PRESENT(volume) )
THEN
934 IF ( volume < 0 )
THEN
935 CALL error_mesg (
'diag_manager_mod::register_static_field_old',
'module/output_field '&
936 &//trim(module_name)//
'/'// trim(field_name)//
' VOLUME measures field NOT found in diag_table&
937 & Contact the model liaison.',&
943 input_fields(field)%register = .true.
945 input_fields(field)%mask_variant = mask_variant1
947 input_fields(field)%issued_mask_ignore_warning = .false.
950 IF (
PRESENT(long_name) )
THEN
951 input_fields(field)%long_name = trim(long_name)
953 input_fields(field)%long_name = input_fields(field)%field_name
956 IF (
PRESENT(standard_name) ) input_fields(field)%standard_name = standard_name
958 IF (
PRESENT(units) )
THEN
959 input_fields(field)%units = trim(units)
961 input_fields(field)%units =
'none'
964 IF (
PRESENT(missing_value) )
THEN
965 input_fields(field)%missing_value = missing_value_use
966 input_fields(field)%missing_value_present = .true.
968 input_fields(field)%missing_value_present = .false.
971 IF (
PRESENT(range) )
THEN
973 TYPE IS (real(kind=r4_kind))
975 TYPE IS (real(kind=r8_kind))
976 range_use = real(range)
978 CALL error_mesg (
'diag_manager_mod::register_static_field',&
979 &
'The range is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
981 input_fields(field)%range = range_use
983 input_fields(field)%range_present = range_use(2) .gt. range_use(1)
985 input_fields(field)%range = (/ 1., 0. /)
986 input_fields(field)%range_present = .false.
989 IF (
PRESENT(interp_method) )
THEN
990 IF ( trim(interp_method) .NE.
'conserve_order1' .AND.&
991 & trim(interp_method) .NE.
'conserve_order2' .AND.&
992 & trim(interp_method) .NE.
'none' )
THEN
998 CALL error_mesg (
'diag_manager_mod::register_diag_field',&
999 &
'when registering module/output_field '//trim(module_name)//
'/'//&
1000 & trim(field_name)//
', the optional argument interp_method = '//trim(interp_method)//&
1001 &
', but it should be "conserve_order1", "conserve_order2", or "none"', fatal)
1003 input_fields(field)%interp_method = trim(interp_method)
1005 input_fields(field)%interp_method =
''
1009 num_axes =
SIZE(axes(:))
1010 input_fields(field)%axes(1:num_axes) = axes
1011 input_fields(field)%num_axes = num_axes
1015 IF ( axes(j) .LE. 0 )
THEN
1019 CALL error_mesg (
'diag_manager_mod::register_diag_field',
'module/output_field '//trim(module_name)//
'/'//&
1020 & trim(field_name)//
' has non-positive axis_id', fatal)
1022 siz(j) = get_axis_length(axes(j))
1027 input_fields(field)%size(j) = siz(j)
1034 DO j = 1, input_fields(field)%num_output_fields
1035 out_num = input_fields(field)%output_fields(j)
1037 IF ( output_fields(out_num)%pack>=4 .AND. .NOT.input_fields(field)%range_present )
THEN
1038 IF(
mpp_pe() .EQ. mpp_root_pe())
THEN
1042 CALL error_mesg (
'diag_manager_mod::register_diag_field ',
'output_field '//trim(field_name)// &
1043 ' has pack >=4, range is REQUIRED in register_diag_field', fatal)
1048 IF ( .NOT.dynamic1 ) output_fields(out_num)%n_diurnal_samples = 1
1052 file_num = output_fields(out_num)%output_file
1053 if (domain_type .eq. diag_axis_2ddomain)
then
1054 if (files(file_num)%use_domainUG)
then
1055 call error_mesg(
"diag_manager_mod::register_static_field_old", &
1056 "Diagnostics living on a structured grid" &
1057 //
" and an unstructured grid cannot exist" &
1058 //
" in the same file (" &
1059 //trim(files(file_num)%name)//
")", &
1061 elseif (.not. files(file_num)%use_domain2D)
then
1062 files(file_num)%use_domain2D = .true.
1065 if (files(file_num)%use_domain2D)
then
1066 call error_mesg(
"diag_manager_mod::register_static_field_old", &
1067 "Diagnostics living on a structured grid" &
1068 //
" and an unstructured grid cannot exist" &
1069 //
" in the same file (" &
1070 //trim(files(file_num)%name)//
")", &
1072 elseif (.not. files(file_num)%use_domainUG)
then
1073 files(file_num)%use_domainUG = .true.
1079 IF ( output_fields(out_num)%reduced_k_range )
THEN
1088 local_start(2) = output_fields(out_num)%output_grid%l_start_indx(2)
1089 local_end(2) = output_fields(out_num)%output_grid%l_end_indx(2)
1090 local_siz(2) = local_end(2) - local_start(2) + 1
1091 allocate(output_fields(out_num)%buffer(siz(1),local_siz(2),siz(3), &
1092 output_fields(out_num)%n_diurnal_samples))
1093 output_fields(out_num)%region_elements = siz(1)*local_siz(2)*siz(3)
1094 output_fields(out_num)%reduced_k_unstruct = .true.
1096 local_start(3) = output_fields(out_num)%output_grid%l_start_indx(3)
1097 local_end(3) = output_fields(out_num)%output_grid%l_end_indx(3)
1098 local_siz(3) = local_end(3) - local_start(3) + 1
1099 allocate(output_fields(out_num)%buffer(siz(1),siz(2),local_siz(3), &
1100 output_fields(out_num)%n_diurnal_samples))
1101 output_fields(out_num)%region_elements = siz(1)*siz(2)*local_siz(3)
1102 output_fields(out_num)%reduced_k_unstruct = .false.
1104 output_fields(out_num)%total_elements = siz(1)*siz(2)*siz(3)
1107 IF ( output_fields(out_num)%time_max )
THEN
1108 output_fields(out_num)%buffer = max_value
1109 ELSE IF ( output_fields(out_num)%time_min )
THEN
1110 output_fields(out_num)%buffer = min_value
1112 output_fields(out_num)%buffer = empty
1114 ELSE IF ( output_fields(out_num)%local_output )
THEN
1115 IF (
SIZE(axes(:)) .LE. 1 )
THEN
1117 CALL error_mesg (
'diag_manager_mod::register_diag_field',
'axes of '//trim(field_name)//&
1118 &
' must >= 2 for local output', fatal)
1121 IF ( output_fields(out_num)%need_compute )
THEN
1123 local_start(k) = output_fields(out_num)%output_grid%l_start_indx(k)
1124 local_end(k) = output_fields(out_num)%output_grid%l_end_indx(k)
1125 local_siz(k) = local_end(k) - local_start(k) +1
1127 ALLOCATE(output_fields(out_num)%buffer(local_siz(1), local_siz(2), local_siz(3),&
1128 & output_fields(out_num)%n_diurnal_samples))
1129 IF(output_fields(out_num)%time_max)
THEN
1130 output_fields(out_num)%buffer = max_value
1131 ELSE IF(output_fields(out_num)%time_min)
THEN
1132 output_fields(out_num)%buffer = min_value
1134 output_fields(out_num)%buffer = empty
1136 output_fields(out_num)%region_elements = local_siz(1)*local_siz(2)*local_siz(3)
1137 output_fields(out_num)%total_elements = siz(1)*siz(2)*siz(3)
1138 files(output_fields(out_num)%output_file)%local = .true.
1142 ALLOCATE(output_fields(out_num)%buffer(siz(1), siz(2), siz(3),&
1143 & output_fields(out_num)%n_diurnal_samples))
1144 IF(output_fields(out_num)%time_max)
THEN
1145 output_fields(out_num)%buffer = max_value
1146 ELSE IF(output_fields(out_num)%time_min)
THEN
1147 output_fields(out_num)%buffer = min_value
1149 output_fields(out_num)%buffer = empty
1151 output_fields(out_num)%total_elements = siz(1)*siz(2)*siz(3)
1155 output_fields(out_num)%static = .true.
1157 IF ( .NOT.dynamic1 .AND. output_fields(out_num)%time_ops )
THEN
1158 WRITE (msg,
'(a,"/",a)') trim(module_name), trim(field_name)
1159 IF (
mpp_pe() .EQ. mpp_root_pe() )
THEN
1166 CALL error_mesg (
'diag_manager_mod::register_static_field_old',&
1167 &
'module/field '//trim(msg)//
' is STATIC. Cannot perform time operations&
1168 & average, maximum, or minimum on static fields. Setting the time operation&
1169 & to "NONE" for this field.', warning)
1171 output_fields(out_num)%time_ops = .false.
1172 output_fields(out_num)%time_average = .false.
1173 output_fields(out_num)%time_method =
'point'
1178 output_fields(out_num)%num_axes = input_fields(field)%num_axes
1180 IF ( .NOT.output_fields(out_num)%local_output )
THEN
1181 output_fields(out_num)%axes(1:input_fields(field)%num_axes) =&
1182 & input_fields(field)%axes(1:input_fields(field)%num_axes)
1184 output_fields(out_num)%axes(1:input_fields(field)%num_axes) =&
1185 & output_fields(out_num)%output_grid%subaxes(1:input_fields(field)%num_axes)
1190 IF ( output_fields(out_num)%n_diurnal_samples > 1 )
THEN
1191 output_fields(out_num)%axes(output_fields(out_num)%num_axes+1) =&
1193 output_fields(out_num)%num_axes = output_fields(out_num)%num_axes+1
1196 IF ( output_fields(out_num)%reduced_k_range )
THEN
1200 output_fields(out_num)%axes(2) = output_fields(out_num)%output_grid%subaxes(2)
1202 output_fields(out_num)%axes(3) = output_fields(out_num)%output_grid%subaxes(3)
1208 output_fields(out_num)%Time_of_prev_field_data = time_zero
1212 IF ( len_trim(msg).GT.0 )
THEN
1213 CALL error_mesg (
'diag_manager_mod::register_static_field_old',&
1214 & trim(msg)//
' for module/field '//trim(module_name)//
'/'//trim(field_name),&
1219 IF (
PRESENT(realm) )
THEN
1220 CALL prepend_attribute(output_fields(out_num),
'modeling_realm', lowercase(trim(realm)))
1224 IF ( input_fields(field)%mask_variant )
THEN
1225 DO j = 1, input_fields(field)%num_output_fields
1226 out_num = input_fields(field)%output_fields(j)
1227 IF(output_fields(out_num)%time_average)
THEN
1233 if (output_fields(out_num)%reduced_k_range .and. &
1235 allocate(output_fields(out_num)%counter(siz(1),local_siz(2),siz(3), &
1236 output_fields(out_num)%n_diurnal_samples))
1238 allocate(output_fields(out_num)%counter(siz(1),siz(2),siz(3), &
1239 output_fields(out_num)%n_diurnal_samples))
1242 output_fields(out_num)%counter = 0.0
1253 CHARACTER(len=*),
INTENT(in) :: module_name
1254 CHARACTER(len=*),
INTENT(in) :: field_name
1259 if (use_modern_diag)
then
1260 get_diag_field_id = fms_diag_object%fms_get_diag_field_id_from_name(module_name, field_name)
1271 INTEGER,
INTENT(in) :: field
1273 INTEGER,
INTENT(out) :: out_field_id
1274 INTEGER,
INTENT(out) :: out_file_id
1276 INTEGER :: i, cm_ind, cm_file_num
1280 rel_file = rel_field%output_file
1288 DO i = 1, input_fields(field)%num_output_fields
1289 cm_ind = input_fields(field)%output_fields(i)
1290 cm_file_num = output_fields(cm_ind)%output_file
1292 IF ( cm_file_num.EQ.rel_file.AND.&
1293 & (( (output_fields(cm_ind)%time_ops.EQV.rel_field%time_ops) .AND.&
1294 & (output_fields(cm_ind)%next_output.EQ.rel_field%next_output) .AND.&
1295 & (output_fields(cm_ind)%last_output.EQ.rel_field%last_output) ).OR.&
1296 & (output_fields(cm_ind)%static.OR.rel_field%static) ) )
THEN
1298 out_field_id = cm_ind
1299 out_file_id = cm_file_num
1306 DO i = 1, input_fields(field)%num_output_fields
1307 cm_ind = input_fields(field)%output_fields(i)
1308 cm_file_num = output_fields(cm_ind)%output_file
1319 IF ( output_fields(cm_ind)%static.OR.rel_field%static )
THEN
1321 out_field_id = cm_ind
1322 out_file_id = cm_file_num
1332 INTEGER,
INTENT(in),
OPTIONAL :: area
1333 INTEGER,
INTENT(in),
OPTIONAL :: volume
1334 CHARACTER(len=*),
INTENT(out),
OPTIONAL :: err_msg
1336 INTEGER :: cm_ind, cm_file_num, file_num
1338 IF (
PRESENT(err_msg) )
THEN
1343 IF (
PRESENT(area) )
THEN
1344 IF ( area.LE.0 )
THEN
1346 &
'AREA field not in diag_table for field '//trim(input_fields(output_field%input_field)%module_name)//&
1347 &
'/'//trim(input_fields(output_field%input_field)%field_name), err_msg) )
RETURN
1351 IF (
PRESENT(volume) )
THEN
1352 IF ( volume.LE.0 )
THEN
1354 &
'VOLUME field not in diag_table for field '//trim(input_fields(output_field%input_field)%module_name)//&
1355 &
'/'//trim(input_fields(output_field%input_field)%field_name), err_msg) )
RETURN
1360 file_num = output_field%output_file
1363 IF (
PRESENT(area) )
THEN
1366 &
'area: '//trim(output_fields(cm_ind)%output_name))
1367 IF ( cm_file_num.NE.file_num )
THEN
1373 &
'AREA measures field "'//trim(input_fields(area)%module_name)//
'/'//&
1374 & trim(input_fields(area)%field_name)//&
1375 &
'" NOT in diag_table with correct output frequency for field '//&
1376 & trim(input_fields(output_field%input_field)%module_name)//&
1377 &
'/'//trim(input_fields(output_field%input_field)%field_name), err_msg) )
RETURN
1382 IF (
PRESENT(volume) )
THEN
1385 &
'volume: '//trim(output_fields(cm_ind)%output_name))
1386 IF ( cm_file_num.NE.file_num )
THEN
1392 &
'VOLUME measures field "'//trim(input_fields(volume)%module_name)//
'/'//&
1393 & trim(input_fields(volume)%field_name)//&
1394 &
'" NOT in diag_table with correct output frequency for field '//&
1395 & trim(input_fields(output_field%input_field)%module_name)//&
1396 &
'/'//trim(input_fields(output_field%input_field)%field_name), err_msg) )
RETURN
1407 INTEGER,
intent(in) :: file_num
1408 INTEGER,
intent(in) :: cm_file_num
1409 INTEGER,
intent(in) :: cm_ind
1411 INTEGER :: year, month, day, hour, minute, second
1413 CHARACTER(len=25) :: date_prefix
1414 CHARACTER(len=FMS_FILE_LEN) :: asso_file_name
1417 IF ( prepend_date )
THEN
1418 CALL get_date(diag_init_time, year, month, day, hour, minute, second)
1419 WRITE (date_prefix,
'(1I20.4, 2I2.2,".")') year, month, day
1420 date_prefix=adjustl(date_prefix)
1428 IF ( len_trim(files(cm_file_num)%name)+17 > len(asso_file_name) )
THEN
1429 CALL error_mesg (
'diag_manager_mod::add_associated_files',&
1430 &
'Length of asso_file_name is not long enough to hold the associated file name. '&
1431 & //
'Contact the developer', fatal)
1433 asso_file_name = trim(files(cm_file_num)%name)
1444 n = max(len_trim(asso_file_name),3)
1445 if (asso_file_name(n-2:n).NE.
'.nc') asso_file_name = trim(asso_file_name)//
'.nc'
1449 & trim(output_fields(cm_ind)%output_name)//
': '//&
1450 & trim(date_prefix)//trim(asso_file_name))
1455 INTEGER,
INTENT(in) :: diag_field_id
1456 CLASS(*),
INTENT(in) :: field
1457 TYPE(
time_type),
INTENT(in),
OPTIONAL :: time
1458 CHARACTER(len=*),
INTENT(out),
OPTIONAL :: err_msg
1460 CLASS(*),
allocatable :: field_out(:, :, :)
1463 IF ( diag_field_id <= 0 )
THEN
1470 TYPE IS (real(kind=r4_kind))
1471 allocate(real(r4_kind) :: field_out(1,1,1))
1472 select type(field_out)
1473 type is (real(r4_kind))
1474 field_out(1, 1, 1) = field
1476 call error_mesg(
'diag_manager_mod::send_data_0d', &
1477 &
'Error allocating field out as real(r4_kind)', fatal)
1479 TYPE IS (real(kind=r8_kind))
1480 allocate(real(r8_kind) :: field_out(1,1,1))
1481 select type(field_out)
1482 type is (real(r8_kind))
1483 field_out(1, 1, 1) = field
1485 call error_mesg(
'diag_manager_mod::send_data_0d', &
1486 &
'Error allocating field out as real(r8_kind)', fatal)
1489 CALL error_mesg (
'diag_manager_mod::send_data_0d',&
1490 &
'The field is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
1497 LOGICAL FUNCTION send_data_1d(diag_field_id, field, time, is_in, mask, rmask, ie_in, weight, err_msg)
1498 INTEGER,
INTENT(in) :: diag_field_id
1499 CLASS(*),
DIMENSION(:),
INTENT(in) :: field
1500 CLASS(*),
INTENT(in),
OPTIONAL :: weight
1501 CLASS(*),
INTENT(in),
DIMENSION(:),
OPTIONAL :: rmask
1502 TYPE (
time_type),
INTENT(in),
OPTIONAL :: time
1503 INTEGER,
INTENT(in),
OPTIONAL :: is_in, ie_in
1504 LOGICAL,
INTENT(in),
DIMENSION(:),
OPTIONAL :: mask
1505 CHARACTER(len=*),
INTENT(out),
OPTIONAL :: err_msg
1507 CLASS(*),
ALLOCATABLE :: field_out(:,:,:)
1508 LOGICAL,
DIMENSION(SIZE(field(:)), 1, 1) :: mask_out
1511 IF ( diag_field_id <= 0 )
THEN
1519 TYPE IS (real(kind=r4_kind))
1520 allocate(real(r4_kind) :: field_out(
SIZE(field),1,1))
1521 select type(field_out)
1522 type is (real(r4_kind))
1523 field_out(:, 1, 1) = field
1525 call error_mesg(
'diag_manager_mod::send_data_1d', &
1526 &
'Error allocating field out as real(r4_kind)', fatal)
1528 TYPE IS (real(kind=r8_kind))
1529 allocate(real(r8_kind) :: field_out(
SIZE(field),1,1))
1530 select type(field_out)
1531 type is (real(r8_kind))
1532 field_out(:, 1, 1) = field
1534 call error_mesg(
'diag_manager_mod::send_data_1d', &
1535 &
'Error allocating field out as real(r8_kind)', fatal)
1538 CALL error_mesg (
'diag_manager_mod::send_data_1d',&
1539 &
'The field is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
1543 IF (
PRESENT(mask) )
THEN
1544 mask_out(:, 1, 1) = mask
1549 IF (
PRESENT(rmask) )
THEN
1551 TYPE IS (real(kind=r4_kind))
1552 WHERE (rmask < 0.5_r4_kind) mask_out(:, 1, 1) = .false.
1553 TYPE IS (real(kind=r8_kind))
1554 WHERE (rmask < 0.5_r8_kind) mask_out(:, 1, 1) = .false.
1556 CALL error_mesg (
'diag_manager_mod::send_data_1d',&
1557 &
'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
1561 IF (
PRESENT(mask) .OR.
PRESENT(rmask) )
THEN
1562 IF (
PRESENT(is_in) .OR.
PRESENT(ie_in) )
THEN
1564 & mask=mask_out, ie_in=ie_in, je_in=1, ke_in=1, weight=weight, err_msg=err_msg)
1567 & weight=weight, err_msg=err_msg)
1570 IF (
PRESENT(is_in) .OR.
PRESENT(ie_in) )
THEN
1572 & ie_in=ie_in, je_in=1, ke_in=1, weight=weight, err_msg=err_msg)
1581 & mask, rmask, ie_in, je_in, weight, err_msg)
1582 INTEGER,
INTENT(in) :: diag_field_id
1583 CLASS(*),
INTENT(in),
DIMENSION(:,:) :: field
1584 CLASS(*),
INTENT(in),
OPTIONAL :: weight
1585 TYPE (
time_type),
INTENT(in),
OPTIONAL :: time
1586 INTEGER,
INTENT(in),
OPTIONAL :: is_in, js_in, ie_in, je_in
1587 LOGICAL,
INTENT(in),
DIMENSION(:,:),
OPTIONAL :: mask
1588 CLASS(*),
INTENT(in),
DIMENSION(:,:),
OPTIONAL :: rmask
1589 CHARACTER(len=*),
INTENT(out),
OPTIONAL :: err_msg
1591 CLASS(*),
ALLOCATABLE :: field_out(:,:,:)
1592 LOGICAL,
DIMENSION(SIZE(field,1),SIZE(field,2),1) :: mask_out
1595 IF ( diag_field_id <= 0 )
THEN
1602 TYPE IS (real(kind=r4_kind))
1603 allocate(real(r4_kind) :: field_out(
SIZE(field,1),
SIZE(field,2),1))
1604 select type(field_out)
1605 type is (real(r4_kind))
1606 field_out(:, :, 1) = field
1608 call error_mesg(
'diag_manager_mod::send_data_2d', &
1609 &
'Error allocating field out as real(r4_kind)', fatal)
1611 TYPE IS (real(kind=r8_kind))
1612 allocate(real(r8_kind) :: field_out(
SIZE(field,1),
SIZE(field,2),1))
1613 select type(field_out)
1614 type is (real(r8_kind))
1615 field_out(:, :, 1) = field
1617 call error_mesg(
'diag_manager_mod::send_data_2d', &
1618 &
'Error allocating field out as real(r8_kind)', fatal)
1621 CALL error_mesg (
'diag_manager_mod::send_data_2d',&
1622 &
'The field is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
1626 IF (
PRESENT(mask) )
THEN
1627 mask_out(:, :, 1) = mask
1632 IF (
PRESENT(rmask) )
THEN
1634 TYPE IS (real(kind=r4_kind))
1635 WHERE ( rmask < 0.5_r4_kind ) mask_out(:, :, 1) = .false.
1636 TYPE IS (real(kind=r8_kind))
1637 WHERE ( rmask < 0.5_r8_kind ) mask_out(:, :, 1) = .false.
1639 CALL error_mesg (
'diag_manager_mod::send_data_2d',&
1640 &
'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
1644 IF (
PRESENT(mask) .OR.
PRESENT(rmask) )
THEN
1646 & mask=mask_out, ie_in=ie_in, je_in=je_in, ke_in=1, weight=weight, err_msg=err_msg)
1649 & ie_in=ie_in, je_in=je_in, ke_in=1, weight=weight, err_msg=err_msg)
1654 LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
1655 & mask, rmask, ie_in, je_in, ke_in, weight, err_msg)
1656 INTEGER,
INTENT(in) :: diag_field_id
1657 CLASS(*),
DIMENSION(:,:,:),
INTENT(in) :: field
1658 CLASS(*),
INTENT(in),
OPTIONAL :: weight
1659 TYPE (
time_type),
INTENT(in),
OPTIONAL :: time
1660 INTEGER,
INTENT(in),
OPTIONAL :: is_in, js_in, ks_in,ie_in,je_in, ke_in
1661 LOGICAL,
DIMENSION(:,:,:),
INTENT(in),
OPTIONAL :: mask
1662 CLASS(*),
DIMENSION(:,:,:),
INTENT(in),
OPTIONAL :: rmask
1663 CHARACTER(len=*),
INTENT(out),
OPTIONAL :: err_msg
1665 if (
present(mask) .and.
present(rmask))
then
1667 mask=mask, rmask=rmask, ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, &
1669 elseif (
present(rmask))
then
1671 rmask=rmask, ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, err_msg=err_msg)
1672 elseif (
present(mask))
then
1674 mask=mask, ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, err_msg=err_msg)
1677 ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, err_msg=err_msg)
1684 & mask, rmask, ie_in, je_in, ke_in, weight, err_msg)
1685 INTEGER,
INTENT(in) :: diag_field_id
1686 CLASS(*),
DIMENSION(:,:,:),
INTENT(in),
TARGET,
CONTIGUOUS :: field
1687 CLASS(*),
INTENT(in),
OPTIONAL :: weight
1688 TYPE (
time_type),
INTENT(in),
OPTIONAL :: time
1689 INTEGER,
INTENT(in),
OPTIONAL :: is_in, js_in, ks_in,ie_in,je_in, ke_in
1690 LOGICAL,
DIMENSION(:,:,:),
INTENT(in),
OPTIONAL,
contiguous,
target :: mask
1691 CLASS(*),
DIMENSION(:,:,:),
INTENT(in),
OPTIONAL,
contiguous,
target :: rmask
1692 CHARACTER(len=*),
INTENT(out),
OPTIONAL :: err_msg
1696 INTEGER :: pow_value
1698 INTEGER :: i, out_num, file_num, n1, n2, n3, number_of_outputs, ii,f1,f2,f3,f4
1699 INTEGER :: freq, units, is, js, ks, ie, je, ke, i1, j1,k1, j, k
1700 INTEGER,
DIMENSION(3) :: l_start
1701 INTEGER,
DIMENSION(3) :: l_end
1711 INTEGER :: numthreads
1712 INTEGER :: active_omp_level
1713 #if defined(_OPENMP)
1714 INTEGER :: omp_get_num_threads
1715 INTEGER :: omp_get_level
1717 LOGICAL :: average, phys_window, need_compute
1718 LOGICAL :: reduced_k_range, local_output
1719 LOGICAL :: time_max, time_min, time_rms, time_sum
1720 LOGICAL :: missvalue_present
1721 LOGICAL,
ALLOCATABLE,
DIMENSION(:,:,:) :: oor_mask
1722 CHARACTER(len=256) :: err_msg_local
1723 CHARACTER(len=128) :: error_string, error_string1
1725 REAL,
ALLOCATABLE,
DIMENSION(:,:,:) :: field_out
1726 class(*),
allocatable,
dimension(:,:,:,:) :: field_remap
1727 logical,
allocatable,
dimension(:,:,:,:) :: mask_remap
1728 class(*),
allocatable,
dimension(:,:,:,:) :: rmask_remap
1729 REAL(kind=r4_kind),
POINTER,
DIMENSION(:,:,:) :: rmask_ptr_r4
1730 REAL(kind=r8_kind),
POINTER,
DIMENSION(:,:,:) :: rmask_ptr_r8
1734 LOGICAL :: mf_result
1736 REAL :: rmask_threshold
1738 character(len=:),
allocatable :: field_name
1741 IF ( diag_field_id <= 0 )
THEN
1748 IF (
PRESENT(err_msg) ) err_msg =
''
1749 IF ( .NOT.module_is_initialized )
THEN
1750 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d',
'diag_manager NOT initialized', err_msg) )
RETURN
1763 ALLOCATE(field_out(
SIZE(field,1),
SIZE(field,2),
SIZE(field,3)), stat=status)
1764 IF ( status .NE. 0 )
THEN
1765 WRITE (err_msg_local, fmt=
'("Unable to allocate field_out(",I5,",",I5,",",I5,"). (STAT: ",I5,")")')&
1766 &
SIZE(field,1),
SIZE(field,2),
SIZE(field,3), status
1767 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
RETURN
1770 TYPE IS (real(kind=r4_kind))
1772 TYPE IS (real(kind=r8_kind))
1773 field_out = real(field)
1775 CALL error_mesg (
'diag_manager_mod::send_data_3d',&
1776 &
'The field is not one of the supported types (real(kind=4) or real(kind=8)). '//&
1777 &
'If using an integer, please set use_modern_diag=.t. in the diag_manager_nml.', fatal)
1780 modern_if:
iF (use_modern_diag)
then
1781 field_name = fms_diag_object%fms_get_field_name_from_id(diag_field_id)
1782 call copy_3d_to_4d(field, field_remap, trim(field_name)//
"'s data")
1783 if (
present(rmask))
call copy_3d_to_4d(rmask, rmask_remap, trim(field_name)//
"'s mask")
1784 if (
present(mask))
then
1785 allocate(mask_remap(1:
size(mask,1), 1:
size(mask,2), 1:
size(mask,3), 1))
1786 mask_remap(:,:,:,1) = mask
1788 call fms_diag_object%fms_diag_accept_data(diag_field_id, field_remap, mask_remap, rmask_remap, &
1789 time, is_in, js_in, ks_in, ie_in, je_in, ke_in, weight, &
1791 deallocate (field_remap)
1792 if (
allocated(mask_remap))
deallocate(mask_remap)
1793 if (
allocated(rmask_remap))
deallocate(rmask_remap)
1796 ALLOCATE(oor_mask(
SIZE(field,1),
SIZE(field,2),
SIZE(field,3)), stat=status)
1797 IF ( status .NE. 0 )
THEN
1798 WRITE (err_msg_local, fmt=
'("Unable to allocate oor_mask(",I5,",",I5,",",I5,"). (STAT: ",I5,")")')&
1799 &
SIZE(field,1),
SIZE(field,2),
SIZE(field,3), status
1800 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
RETURN
1803 IF (
PRESENT(mask) )
THEN
1809 rmask_ptr_r4 => null()
1810 rmask_ptr_r8 => null()
1811 IF (
PRESENT(rmask) )
THEN
1813 TYPE IS (real(kind=r4_kind))
1814 WHERE ( rmask < 0.5_r4_kind ) oor_mask = .false.
1815 rmask_threshold = 0.5_r4_kind
1816 rmask_ptr_r4 => rmask
1817 TYPE IS (real(kind=r8_kind))
1818 WHERE ( rmask < 0.5_r8_kind ) oor_mask = .false.
1819 rmask_threshold = 0.5_r8_kind
1820 rmask_ptr_r8 => rmask
1822 CALL error_mesg (
'diag_manager_mod::send_data_3d',&
1823 &
'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
1838 IF (
PRESENT(ie_in) )
THEN
1839 IF ( .NOT.
PRESENT(is_in) )
THEN
1840 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d',
'ie_in present without is_in', err_msg) )
THEN
1841 DEALLOCATE(field_out)
1842 DEALLOCATE(oor_mask)
1846 IF (
PRESENT(js_in) .AND. .NOT.
PRESENT(je_in) )
THEN
1848 &
'is_in and ie_in present, but js_in present without je_in', err_msg) )
THEN
1849 DEALLOCATE(field_out)
1850 DEALLOCATE(oor_mask)
1855 IF (
PRESENT(je_in) )
THEN
1856 IF ( .NOT.
PRESENT(js_in) )
THEN
1857 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d',
'je_in present without js_in', err_msg) )
THEN
1858 DEALLOCATE(field_out)
1859 DEALLOCATE(oor_mask)
1863 IF (
PRESENT(is_in) .AND. .NOT.
PRESENT(ie_in) )
THEN
1865 &
'js_in and je_in present, but is_in present without ie_in', err_msg))
THEN
1866 DEALLOCATE(field_out)
1867 DEALLOCATE(oor_mask)
1877 IF (
PRESENT(is_in) ) is = is_in
1878 IF (
PRESENT(js_in) ) js = js_in
1879 IF (
PRESENT(ks_in) ) ks = ks_in
1886 IF (
PRESENT(ie_in) ) ie = ie_in
1887 IF (
PRESENT(je_in) ) je = je_in
1888 IF (
PRESENT(ke_in) ) ke = ke_in
1889 twohi = n1-(ie-is+1)
1890 IF ( mod(twohi,2) /= 0 )
THEN
1891 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d',
'non-symmetric halos in first dimension', &
1893 DEALLOCATE(field_out)
1894 DEALLOCATE(oor_mask)
1898 twohj = n2-(je-js+1)
1899 IF ( mod(twohj,2) /= 0 )
THEN
1900 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d',
'non-symmetric halos in second dimension', &
1902 DEALLOCATE(field_out)
1903 DEALLOCATE(oor_mask)
1912 IF (
PRESENT(ie_in) .AND.
PRESENT(je_in) )
THEN
1926 IF (
PRESENT(weight) )
THEN
1927 SELECT TYPE (weight)
1928 TYPE IS (real(kind=r4_kind))
1930 TYPE IS (real(kind=r8_kind))
1931 weight1 = real(weight)
1933 CALL error_mesg (
'diag_manager_mod::send_data_3d',&
1934 &
'The weight is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
1941 missvalue_present = input_fields(diag_field_id)%missing_value_present
1942 IF ( missvalue_present ) missvalue = input_fields(diag_field_id)%missing_value
1944 number_of_outputs = input_fields(diag_field_id)%num_output_fields
1946 input_fields(diag_field_id)%numthreads = 1
1948 #if defined(_OPENMP)
1949 input_fields(diag_field_id)%numthreads = omp_get_num_threads()
1950 input_fields(diag_field_id)%active_omp_level = omp_get_level()
1952 numthreads = input_fields(diag_field_id)%numthreads
1953 active_omp_level = input_fields(diag_field_id)%active_omp_level
1956 if(
present(time)) input_fields(diag_field_id)%time = time
1959 IF ( input_fields(diag_field_id)%range_present )
THEN
1960 IF ( issue_oor_warnings .OR. oor_warnings_fatal )
THEN
1961 WRITE (error_string,
'("[",ES14.5E3,",",ES14.5E3,"]")')&
1962 & input_fields(diag_field_id)%range(1:2)
1963 WRITE (error_string1,
'("(Min: ",ES14.5E3,", Max: ",ES14.5E3, ")")')&
1964 & minval(field_out(f1:f2,f3:f4,ks:ke),mask=oor_mask(f1:f2,f3:f4,ks:ke)),&
1965 & maxval(field_out(f1:f2,f3:f4,ks:ke),mask=oor_mask(f1:f2,f3:f4,ks:ke))
1966 IF ( missvalue_present )
THEN
1967 IF ( any(oor_mask(f1:f2,f3:f4,ks:ke) .AND.&
1968 & ((field_out(f1:f2,f3:f4,ks:ke) < input_fields(diag_field_id)%range(1) .OR.&
1969 & field_out(f1:f2,f3:f4,ks:ke) > input_fields(diag_field_id)%range(2)).AND.&
1970 & field_out(f1:f2,f3:f4,ks:ke) .NE. missvalue)) )
THEN
1976 CALL error_mesg(
'diag_manager_mod::send_data_3d',&
1978 &trim(input_fields(diag_field_id)%module_name)//
' in field '//&
1979 &trim(input_fields(diag_field_id)%field_name)//
' '&
1980 &//trim(error_string1)//&
1981 &
' is outside the range '//trim(error_string)//
',&
1982 & and not equal to the missing value.',&
1986 IF ( any(oor_mask(f1:f2,f3:f4,ks:ke) .AND.&
1987 & (field_out(f1:f2,f3:f4,ks:ke) < input_fields(diag_field_id)%range(1) .OR.&
1988 & field_out(f1:f2,f3:f4,ks:ke) > input_fields(diag_field_id)%range(2))) )
THEN
1993 CALL error_mesg(
'diag_manager_mod::send_data_3d',&
1995 &trim(input_fields(diag_field_id)%module_name)//
' in field '//&
1996 &trim(input_fields(diag_field_id)%field_name)//
' '&
1997 &//trim(error_string1)//&
1998 &
' is outside the range '//trim(error_string)//
'.',&
2006 num_out_fields:
DO ii = 1, number_of_outputs
2008 out_num = input_fields(diag_field_id)%output_fields(ii)
2011 local_output = output_fields(out_num)%local_output
2013 need_compute = output_fields(out_num)%need_compute
2015 reduced_k_range = output_fields(out_num)%reduced_k_range
2018 IF ( local_output .AND. (.NOT.need_compute) ) cycle
2021 file_num = output_fields(out_num)%output_file
2022 IF(file_num == max_files) cycle
2024 freq = files(file_num)%output_freq
2025 units = files(file_num)%output_units
2027 average = output_fields(out_num)%time_average
2030 time_rms = output_fields(out_num)%time_rms
2032 pow_value = output_fields(out_num)%pow_value
2034 time_max = output_fields(out_num)%time_max
2035 time_min = output_fields(out_num)%time_min
2037 time_sum = output_fields(out_num)%time_sum
2038 IF ( output_fields(out_num)%total_elements >
SIZE(field_out(f1:f2,f3:f4,ks:ke)) )
THEN
2039 output_fields(out_num)%phys_window = .true.
2041 output_fields(out_num)%phys_window = .false.
2043 phys_window = output_fields(out_num)%phys_window
2044 IF ( need_compute )
THEN
2045 l_start = output_fields(out_num)%output_grid%l_start_indx
2046 l_end = output_fields(out_num)%output_grid%l_end_indx
2051 IF (
PRESENT(time) )
THEN
2052 CALL get_time(time,second,day,tick)
2054 & * output_fields(out_num)%n_diurnal_samples/seconds_per_day) + 1
2058 IF ( reduced_k_range )
THEN
2061 if (output_fields(out_num)%reduced_k_unstruct)
then
2062 f3 = output_fields(out_num)%output_grid%l_start_indx(2)
2063 f4 = output_fields(out_num)%output_grid%l_end_indx(2)
2067 l_start(3) = output_fields(out_num)%output_grid%l_start_indx(3)
2068 l_end(3) = output_fields(out_num)%output_grid%l_end_indx(3)
2075 IF ( freq == every_time .AND. .NOT.output_fields(out_num)%static )
THEN
2076 IF (
PRESENT(time))
THEN
2077 IF ( numthreads .ne. 1 .or. active_omp_level .gt. 1)
THEN
2081 IF ( time > output_fields(out_num)%last_output )
THEN
2082 output_fields(out_num)%next_output = time
2088 IF ( output_fields(out_num)%next_output == output_fields(out_num)%last_output )
THEN
2089 output_fields(out_num)%next_output = time
2092 ELSE IF ( output_fields(out_num)%next_output == output_fields(out_num)%last_output )
THEN
2093 WRITE (error_string,
'(a,"/",a)')&
2094 & trim(input_fields(diag_field_id)%module_name),&
2095 & trim(output_fields(out_num)%output_name)
2096 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d',
'module/output_field '//trim(error_string)//&
2097 &
', time must be present when output frequency = EVERY_TIME', err_msg))
THEN
2098 DEALLOCATE(field_out)
2099 DEALLOCATE(oor_mask)
2104 IF ( .NOT.output_fields(out_num)%static .AND. .NOT.
PRESENT(time) )
THEN
2105 WRITE (error_string,
'(a,"/",a)')&
2106 & trim(input_fields(diag_field_id)%module_name), &
2107 & trim(output_fields(out_num)%output_name)
2108 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d',
'module/output_field '//trim(error_string)//&
2109 &
', time must be present for nonstatic field', err_msg))
THEN
2110 DEALLOCATE(field_out)
2111 DEALLOCATE(oor_mask)
2119 IF ( (numthreads == 1) .AND. (active_omp_level.LE.1) )
then
2120 IF ( .NOT.output_fields(out_num)%static .AND. freq /= end_of_run )
THEN
2121 IF ( time > output_fields(out_num)%next_output )
THEN
2123 IF ( time > output_fields(out_num)%next_next_output .AND. freq > 0 )
THEN
2124 IF (
mpp_pe() .EQ. mpp_root_pe() )
THEN
2125 WRITE (error_string,
'(a,"/",a)')&
2126 & trim(input_fields(diag_field_id)%module_name), &
2127 & trim(output_fields(out_num)%output_name)
2128 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d',
'module/output_field '//&
2129 & trim(error_string)//
' is skipped one time level in output data', err_msg))
THEN
2130 DEALLOCATE(field_out)
2131 DEALLOCATE(oor_mask)
2137 status =
writing_field(out_num, .false., error_string, time)
2138 IF(status == -1)
THEN
2139 IF (
mpp_pe() .EQ. mpp_root_pe() )
THEN
2140 IF(
fms_error_handler(
'diag_manager_mod::send_data_3d',
'module/output_field '//trim(error_string)&
2141 & //
', write EMPTY buffer', err_msg))
THEN
2142 DEALLOCATE(field_out)
2143 DEALLOCATE(oor_mask)
2153 if (
present(time))
then
2155 if (output_fields(out_num)%last_output > time) cycle
2158 IF ( .NOT.output_fields(out_num)%static .AND. .NOT.need_compute .AND. debug_diag_manager )
THEN
2160 IF ( err_msg_local /=
'' )
THEN
2161 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
2162 DEALLOCATE(field_out)
2163 DEALLOCATE(oor_mask)
2169 IF (use_refactored_send)
THEN
2170 ALLOCATE( ofield_index_cfg )
2171 CALL ofield_index_cfg%initialize( is, js, ks, ie, je, ke, &
2172 & hi, hj, f1, f2, f3, f4)
2174 ALLOCATE( ofield_cfg )
2175 CALL ofield_cfg%initialize( input_fields(diag_field_id), output_fields(out_num),
PRESENT(mask), freq)
2179 mf_result =
fieldbuff_update(ofield_cfg, ofield_index_cfg, field_out, sample, &
2180 & output_fields(out_num)%buffer, output_fields(out_num)%counter ,output_fields(out_num)%buff_bounds,&
2181 & output_fields(out_num)%count_0d(sample), output_fields(out_num)%num_elements(sample), &
2182 & mask, weight1 ,missvalue, &
2183 & input_fields(diag_field_id)%numthreads, input_fields(diag_field_id)%active_omp_level,&
2184 & input_fields(diag_field_id)%issued_mask_ignore_warning, &
2185 & l_start, l_end, err_msg, err_msg_local )
2186 IF (mf_result .eqv. .false.)
THEN
2187 DEALLOCATE(ofield_index_cfg)
2188 DEALLOCATE(ofield_cfg)
2189 DEALLOCATE(field_out)
2190 DEALLOCATE(oor_mask)
2195 & output_fields(out_num)%buffer, output_fields(out_num)%buff_bounds , &
2196 & output_fields(out_num)%count_0d(sample), &
2197 & mask, missvalue, l_start, l_end, err_msg, err_msg_local)
2198 IF (mf_result .eqv. .false.)
THEN
2199 DEALLOCATE(ofield_index_cfg)
2200 DEALLOCATE(ofield_cfg)
2201 DEALLOCATE(field_out)
2202 DEALLOCATE(oor_mask)
2207 IF ( output_fields(out_num)%static .AND. .NOT.need_compute .AND. debug_diag_manager )
THEN
2209 IF ( err_msg_local /=
'' )
THEN
2210 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg))
THEN
2211 DEALLOCATE(field_out)
2212 DEALLOCATE(oor_mask)
2239 IF(
ALLOCATED(ofield_index_cfg))
THEN
2240 DEALLOCATE(ofield_index_cfg)
2242 IF(
ALLOCATED(ofield_cfg))
THEN
2243 DEALLOCATE(ofield_cfg)
2250 IF ( input_fields(diag_field_id)%mask_variant )
THEN
2251 IF ( need_compute )
THEN
2252 WRITE (error_string,
'(a,"/",a)') &
2253 & trim(input_fields(diag_field_id)%module_name), &
2254 & trim(output_fields(out_num)%output_name)
2255 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d',
'module/output_field '//trim(error_string)//&
2256 &
', regional output NOT supported with mask_variant', err_msg))
THEN
2257 DEALLOCATE(field_out)
2258 DEALLOCATE(oor_mask)
2265 IF (
PRESENT(mask) )
THEN
2266 IF ( missvalue_present )
THEN
2267 IF ( debug_diag_manager )
THEN
2268 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
2270 IF ( err_msg_local /=
'' )
THEN
2271 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
2272 DEALLOCATE(field_out)
2273 DEALLOCATE(oor_mask)
2278 IF( numthreads>1 .AND. phys_window )
then
2279 IF ( reduced_k_range )
THEN
2284 IF ( mask(i-is+1+hi, j-js+1+hj, k) )
THEN
2285 IF ( pow_value /= 1 )
THEN
2286 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2287 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2288 & (field_out(i-is+1+hi, j-js+1+hj, k) * weight1)**(pow_value)
2290 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2291 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2292 & field_out(i-is+1+hi, j-js+1+hj, k) * weight1
2294 output_fields(out_num)%counter(i-hi,j-hj,k1,sample) =&
2295 & output_fields(out_num)%counter(i-hi,j-hj,k1,sample) + weight1
2304 IF ( mask(i-is+1+hi, j-js+1+hj, k) )
THEN
2305 IF ( pow_value /= 1 )
THEN
2306 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2307 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2308 & (field_out(i-is+1+hi,j-js+1+hj,k)*weight1)**(pow_value)
2310 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2311 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2312 & field_out(i-is+1+hi,j-js+1+hj,k)*weight1
2314 output_fields(out_num)%counter(i-hi,j-hj,k,sample) =&
2315 &output_fields(out_num)%counter(i-hi,j-hj,k,sample) + weight1
2323 IF ( reduced_k_range )
THEN
2328 IF ( mask(i-is+1+hi, j-js+1+hj, k) )
THEN
2329 IF ( pow_value /= 1 )
THEN
2330 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2331 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2332 & (field_out(i-is+1+hi, j-js+1+hj, k) * weight1)**(pow_value)
2334 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2335 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2336 & field_out(i-is+1+hi, j-js+1+hj, k) * weight1
2338 output_fields(out_num)%counter(i-hi,j-hj,k1,sample) =&
2339 & output_fields(out_num)%counter(i-hi,j-hj,k1,sample) + weight1
2348 IF ( mask(i-is+1+hi, j-js+1+hj, k) )
THEN
2349 IF ( pow_value /= 1 )
THEN
2350 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2351 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2352 & (field_out(i-is+1+hi,j-js+1+hj,k)*weight1)**(pow_value)
2354 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2355 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2356 & field_out(i-is+1+hi,j-js+1+hj,k)*weight1
2358 output_fields(out_num)%counter(i-hi,j-hj,k,sample) =&
2359 &output_fields(out_num)%counter(i-hi,j-hj,k,sample) + weight1
2368 WRITE (error_string,
'(a,"/",a)')&
2369 & trim(input_fields(diag_field_id)%module_name), &
2370 & trim(output_fields(out_num)%output_name)
2371 IF(
fms_error_handler(
'diag_manager_mod::send_data_3d',
'module/output_field '//trim(error_string)//&
2372 &
', variable mask but no missing value defined', err_msg))
THEN
2373 DEALLOCATE(field_out)
2374 DEALLOCATE(oor_mask)
2379 WRITE (error_string,
'(a,"/",a)')&
2380 & trim(input_fields(diag_field_id)%module_name), &
2381 & trim(output_fields(out_num)%output_name)
2382 IF(
fms_error_handler(
'diag_manager_mod::send_data_3d',
'module/output_field '//trim(error_string)//&
2383 &
', variable mask but no mask given', err_msg))
THEN
2384 DEALLOCATE(field_out)
2385 DEALLOCATE(oor_mask)
2390 IF (
PRESENT(mask) )
THEN
2391 IF ( missvalue_present )
THEN
2392 IF ( need_compute )
THEN
2393 IF (numthreads>1 .AND. phys_window)
then
2394 DO k = l_start(3), l_end(3)
2398 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2399 & j <= l_end(2)+hj )
THEN
2400 i1 = i-l_start(1)-hi+1
2401 j1= j-l_start(2)-hj+1
2402 IF ( mask(i-is+1+hi, j-js+1+hj, k) )
THEN
2403 IF ( pow_value /= 1 )
THEN
2404 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2405 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2406 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2408 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2409 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2410 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2413 output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
2421 DO k = l_start(3), l_end(3)
2425 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2426 & j <= l_end(2)+hj )
THEN
2427 i1 = i-l_start(1)-hi+1
2428 j1= j-l_start(2)-hj+1
2429 IF ( mask(i-is+1+hi, j-js+1+hj, k) )
THEN
2430 IF ( pow_value /= 1 )
THEN
2431 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2432 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2433 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2435 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2436 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2437 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2440 output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
2451 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2452 & j <= l_end(2)+hj )
THEN
2453 output_fields(out_num)%num_elements(sample) = &
2454 output_fields(out_num)%num_elements(sample) + l_end(3) - l_start(3) + 1
2459 ELSE IF ( reduced_k_range )
THEN
2460 IF (numthreads>1 .AND. phys_window)
then
2465 IF ( mask(i-is+1+hi,j-js+1+hj,k) )
THEN
2466 IF ( pow_value /= 1 )
THEN
2467 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2468 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2469 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2471 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2472 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2473 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2476 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue
2487 IF ( mask(i-is+1+hi,j-js+1+hj,k) )
THEN
2488 IF ( pow_value /= 1 )
THEN
2489 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2490 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2491 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2493 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2494 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2495 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2498 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue
2506 IF ( debug_diag_manager )
THEN
2507 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
2509 IF ( err_msg_local /=
'' )
THEN
2510 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
2511 DEALLOCATE(field_out)
2512 DEALLOCATE(oor_mask)
2517 IF (numthreads>1 .AND. phys_window)
then
2521 IF ( mask(i-is+1+hi,j-js+1+hj,k) )
THEN
2522 IF ( pow_value /= 1 )
THEN
2523 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2524 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2525 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2527 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2528 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2529 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2532 output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue
2542 IF ( mask(i-is+1+hi,j-js+1+hj,k) )
THEN
2543 IF ( pow_value /= 1 )
THEN
2544 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2545 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2546 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2548 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2549 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2550 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2553 output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue
2562 IF ( need_compute .AND. .NOT.phys_window )
THEN
2563 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))) ) &
2564 & output_fields(out_num)%count_0d(sample) =&
2565 & output_fields(out_num)%count_0d(sample) + weight1
2567 IF ( any(mask(f1:f2,f3:f4,ks:ke)) ) output_fields(out_num)%count_0d(sample) =&
2568 & output_fields(out_num)%count_0d(sample)+weight1
2573 IF ( (.NOT.all(mask(f1:f2,f3:f4,ks:ke)) .AND.
mpp_pe() .EQ. mpp_root_pe()).AND.&
2574 & .NOT.input_fields(diag_field_id)%issued_mask_ignore_warning )
THEN
2579 CALL error_mesg(
'diag_manager_mod::send_data_3d',&
2580 &
'Mask will be ignored since missing values were not specified for field '//&
2581 & trim(input_fields(diag_field_id)%field_name)//
' in module '//&
2582 & trim(input_fields(diag_field_id)%module_name), warning)
2583 input_fields(diag_field_id)%issued_mask_ignore_warning = .true.
2585 IF ( need_compute )
THEN
2586 IF (numthreads>1 .AND. phys_window)
then
2589 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2590 & j <= l_end(2)+hj )
THEN
2591 i1 = i-l_start(1)-hi+1
2592 j1 = j-l_start(2)-hj+1
2593 IF ( pow_value /= 1 )
THEN
2594 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2595 & output_fields(out_num)%buffer(i1,j1,:,sample)+ &
2596 & (field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value)
2598 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2599 & output_fields(out_num)%buffer(i1,j1,:,sample)+ &
2600 & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
2609 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2610 & j <= l_end(2)+hj )
THEN
2611 i1 = i-l_start(1)-hi+1
2612 j1 = j-l_start(2)-hj+1
2613 IF ( pow_value /= 1 )
THEN
2614 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2615 & output_fields(out_num)%buffer(i1,j1,:,sample)+ &
2616 & (field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value)
2618 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2619 & output_fields(out_num)%buffer(i1,j1,:,sample)+ &
2620 & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
2630 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2631 & j <= l_end(2)+hj )
THEN
2632 output_fields(out_num)%num_elements(sample)=&
2633 & output_fields(out_num)%num_elements(sample)+l_end(3)-l_start(3)+1
2639 ELSE IF ( reduced_k_range )
THEN
2640 IF (numthreads>1 .AND. phys_window)
then
2643 IF ( pow_value /= 1 )
THEN
2644 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2645 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) +&
2646 & (field_out(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value)
2648 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2649 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) +&
2650 & field_out(f1:f2,f3:f4,ksr:ker)*weight1
2656 IF ( pow_value /= 1 )
THEN
2657 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2658 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) +&
2659 & (field_out(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value)
2661 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2662 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) +&
2663 & field_out(f1:f2,f3:f4,ksr:ker)*weight1
2668 IF ( debug_diag_manager )
THEN
2669 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
2671 IF ( err_msg_local /=
'')
THEN
2672 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
2673 DEALLOCATE(field_out)
2674 DEALLOCATE(oor_mask)
2679 IF (numthreads>1 .AND. phys_window)
then
2680 IF ( pow_value /= 1 )
THEN
2681 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
2682 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
2683 & (field_out(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value)
2685 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
2686 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
2687 & field_out(f1:f2,f3:f4,ks:ke)*weight1
2691 IF ( pow_value /= 1 )
THEN
2692 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
2693 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
2694 & (field_out(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value)
2696 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
2697 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
2698 & field_out(f1:f2,f3:f4,ks:ke)*weight1
2704 IF ( .NOT.phys_window ) output_fields(out_num)%count_0d(sample) =&
2705 & output_fields(out_num)%count_0d(sample) + weight1
2709 IF ( missvalue_present )
THEN
2710 IF ( need_compute )
THEN
2711 if( numthreads>1 .AND. phys_window )
then
2712 DO k = l_start(3), l_end(3)
2713 k1 = k - l_start(3) + 1
2716 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2717 & j <= l_end(2)+hj)
THEN
2718 i1 = i-l_start(1)-hi+1
2719 j1= j-l_start(2)-hj+1
2720 IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue )
THEN
2721 IF ( pow_value /= 1 )
THEN
2722 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2723 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2724 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2726 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2727 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2728 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2731 output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
2739 DO k = l_start(3), l_end(3)
2740 k1 = k - l_start(3) + 1
2743 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2744 & j <= l_end(2)+hj)
THEN
2745 i1 = i-l_start(1)-hi+1
2746 j1= j-l_start(2)-hj+1
2747 IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue )
THEN
2748 IF ( pow_value /= 1 )
THEN
2749 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2750 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2751 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2753 output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2754 & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2755 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2758 output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
2769 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2770 & j <= l_end(2)+hj)
THEN
2771 output_fields(out_num)%num_elements(sample) =&
2772 & output_fields(out_num)%num_elements(sample) + l_end(3) - l_start(3) + 1
2776 IF ( .NOT.phys_window )
THEN
2777 outer0:
DO k = l_start(3), l_end(3)
2778 DO j=l_start(2)+hj, l_end(2)+hj
2779 DO i=l_start(1)+hi, l_end(1)+hi
2780 IF ( field_out(i,j,k) /= missvalue )
THEN
2781 output_fields(out_num)%count_0d(sample) = output_fields(out_num)%count_0d(sample)&
2790 ELSE IF ( reduced_k_range )
THEN
2791 if( numthreads>1 .AND. phys_window )
then
2798 IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue )
THEN
2799 IF ( pow_value /= 1 )
THEN
2800 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2801 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2802 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2804 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2805 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2806 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2809 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) = missvalue
2822 IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue )
THEN
2823 IF ( pow_value /= 1 )
THEN
2824 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2825 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2826 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2828 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2829 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2830 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2833 output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) = missvalue
2841 outer3:
DO k = ksr, ker
2845 IF ( field_out(i,j,k) /= missvalue )
THEN
2846 output_fields(out_num)%count_0d(sample) = output_fields(out_num)%count_0d(sample) &
2855 IF ( debug_diag_manager )
THEN
2856 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
2858 IF ( err_msg_local /=
'' )
THEN
2859 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
2860 DEALLOCATE(field_out)
2861 DEALLOCATE(oor_mask)
2866 IF( numthreads > 1 .AND. phys_window )
then
2870 IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue )
THEN
2871 IF ( pow_value /= 1 )
THEN
2872 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2873 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2874 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2876 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2877 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2878 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2881 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) = missvalue
2891 IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue )
THEN
2892 IF ( pow_value /= 1 )
THEN
2893 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2894 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2895 & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2897 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2898 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2899 & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2902 output_fields(out_num)%buffer(i-hi,j-hj,k,sample) = missvalue
2913 IF ( field_out(i,j,k) /= missvalue )
THEN
2914 output_fields(out_num)%count_0d(sample) = output_fields(out_num)%count_0d(sample) &
2924 IF ( need_compute )
THEN
2925 IF( numthreads > 1 .AND. phys_window )
then
2928 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2929 & j <= l_end(2)+hj )
THEN
2930 i1 = i-l_start(1)-hi+1
2931 j1= j-l_start(2)-hj+1
2932 IF ( pow_value /= 1 )
THEN
2933 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2934 & output_fields(out_num)%buffer(i1,j1,:,sample) +&
2935 & (field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value)
2937 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2938 & output_fields(out_num)%buffer(i1,j1,:,sample) +&
2939 & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
2948 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2949 & j <= l_end(2)+hj )
THEN
2950 i1 = i-l_start(1)-hi+1
2951 j1= j-l_start(2)-hj+1
2952 IF ( pow_value /= 1 )
THEN
2953 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2954 & output_fields(out_num)%buffer(i1,j1,:,sample) +&
2955 & (field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value)
2957 output_fields(out_num)%buffer(i1,j1,:,sample)= &
2958 & output_fields(out_num)%buffer(i1,j1,:,sample) +&
2959 & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
2970 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2971 & j <= l_end(2)+hj )
THEN
2972 output_fields(out_num)%num_elements(sample) =&
2973 & output_fields(out_num)%num_elements(sample)+l_end(3)-l_start(3)+1
2979 ELSE IF ( reduced_k_range )
THEN
2982 IF( numthreads > 1 .AND. phys_window )
then
2983 IF ( pow_value /= 1 )
THEN
2984 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2985 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
2986 & (field_out(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value)
2988 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2989 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
2990 & field_out(f1:f2,f3:f4,ksr:ker)*weight1
2994 IF ( pow_value /= 1 )
THEN
2995 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2996 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
2997 & (field_out(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value)
2999 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
3000 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
3001 & field_out(f1:f2,f3:f4,ksr:ker)*weight1
3006 IF ( debug_diag_manager )
THEN
3007 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3009 IF ( err_msg_local /=
'' )
THEN
3010 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3011 DEALLOCATE(field_out)
3012 DEALLOCATE(oor_mask)
3017 IF( numthreads > 1 .AND. phys_window )
then
3018 IF ( pow_value /= 1 )
THEN
3019 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
3020 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
3021 & (field_out(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value)
3023 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
3024 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
3025 & field_out(f1:f2,f3:f4,ks:ke)*weight1
3029 IF ( pow_value /= 1 )
THEN
3030 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
3031 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
3032 & (field_out(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value)
3034 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
3035 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
3036 & field_out(f1:f2,f3:f4,ks:ke)*weight1
3042 IF ( .NOT.phys_window ) output_fields(out_num)%count_0d(sample) =&
3043 & output_fields(out_num)%count_0d(sample) + weight1
3049 IF ( .NOT.need_compute .AND. .NOT.reduced_k_range )&
3050 & output_fields(out_num)%num_elements(sample) =&
3051 & output_fields(out_num)%num_elements(sample) + (ie-is+1)*(je-js+1)*(ke-ks+1)
3052 IF ( reduced_k_range ) &
3053 & output_fields(out_num)%num_elements(sample) = output_fields(out_num)%num_elements(sample) +&
3054 & (ie-is+1)*(je-js+1)*(ker-ksr+1)
3057 ELSE IF ( time_max )
THEN
3058 IF (
PRESENT(mask) )
THEN
3059 IF ( need_compute )
THEN
3060 DO k = l_start(3), l_end(3)
3061 k1 = k - l_start(3) + 1
3064 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
3065 & j <= l_end(2)+hj )
THEN
3066 i1 = i-l_start(1)-hi+1
3067 j1= j-l_start(2)-hj+1
3068 IF ( mask(i-is+1+hi,j-js+1+hj,k) .AND. field_out(i-is+1+hi,j-js+1+hj,k)>&
3069 & output_fields(out_num)%buffer(i1,j1,k1,sample) )
THEN
3070 output_fields(out_num)%buffer(i1,j1,k1,sample) = field_out(i-is+1+hi,j-js+1+hj,k)
3077 ELSE IF ( reduced_k_range )
THEN
3080 WHERE ( mask(f1:f2,f3:f4,ksr:ker) .AND. field_out(f1:f2,f3:f4,ksr:ker) >&
3081 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) )&
3082 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker)
3084 IF ( debug_diag_manager )
THEN
3085 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3087 IF ( err_msg_local /=
'' )
THEN
3088 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3089 DEALLOCATE(field_out)
3090 DEALLOCATE(oor_mask)
3095 WHERE ( mask(f1:f2,f3:f4,ks:ke) .AND. field_out(f1:f2,f3:f4,ks:ke)>&
3096 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) )&
3097 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke)
3100 IF ( need_compute )
THEN
3101 DO k = l_start(3), l_end(3)
3102 k1 = k - l_start(3) + 1
3105 IF(l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
3106 & j <= l_end(2)+hj )
THEN
3107 i1 = i-l_start(1)-hi+1
3108 j1 = j-l_start(2)-hj+1
3109 IF ( field_out(i-is+1+hi,j-js+1+hj,k)>output_fields(out_num)%buffer(i1,j1,k1,sample) )
THEN
3110 output_fields(out_num)%buffer(i1,j1,k1,sample) = field_out(i-is+1+hi,j-js+1+hj,k)
3117 ELSE IF ( reduced_k_range )
THEN
3120 WHERE ( field_out(f1:f2,f3:f4,ksr:ker) >&
3121 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) ) &
3122 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker)
3124 IF ( debug_diag_manager )
THEN
3125 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3127 IF ( err_msg_local /=
'' )
THEN
3128 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3129 DEALLOCATE(field_out)
3130 DEALLOCATE(oor_mask)
3135 WHERE ( field_out(f1:f2,f3:f4,ks:ke) >&
3136 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) ) &
3137 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke)
3140 output_fields(out_num)%count_0d(sample) = 1
3141 ELSE IF ( time_min )
THEN
3142 IF (
PRESENT(mask) )
THEN
3143 IF ( need_compute )
THEN
3144 DO k = l_start(3), l_end(3)
3145 k1 = k - l_start(3) + 1
3148 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
3149 & j <= l_end(2)+hj )
THEN
3150 i1 = i-l_start(1)-hi+1
3151 j1 = j-l_start(2)-hj+1
3152 IF ( mask(i-is+1+hi,j-js+1+hj,k) .AND. field_out(i-is+1+hi,j-js+1+hj,k) <&
3153 & output_fields(out_num)%buffer(i1,j1,k1,sample) )
THEN
3154 output_fields(out_num)%buffer(i1,j1,k1,sample) = field_out(i-is+1+hi,j-js+1+hj,k)
3161 ELSE IF ( reduced_k_range )
THEN
3164 WHERE ( mask(f1:f2,f3:f4,ksr:ker) .AND. field_out(f1:f2,f3:f4,ksr:ker) <&
3165 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) ) &
3166 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker)
3168 IF ( debug_diag_manager )
THEN
3169 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3171 IF ( err_msg_local /=
'' )
THEN
3172 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3173 DEALLOCATE(field_out)
3174 DEALLOCATE(oor_mask)
3179 WHERE ( mask(f1:f2,f3:f4,ks:ke) .AND. field_out(f1:f2,f3:f4,ks:ke) <&
3180 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) ) &
3181 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke)
3184 IF ( need_compute )
THEN
3185 DO k = l_start(3), l_end(3)
3186 k1 = k - l_start(3) + 1
3189 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
3190 i1 = i-l_start(1)-hi+1
3191 j1= j-l_start(2)-hj+1
3192 IF ( field_out(i-is+1+hi,j-js+1+hj,k) <&
3193 & output_fields(out_num)%buffer(i1,j1,k1,sample) )
THEN
3194 output_fields(out_num)%buffer(i1,j1,k1,sample) = field_out(i-is+1+hi,j-js+1+hj,k)
3201 ELSE IF ( reduced_k_range )
THEN
3204 WHERE ( field_out(f1:f2,f3:f4,ksr:ker) <&
3205 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) ) &
3206 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker)
3208 IF ( debug_diag_manager )
THEN
3209 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3211 IF ( err_msg_local /=
'' )
THEN
3212 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3213 DEALLOCATE(field_out)
3214 DEALLOCATE(oor_mask)
3219 WHERE ( field_out(f1:f2,f3:f4,ks:ke) <&
3220 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) )&
3221 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke)
3224 output_fields(out_num)%count_0d(sample) = 1
3225 ELSE IF ( time_sum )
THEN
3226 IF (
PRESENT(mask) )
THEN
3227 IF ( need_compute )
THEN
3228 DO k = l_start(3), l_end(3)
3229 k1 = k - l_start(3) + 1
3232 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
3233 & j <= l_end(2)+hj )
THEN
3234 i1 = i-l_start(1)-hi+1
3235 j1 = j-l_start(2)-hj+1
3236 IF ( mask(i-is+1+hi,j-js+1+hj,k) )
THEN
3237 output_fields(out_num)%buffer(i1,j1,k1,sample) = &
3238 output_fields(out_num)%buffer(i1,j1,k1,sample) + &
3239 field_out(i-is+1+hi,j-js+1+hj,k)
3246 ELSE IF ( reduced_k_range )
THEN
3249 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = &
3250 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
3251 & field_out(f1:f2,f3:f4,ksr:ker)
3253 IF ( debug_diag_manager )
THEN
3254 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3256 IF ( err_msg_local /=
'' )
THEN
3257 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3258 DEALLOCATE(field_out)
3259 DEALLOCATE(oor_mask)
3264 WHERE ( mask(f1:f2,f3:f4,ks:ke) ) &
3265 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = &
3266 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) + &
3267 & field_out(f1:f2,f3:f4,ks:ke)
3270 IF ( need_compute )
THEN
3271 DO k = l_start(3), l_end(3)
3272 k1 = k - l_start(3) + 1
3275 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
3276 i1 = i-l_start(1)-hi+1
3277 j1= j-l_start(2)-hj+1
3278 output_fields(out_num)%buffer(i1,j1,k1,sample) = &
3279 & output_fields(out_num)%buffer(i1,j1,k1,sample) + &
3280 & field_out(i-is+1+hi,j-js+1+hj,k)
3285 ELSE IF ( reduced_k_range )
THEN
3288 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = &
3289 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
3290 & field_out(f1:f2,f3:f4,ksr:ker)
3292 IF ( debug_diag_manager )
THEN
3293 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3295 IF ( err_msg_local /=
'' )
THEN
3296 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3297 DEALLOCATE(field_out)
3298 DEALLOCATE(oor_mask)
3303 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = &
3304 & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) + &
3305 & field_out(f1:f2,f3:f4,ks:ke)
3308 output_fields(out_num)%count_0d(sample) = 1
3310 output_fields(out_num)%count_0d(sample) = 1
3311 IF ( need_compute )
THEN
3314 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
3315 i1 = i-l_start(1)-hi+1
3316 j1 = j-l_start(2)-hj+1
3317 output_fields(out_num)%buffer(i1,j1,:,sample) =&
3318 & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))
3323 ELSE IF ( reduced_k_range )
THEN
3326 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker)
3328 IF ( debug_diag_manager )
THEN
3329 CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3331 IF ( err_msg_local /=
'' )
THEN
3332 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg) )
THEN
3333 DEALLOCATE(field_out)
3334 DEALLOCATE(oor_mask)
3339 output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke)
3342 IF (
PRESENT(mask) .AND. missvalue_present )
THEN
3343 IF ( need_compute )
THEN
3344 DO k = l_start(3), l_end(3)
3345 k1 = k - l_start(3) + 1
3348 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
3349 & j <= l_end(2)+hj )
THEN
3350 i1 = i-l_start(1)-hi+1
3351 j1 = j-l_start(2)-hj+1
3352 IF ( .NOT.mask(i-is+1+hi,j-js+1+hj,k) )&
3353 & output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
3358 ELSE IF ( reduced_k_range )
THEN
3365 IF ( .NOT.mask(i-is+1+hi,j-js+1+hj,k) ) &
3366 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue
3374 IF ( .NOT.mask(i-is+1+hi,j-js+1+hj,k) )&
3375 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue
3383 IF ( output_fields(out_num)%static .AND. .NOT.need_compute .AND. debug_diag_manager )
THEN
3385 IF ( err_msg_local /=
'' )
THEN
3386 IF (
fms_error_handler(
'diag_manager_mod::send_data_3d', err_msg_local, err_msg))
THEN
3387 DEALLOCATE(field_out)
3388 DEALLOCATE(oor_mask)
3397 IF (
PRESENT(rmask) .AND. missvalue_present )
THEN
3398 IF ( need_compute )
THEN
3400 TYPE IS (real(kind=r4_kind))
3401 DO k = l_start(3), l_end(3)
3402 k1 = k - l_start(3) + 1
3405 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND.&
3406 & j <= l_end(2)+hj )
THEN
3407 i1 = i-l_start(1)-hi+1
3408 j1 = j-l_start(2)-hj+1
3409 IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r4_kind ) &
3410 & output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
3415 TYPE IS (real(kind=r8_kind))
3416 DO k = l_start(3), l_end(3)
3417 k1 = k - l_start(3) + 1
3420 IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND.&
3421 & j <= l_end(2)+hj )
THEN
3422 i1 = i-l_start(1)-hi+1
3423 j1 = j-l_start(2)-hj+1
3424 IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r8_kind ) &
3425 & output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
3431 CALL error_mesg (
'diag_manager_mod::send_data_3d',&
3432 &
'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
3434 ELSE IF ( reduced_k_range )
THEN
3438 TYPE IS (real(kind=r4_kind))
3443 IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r4_kind ) &
3444 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue
3448 TYPE IS (real(kind=r8_kind))
3453 IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r8_kind ) &
3454 & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue
3459 CALL error_mesg (
'diag_manager_mod::send_data_3d',&
3460 &
'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
3464 TYPE IS (real(kind=r4_kind))
3468 IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r4_kind ) &
3469 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue
3473 TYPE IS (real(kind=r8_kind))
3477 IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r8_kind ) &
3478 & output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue
3483 CALL error_mesg (
'diag_manager_mod::send_data_3d',&
3484 &
'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
3489 END DO num_out_fields
3491 DEALLOCATE(field_out)
3492 DEALLOCATE(oor_mask)
3498 LOGICAL FUNCTION send_data_4d(diag_field_id, field, time, is_in, js_in, ks_in, &
3499 & mask, rmask, ie_in, je_in, ke_in, weight, err_msg)
3500 INTEGER,
INTENT(in) :: diag_field_id
3501 CLASS(*),
INTENT(in) :: field(:,:,:,:)
3502 CLASS(*),
INTENT(in),
OPTIONAL :: weight
3503 TYPE (
time_type),
INTENT(in),
OPTIONAL :: time
3504 INTEGER,
INTENT(in),
OPTIONAL :: is_in
3505 INTEGER,
INTENT(in),
OPTIONAL :: js_in
3506 INTEGER,
INTENT(in),
OPTIONAL :: ks_in
3507 INTEGER,
INTENT(in),
OPTIONAL :: ie_in
3508 INTEGER,
INTENT(in),
OPTIONAL :: je_in
3509 INTEGER,
INTENT(in),
OPTIONAL :: ke_in
3510 LOGICAL,
INTENT(in),
OPTIONAL :: mask(:,:,:,:)
3511 CLASS(*),
INTENT(in),
OPTIONAL :: rmask(:,:,:,:)
3512 CHARACTER(len=*),
INTENT(out),
OPTIONAL :: err_msg
3515 class(*),
allocatable :: rmask_local(:,:,:,:)
3516 logical,
allocatable :: mask_local(:,:,:,:)
3519 IF ( diag_field_id <= 0 )
THEN
3524 if (.not. use_modern_diag) &
3525 call mpp_error(fatal,
"Send_data_4d is only supported when diag_manager_nml::use_modern_diag=.true.")
3528 if (
present(mask)) mask_local = mask
3529 if (
present(rmask)) rmask_local = rmask
3531 call fms_diag_object%fms_diag_accept_data(diag_field_id, field, mask_local, rmask_local, &
3532 time, is_in, js_in, ks_in, ie_in, je_in, ke_in, weight, &
3536 if (
present(err_msg))
then
3537 if (err_msg .ne.
"")
then
3544 if (
allocated(rmask_local))
deallocate(rmask_local)
3545 if (
allocated(mask_local))
deallocate(mask_local)
3550 INTEGER,
INTENT(in) :: id
3551 REAL,
INTENT(in) :: field(:,:)
3552 REAL,
INTENT(in) :: area (:,:)
3554 LOGICAL,
INTENT(in),
OPTIONAL :: mask (:,:)
3556 REAL,
DIMENSION(SIZE(field,1)) :: out(size(field,1))
3570 INTEGER,
INTENT(in) :: diag_field_id
3571 REAL,
DIMENSION(:,:),
INTENT(in) :: x
3572 REAL,
DIMENSION(:,:),
INTENT(in) :: area
3573 LOGICAL,
DIMENSION(:,:),
INTENT(in) :: mask
3574 REAL,
DIMENSION(:),
INTENT(out) :: out
3577 REAL,
DIMENSION(SIZE(x,1)) :: s
3578 REAL :: local_missing_value
3582 IF ( diag_field_id <= 0 )
THEN
3586 CALL error_mesg(
'diag_manager_mod::average_tiles1d',&
3587 &
"diag_field_id less than 0. Contact developers.", fatal)
3591 IF ( input_fields(diag_field_id)%missing_value_present )
THEN
3592 local_missing_value = input_fields(diag_field_id)%missing_value
3594 local_missing_value = 0.0
3601 DO it = 1,
SIZE(area,dim=2)
3602 WHERE ( mask(:,it) )
3603 out(:) = out(:) + x(:,it)*area(:,it)
3604 s(:) = s(:) + area(:,it)
3609 out(:) = out(:)/s(:)
3611 out(:) = local_missing_value
3617 INTEGER,
INTENT(in) :: id
3618 REAL,
INTENT(in) :: field(:,:,:)
3619 REAL,
INTENT(in) :: area (:,:,:)
3621 LOGICAL,
INTENT(in),
OPTIONAL :: mask (:,:,:)
3623 REAL,
DIMENSION(SIZE(field,1),SIZE(field,2)) :: out(size(field,1), size(field,2))
3637 INTEGER,
INTENT(in) :: id
3638 REAL,
DIMENSION(:,:,:,:),
INTENT(in) :: field
3639 REAL,
DIMENSION(:,:,:),
INTENT(in) :: area (:,:,:)
3642 LOGICAL,
DIMENSION(:,:,:),
INTENT(in),
OPTIONAL :: mask
3644 REAL,
DIMENSION(SIZE(field,1),SIZE(field,2),SIZE(field,4)) :: out
3645 LOGICAL,
DIMENSION(SIZE(field,1),SIZE(field,2),SIZE(field,4)) :: mask3
3654 DO it=1,
SIZE(field,4)
3655 CALL average_tiles(id, field(:,:,:,it), area, mask, out(:,:,it) )
3658 mask3(:,:,1) = any(mask,dim=3)
3659 DO it = 2,
SIZE(field,4)
3660 mask3(:,:,it) = mask3(:,:,1)
3668 INTEGER,
INTENT(in) :: diag_field_id
3669 REAL,
DIMENSION(:,:,:),
INTENT(in) :: x
3670 REAL,
DIMENSION(:,:,:),
INTENT(in) :: area
3671 LOGICAL,
DIMENSION(:,:,:),
INTENT(in) :: mask
3672 REAL,
DIMENSION(:,:),
INTENT(out) :: out
3675 REAL,
DIMENSION(SIZE(x,1),SIZE(x,2)) :: s
3676 REAL :: local_missing_value
3680 IF ( diag_field_id <= 0 )
THEN
3684 CALL error_mesg(
'diag_manager_mod::average_tiles',&
3685 &
"diag_field_id less than 0. Contact developers.", fatal)
3689 IF ( input_fields(diag_field_id)%missing_value_present )
THEN
3690 local_missing_value = input_fields(diag_field_id)%missing_value
3692 local_missing_value = 0.0
3699 DO it = 1,
SIZE(area,3)
3700 WHERE ( mask(:,:,it) )
3701 out(:,:) = out(:,:) + x(:,:,it)*area(:,:,it)
3702 s(:,:) = s(:,:) + area(:,:,it)
3706 WHERE ( s(:,:) > 0 )
3707 out(:,:) = out(:,:)/s(:,:)
3709 out(:,:) = local_missing_value
3715 INTEGER,
INTENT(in) :: out_num
3716 LOGICAL,
INTENT(in) :: at_diag_end
3717 CHARACTER(len=*),
INTENT(out) :: error_string
3722 LOGICAL :: time_max, time_min, reduced_k_range, missvalue_present
3723 LOGICAL :: average, time_rms, need_compute, phys_window
3724 INTEGER :: in_num, file_num, freq, units
3725 INTEGER :: b1,b2,b3,b4
3726 INTEGER :: i, j, k, m
3727 REAL :: missvalue, num
3730 need_compute = output_fields(out_num)%need_compute
3732 in_num = output_fields(out_num)%input_field
3733 IF ( input_fields(in_num)%static )
RETURN
3735 missvalue = input_fields(in_num)%missing_value
3736 missvalue_present = input_fields(in_num)%missing_value_present
3737 reduced_k_range = output_fields(out_num)%reduced_k_range
3738 phys_window = output_fields(out_num)%phys_window
3740 average = output_fields(out_num)%time_average
3743 time_rms = output_fields(out_num)%time_rms
3745 time_max = output_fields(out_num)%time_max
3746 time_min = output_fields(out_num)%time_min
3747 file_num = output_fields(out_num)%output_file
3748 freq = files(file_num)%output_freq
3749 units = files(file_num)%output_units
3753 b1=
SIZE(output_fields(out_num)%buffer,1)
3754 b2=
SIZE(output_fields(out_num)%buffer,2)
3755 b3=
SIZE(output_fields(out_num)%buffer,3)
3756 b4=
SIZE(output_fields(out_num)%buffer,4)
3757 IF ( input_fields(in_num)%mask_variant )
THEN
3762 IF ( output_fields(out_num)%counter(i,j,k,m) > 0. )
THEN
3763 output_fields(out_num)%buffer(i,j,k,m) = &
3764 & output_fields(out_num)%buffer(i,j,k,m)/output_fields(out_num)%counter(i,j,k,m)
3765 IF ( time_rms ) output_fields(out_num)%buffer(i,j,k,m) = &
3766 sqrt(output_fields(out_num)%buffer(i,j,k,m))
3768 output_fields(out_num)%buffer(i,j,k,m) = missvalue
3776 IF ( phys_window )
THEN
3777 IF ( need_compute .OR. reduced_k_range )
THEN
3778 num = real(output_fields(out_num)%num_elements(m)/output_fields(out_num)%region_elements)
3780 num = real(output_fields(out_num)%num_elements(m)/output_fields(out_num)%total_elements)
3783 num = output_fields(out_num)%count_0d(m)
3785 IF ( num > 0. )
THEN
3786 IF ( missvalue_present )
THEN
3790 IF ( output_fields(out_num)%buffer(i,j,k,m) /= missvalue )
THEN
3791 output_fields(out_num)%buffer(i,j,k,m) = output_fields(out_num)%buffer(i,j,k,m)/num
3792 IF ( time_rms ) output_fields(out_num)%buffer(i,j,k,m) =&
3793 & sqrt(output_fields(out_num)%buffer(i,j,k,m))
3799 output_fields(out_num)%buffer(:,:,:,m) = output_fields(out_num)%buffer(:,:,:,m)/num
3800 IF ( time_rms ) output_fields(out_num)%buffer(:,:,:,m) =&
3801 & sqrt(output_fields(out_num)%buffer(:,:,:,m))
3803 ELSE IF ( .NOT. at_diag_end )
THEN
3804 IF ( missvalue_present )
THEN
3805 IF(any(output_fields(out_num)%buffer /= missvalue))
THEN
3806 WRITE (error_string,
'(a,"/",a)')&
3807 & trim(input_fields(in_num)%module_name), &
3808 & trim(output_fields(out_num)%output_name)
3816 ELSE IF ( time_min .OR. time_max )
THEN
3817 IF ( missvalue_present )
THEN
3818 WHERE ( abs(output_fields(out_num)%buffer) == min_value )
3819 output_fields(out_num)%buffer = missvalue
3825 IF ( at_diag_end .AND. freq == end_of_run ) output_fields(out_num)%next_output = time
3827 IF ( (output_fields(out_num)%time_ops) .AND. (.NOT. mix_snapshot_average_fields) )
THEN
3828 middle_time = (output_fields(out_num)%last_output+output_fields(out_num)%next_output)/2
3829 if (trim(files(file_num)%filename_time_bounds) ==
"begin")
then
3830 filename_time = output_fields(out_num)%last_output
3831 elseif (trim(files(file_num)%filename_time_bounds) ==
"middle")
then
3832 filename_time = middle_time
3833 elseif (trim(files(file_num)%filename_time_bounds) ==
"end")
then
3834 filename_time = output_fields(out_num)%next_output
3837 CALL diag_data_out(file_num, out_num, output_fields(out_num)%buffer, middle_time, &
3838 & filename_time=filename_time)
3841 & output_fields(out_num)%buffer, output_fields(out_num)%next_output)
3845 IF ( at_diag_end )
RETURN
3848 output_fields(out_num)%last_output = output_fields(out_num)%next_output
3849 IF ( freq == end_of_run )
THEN
3850 output_fields(out_num)%next_output = time
3852 IF ( freq == every_time )
THEN
3853 output_fields(out_num)%next_output = time
3855 output_fields(out_num)%next_output = output_fields(out_num)%next_next_output
3856 output_fields(out_num)%next_next_output = &
3857 & diag_time_inc(output_fields(out_num)%next_next_output, freq, units)
3859 output_fields(out_num)%count_0d(:) = 0.0
3860 output_fields(out_num)%num_elements(:) = 0
3861 IF ( time_max )
THEN
3862 output_fields(out_num)%buffer = max_value
3863 ELSE IF ( time_min )
THEN
3864 output_fields(out_num)%buffer = min_value
3866 output_fields(out_num)%buffer = empty
3868 IF ( input_fields(in_num)%mask_variant .AND. average ) output_fields(out_num)%counter = 0.0
3872 SUBROUTINE diag_manager_set_time_end(Time_end_in)
3873 TYPE (
time_type),
INTENT(in) :: time_end_in
3875 time_end = time_end_in
3876 if (use_modern_diag)
then
3877 call fms_diag_object%set_time_end(time_end_in)
3880 END SUBROUTINE diag_manager_set_time_end
3895 integer :: file, j, freq, in_num, file_num, out_num
3897 DO file = 1, num_files
3898 freq = files(file)%output_freq
3900 DO j = 1, files(file)%num_fields
3901 out_num = files(file)%fields(j)
3902 in_num = output_fields(out_num)%input_field
3903 IF ( (input_fields(in_num)%numthreads == 1) .AND.&
3904 & (input_fields(in_num)%active_omp_level.LE.1) ) cycle
3905 file_num = output_fields(out_num)%output_file
3907 & output_fields(out_num)%buffer, time)
3916 TYPE (
time_type),
INTENT(in) :: time_step
3917 character(len=*),
INTENT(out),
optional :: err_msg
3920 integer :: file, j, out_num, in_num, freq, status
3921 logical :: local_output, need_compute
3922 CHARACTER(len=128) :: error_string
3924 IF ( time_end == time_zero )
THEN
3928 CALL error_mesg(
'diag_manager_mod::diag_send_complete',&
3929 &
"diag_manager_set_time_end must be called before diag_send_complete", fatal)
3932 if (use_modern_diag)
then
3933 call fms_diag_object%fms_diag_send_complete(time_step)
3937 DO file = 1, num_files
3938 freq = files(file)%output_freq
3939 DO j = 1, files(file)%num_fields
3940 out_num = files(file)%fields(j)
3941 in_num = output_fields(out_num)%input_field
3943 IF ( (input_fields(in_num)%numthreads == 1) .AND. (input_fields(in_num)%active_omp_level.LE.1) ) cycle
3944 IF ( output_fields(out_num)%static .OR. freq == end_of_run ) cycle
3945 time = input_fields(in_num)%time
3946 IF ( time >= time_end ) cycle
3949 local_output = output_fields(out_num)%local_output
3951 need_compute = output_fields(out_num)%need_compute
3953 IF ( local_output .AND. (.NOT.need_compute) ) cycle
3954 next_time = time + time_step
3956 IF ( next_time > output_fields(out_num)%next_output )
THEN
3958 IF ( next_time > output_fields(out_num)%next_next_output .AND. freq > 0 )
THEN
3959 IF (
mpp_pe() .EQ. mpp_root_pe() )
THEN
3960 WRITE (error_string,
'(a,"/",a)')&
3961 & trim(input_fields(in_num)%module_name), &
3962 & trim(output_fields(out_num)%output_name)
3964 &
'module/output_field '//trim(error_string)//&
3965 &
' is skipped one time level in output data', err_msg))
RETURN
3969 status =
writing_field(out_num, .false., error_string, next_time)
3970 IF ( status == -1 )
THEN
3971 IF (
mpp_pe() .EQ. mpp_root_pe() )
THEN
3972 IF(
fms_error_handler(
'diag_manager_mod::diag_send_complete',
'module/output_field '//&
3973 & trim(error_string)//
', write EMPTY buffer', err_msg))
RETURN
3989 IF ( do_diag_field_log )
THEN
3990 close (diag_log_unit)
3992 DO file = 1, num_files
3995 if (
allocated(fileobju))
deallocate(fileobju)
3996 if (
allocated(fileobj))
deallocate(fileobj)
3997 if (
allocated(fileobjnd))
deallocate(fileobjnd)
4000 if (use_modern_diag)
then
4001 call fms_diag_object%diag_end(time)
4007 INTEGER,
INTENT(in) :: file
4010 INTEGER :: j, i, input_num, freq, status
4011 INTEGER :: stdout_unit
4012 LOGICAL :: reduced_k_range, need_compute, local_output
4013 CHARACTER(len=128) :: message
4018 DO j = 1, files(file)%num_fields
4019 i = files(file)%fields(j)
4022 local_output = output_fields(i)%local_output
4024 need_compute = output_fields(i)%need_compute
4026 reduced_k_range = output_fields(i)%reduced_k_range
4029 IF ( local_output .AND. (.NOT. need_compute) ) cycle
4031 input_num = output_fields(i)%input_field
4032 IF ( input_fields(input_num)%static ) cycle
4033 IF ( .NOT.input_fields(input_num)%register ) cycle
4034 freq = files(file)%output_freq
4035 IF ( freq /= end_of_run .AND. files(file)%file_unit < 0 &
4036 & .AND. all(output_fields(i)%num_elements(:) == 0)&
4037 & .AND. all(output_fields(i)%count_0d(:) == 0) ) cycle
4040 IF ( time >= output_fields(i)%next_output .OR. freq == end_of_run )
THEN
4041 IF ( time >= output_fields(i)%next_next_output .AND. freq > 0 )
THEN
4042 WRITE (message,
'(a,"/",a)') trim(input_fields(input_num)%module_name), &
4043 & trim(output_fields(i)%output_name)
4048 IF (
mpp_pe() .EQ. mpp_root_pe() ) &
4049 &
CALL error_mesg(
'diag_manager_mod::closing_file',
'module/output_field ' //&
4050 & trim(message)//
', skip one time level, maybe send_data never called', warning)
4055 ELSEIF ( .NOT.output_fields(i)%written_once )
THEN
4060 CALL error_mesg(
'Potential error in diag_manager_end ',&
4061 & trim(output_fields(i)%output_name)//
' NOT available,'//&
4062 &
' check if output interval > runlength. Netcdf fill_values are written', note)
4063 output_fields(i)%buffer = fill_value
4064 CALL diag_data_out(file, i, output_fields(i)%buffer, time, .true.)
4071 IF ( write_bytes_in_file )
THEN
4072 CALL mpp_sum (files(file)%bytes_written)
4073 IF (
mpp_pe() == mpp_root_pe() )&
4074 &
WRITE (stdout_unit,
'(a,i12,a,a)')
'Diag_Manager: ',files(file)%bytes_written, &
4075 &
' bytes of data written to file ',trim(files(file)%name)
4082 INTEGER,
OPTIONAL,
INTENT(IN) :: diag_model_subset
4083 INTEGER,
DIMENSION(6),
OPTIONAL,
INTENT(IN) :: time_init
4084 CHARACTER(len=*),
INTENT(out),
OPTIONAL :: err_msg
4086 CHARACTER(len=*),
PARAMETER :: sep =
'|'
4088 INTEGER,
PARAMETER :: fltkind = r4_kind
4089 INTEGER,
PARAMETER :: dblkind = r8_kind
4090 INTEGER :: diag_subset_output
4092 INTEGER,
ALLOCATABLE,
DIMENSION(:) :: pelist
4093 INTEGER :: stdlog_unit, stdout_unit
4095 CHARACTER(len=256) :: err_msg_local
4097 namelist /diag_manager_nml/ append_pelist_name, mix_snapshot_average_fields, max_output_fields, &
4098 & max_input_fields, max_axes, do_diag_field_log, write_bytes_in_file, debug_diag_manager,&
4099 & max_num_axis_sets, max_files, use_cmor, issue_oor_warnings,&
4100 & oor_warnings_fatal, max_out_per_in_field, flush_nc_files, region_out_use_alt_value, max_field_attributes,&
4101 & max_file_attributes, max_axis_attributes, prepend_date, use_modern_diag, use_clock_average, &
4105 IF ( module_is_initialized )
RETURN
4108 IF (
PRESENT(err_msg) ) err_msg =
''
4113 call diag_data_init()
4116 pack_size =
SIZE(transfer(0.0_dblkind, (/0.0, 0.0, 0.0, 0.0/)))
4117 IF (pack_size .EQ. 1)
then
4118 pack_size_str =
"double"
4119 else if (pack_size .EQ. 2)
then
4120 pack_size_str =
"float"
4122 IF (
fms_error_handler(
'diag_manager_mod::diag_manager_init',
'unknown pack_size. Must be 1, or 2.', &
4127 min_value = huge(0.0_fltkind)
4128 max_value = -min_value
4139 time_end = time_zero
4140 diag_subset_output = diag_all
4141 IF (
PRESENT(diag_model_subset) )
THEN
4142 IF ( diag_model_subset >= diag_other .AND. diag_model_subset <= diag_all )
THEN
4143 diag_subset_output = diag_model_subset
4145 IF (
fms_error_handler(
'diag_manager_mod::diag_manager_init',
'invalid value of diag_model_subset', &
4150 READ (input_nml_file, nml=diag_manager_nml, iostat=mystat)
4153 IF (
check_nml_error(iostat=mystat, nml_name=
'DIAG_MANAGER_NML') < 0 )
THEN
4154 IF (
mpp_pe() == mpp_root_pe() )
THEN
4155 CALL error_mesg(
'diag_manager_mod::diag_manager_init', &
4156 &
'DIAG_MANAGER_NML not found in input nml file. Using defaults.', warning)
4160 IF (.not. use_modern_diag .and. use_clock_average) &
4161 call mpp_error(fatal,
"diag_manager_mod: You cannot set use_modern_diag=.false. and &
4162 & use_clock_average=.true. in diag_manager_nml")
4164 IF (
mpp_pe() == mpp_root_pe() )
THEN
4165 WRITE (stdlog_unit, diag_manager_nml)
4169 IF ( use_cmor )
THEN
4171 WRITE (err_msg_local,
'(ES8.1E2)') cmor_missing_value
4172 CALL error_mesg(
'diag_manager_mod::diag_manager_init',
'Using CMOR missing value ('//trim(err_msg_local)// &
4177 IF ( oor_warnings_fatal )
THEN
4179 CALL error_mesg(
'diag_manager_mod::diag_manager_init',
'Out &
4180 &of Range warnings are fatal.', note)
4181 ELSEIF ( .NOT.issue_oor_warnings )
THEN
4182 CALL error_mesg(
'diag_manager_mod::diag_manager_init',
'Out &
4183 &of Range warnings will be ignored.', note)
4186 IF ( mix_snapshot_average_fields )
THEN
4187 IF ( .not. use_modern_diag )
THEN
4188 CALL error_mesg(
'diag_manager_mod::diag_manager_init',
'Setting diag_manager_nml variable '//&
4189 &
'mix_snapshot_average_fields = .TRUE. will cause ERRORS in the time coordinates '//&
4190 &
'of all time averaged fields. Strongly recommend setting mix_snapshot_average_fields '//&
4191 &
'= .FALSE.', note)
4193 CALL error_mesg(
'diag_manager_mod::diag_manager_init',
'mix_snapshot_average_fields = .TRUE. is not '//&
4194 &
'supported if use_modern_diag = .TRUE. Please set mix_snapshot_average_fields '//&
4195 &
'to .FALSE. and put instantaneous and averaged fields in separate files!', fatal)
4198 ALLOCATE(output_fields(max_output_fields))
4199 ALLOCATE(input_fields(max_input_fields))
4200 DO j = 1, max_input_fields
4201 ALLOCATE(input_fields(j)%output_fields(max_out_per_in_field))
4204 ALLOCATE(files(max_files))
4205 ALLOCATE(fileobju(max_files))
4206 ALLOCATE(fileobj(max_files))
4207 ALLOCATE(fileobjnd(max_files))
4212 CALL mpp_get_current_pelist(pelist, pelist_name)
4215 IF (
PRESENT(time_init) )
THEN
4216 diag_init_time =
set_date(time_init(1), time_init(2), time_init(3), time_init(4),&
4217 & time_init(5), time_init(6))
4219 diag_init_time = get_base_time()
4220 IF ( prepend_date .EQV. .true. )
THEN
4221 CALL error_mesg(
'diag_manager_mod::diag_manager_init',&
4222 &
'prepend_date only supported when diag_manager_init is called with time_init present.', note)
4223 prepend_date = .false.
4227 if (use_modern_diag)
then
4228 CALL error_mesg(
'diag_manager_mod::diag_manager_init',&
4229 &
'You are using the yaml version of the diag table', note)
4230 CALL fms_diag_object%init(diag_subset_output, time_init)
4232 if (.not. use_modern_diag)
then
4233 CALL error_mesg(
'diag_manager_mod::diag_manager_init',&
4234 &
'You are using the legacy version of the diag table', note)
4235 CALL parse_diag_table(diag_subset=diag_subset_output, istat=mystat, err_msg=err_msg_local)
4236 IF ( mystat /= 0 )
THEN
4238 &
'Error parsing diag_table. '//trim(err_msg_local), err_msg) )
RETURN
4242 files(:)%bytes_written = 0
4245 IF ( do_diag_field_log.AND.
mpp_pe().EQ.mpp_root_pe() )
THEN
4246 open(newunit=diag_log_unit, file=
'diag_field_log.out.'//
string(
mpp_pe()), action=
'WRITE')
4247 WRITE (diag_log_unit,
'(777a)') &
4255 module_is_initialized = .true.
4257 if(.not. use_modern_diag) null_axis_id = diag_axis_init(
'scalar_axis', (/0./),
'none',
'N',
'none')
4264 INTEGER,
INTENT(out) :: year, month, day, hour, minute, second
4267 IF (.NOT.module_is_initialized)
CALL error_mesg (
'diag_manager_mod::get_base_date', &
4268 &
'module has not been initialized', fatal)
4269 year = get_base_year()
4270 month = get_base_month()
4271 day = get_base_day()
4272 hour = get_base_hour()
4273 minute = get_base_minute()
4274 second = get_base_second()
4284 TYPE(
time_type),
INTENT(in) :: next_model_time
4285 INTEGER,
INTENT(in) :: diag_field_id
4287 INTEGER :: i, out_num
4290 IF ( diag_field_id < 0 )
RETURN
4291 DO i = 1, input_fields(diag_field_id)%num_output_fields
4293 out_num = input_fields(diag_field_id)%output_fields(i)
4294 IF ( .NOT.output_fields(out_num)%static )
THEN
4295 IF ( next_model_time > output_fields(out_num)%next_output )
need_data=.true.
4299 IF ( output_fields(out_num)%time_average)
need_data = .true.
4311 INTEGER,
INTENT(in) :: n_samples
4313 REAL :: center_data (n_samples)
4314 REAL :: edges (n_samples+1)
4323 CHARACTER(32) :: name
4324 CHARACTER(128) :: units
4327 WRITE (units,11)
'hours', year, month, day, hour, minute, second
4328 11
FORMAT(a,
' since ',i4.4,
'-',i2.2,
'-',i2.2,
' ',i2.2,
':',i2.2,
':',i2.2)
4332 center_data(i) = 24.0*(real(i)-0.5)/n_samples
4333 edges(i+1) = 24.0* real(i)/n_samples
4338 WRITE (name,
'(a,i2.2)')
'time_of_day_edges_', n_samples
4339 edges_id = get_axis_num(name,
'diurnal')
4340 IF ( edges_id <= 0 )
THEN
4341 edges_id = diag_axis_init(name,edges,units,
'N',
'time of day edges', set_name=
'diurnal')
4346 WRITE (name,
'(a,i2.2)')
'time_of_day_', n_samples
4349 init_diurnal_axis = diag_axis_init(name, center_data, units,
'N',
'time of day', &
4350 set_name=
'diurnal', edges=edges_id)
4355 INTEGER,
INTENT(in) :: diag_field_id
4356 CHARACTER(len=*),
INTENT(in) :: name
4357 INTEGER,
INTENT(in) ::
type
4358 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: cval
4359 INTEGER,
DIMENSION(:),
INTENT(in),
OPTIONAL :: ival
4360 REAL,
DIMENSION(:),
INTENT(in),
OPTIONAL :: rval
4362 INTEGER :: istat, length, i, j, this_attribute, out_field
4364 IF ( .NOT.first_send_data_call )
THEN
4370 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',
'Attempting to add attribute "'&
4371 &//trim(name)//
'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//
'/'&
4372 &//trim(input_fields(diag_field_id)%field_name)//
'" after first send_data call. Too late.', fatal)
4376 IF ( diag_field_id .LE. 0 )
THEN
4379 DO j=1,input_fields(diag_field_id)%num_output_fields
4380 out_field = input_fields(diag_field_id)%output_fields(j)
4387 DO i=1, output_fields(out_field)%num_attributes
4388 IF ( trim(output_fields(out_field)%attributes(i)%name) .EQ. trim(name) )
THEN
4394 IF ( this_attribute.NE.0 .AND. (type.EQ.nf90_int .OR. type.EQ.nf90_float) )
THEN
4399 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',&
4400 &
'Attribute "'//trim(name)//
'" already defined for module/input_field "'&
4401 &//trim(input_fields(diag_field_id)%module_name)//
'/'&
4402 &//trim(input_fields(diag_field_id)%field_name)//
'". Contact the developers.', fatal)
4403 ELSE IF ( this_attribute.NE.0 .AND. type.EQ.nf90_char .AND. debug_diag_manager )
THEN
4408 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',&
4409 &
'Attribute "'//trim(name)//
'" already defined for module/input_field "'&
4410 &//trim(input_fields(diag_field_id)%module_name)//
'/'&
4411 &//trim(input_fields(diag_field_id)%field_name)//
'". Prepending.', note)
4412 ELSE IF ( this_attribute.EQ.0 )
THEN
4415 this_attribute = output_fields(out_field)%num_attributes + 1
4417 IF ( this_attribute .GT. max_field_attributes )
THEN
4423 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',&
4424 &
'Number of attributes exceeds max_field_attributes for attribute "'&
4425 &//trim(name)//
'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//
'/'&
4426 &//trim(input_fields(diag_field_id)%field_name)&
4427 &//
'". Increase diag_manager_nml:max_field_attributes.', fatal)
4429 output_fields(out_field)%num_attributes = this_attribute
4431 output_fields(out_field)%attributes(this_attribute)%name = name
4432 output_fields(out_field)%attributes(this_attribute)%type =
type
4434 output_fields(out_field)%attributes(this_attribute)%catt =
''
4440 IF ( .NOT.
PRESENT(ival) )
THEN
4446 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',&
4447 &
'Attribute type claims INTEGER, but ival not present for attribute "'&
4448 &//trim(name)//
'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//
'/'&
4449 &//trim(input_fields(diag_field_id)%field_name)//
'". Contact then developers.', fatal)
4453 ALLOCATE(output_fields(out_field)%attributes(this_attribute)%iatt(length), stat=istat)
4454 IF ( istat.NE.0 )
THEN
4458 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',
'Unable to allocate iatt for attribute "'&
4459 &//trim(name)//
'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//
'/'&
4460 &//trim(input_fields(diag_field_id)%field_name)//
'"', fatal)
4463 output_fields(out_field)%attributes(this_attribute)%len = length
4464 output_fields(out_field)%attributes(this_attribute)%iatt = ival
4466 IF ( .NOT.
PRESENT(rval) )
THEN
4472 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',&
4473 &
'Attribute type claims REAL, but rval not present for attribute "'&
4474 &//trim(name)//
'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//
'/'&
4475 &//trim(input_fields(diag_field_id)%field_name)//
'". Contact the developers.', fatal)
4479 ALLOCATE(output_fields(out_field)%attributes(this_attribute)%fatt(length), stat=istat)
4480 IF ( istat.NE.0 )
THEN
4484 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',
'Unable to allocate fatt for attribute "'&
4485 &//trim(name)//
'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//
'/'&
4486 &//trim(input_fields(diag_field_id)%field_name)//
'"', fatal)
4489 output_fields(out_field)%attributes(this_attribute)%len = length
4490 output_fields(out_field)%attributes(this_attribute)%fatt = rval
4492 IF ( .NOT.
PRESENT(cval) )
THEN
4498 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',&
4499 &
'Attribute type claims CHARACTER, but cval not present for attribute "'&
4500 &//trim(name)//
'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//
'/'&
4501 &//trim(input_fields(diag_field_id)%field_name)//
'". Contact the developers.', fatal)
4509 CALL error_mesg(
'diag_manager_mod::diag_field_add_attribute',
'Unknown attribute type for attribute "'&
4510 &//trim(name)//
'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//
'/'&
4511 &//trim(input_fields(diag_field_id)%field_name)//
'". Contact the developers.', fatal)
4519 INTEGER,
INTENT(in) :: diag_field_id
4520 CHARACTER(len=*),
INTENT(in) :: att_name
4521 class(*),
INTENT(in) :: att_value
4523 if (use_modern_diag)
then
4524 select type(att_value)
4525 type is (real(kind=r4_kind))
4526 call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, (/att_value /))
4527 type is (real(kind=r8_kind))
4528 call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, (/att_value /))
4529 type is (
integer(kind=i4_kind))
4530 call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, (/att_value /))
4531 type is (
character(len=*))
4532 call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, (/att_value /))
4534 call mpp_error(fatal,
"Diag_field_add_attribute 0d:: unsupported type. The acceptable types "//&
4535 "are float, double, integer, and string")
4538 select type(att_value)
4539 type is (real(kind=r4_kind))
4541 type is (real(kind=r8_kind))
4543 type is (
integer(kind=i4_kind))
4545 type is (
character(len=*))
4548 call mpp_error(fatal,
"Diag_field_add_attribute 0d:: unsupported type. The acceptable types "//&
4549 "are float, double, integer, and string")
4557 INTEGER,
INTENT(in) :: diag_field_id
4558 CHARACTER(len=*),
INTENT(in) :: att_name
4559 class(*),
INTENT(in) :: att_value(:)
4561 if (use_modern_diag)
then
4562 call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, att_value)
4564 select type(att_value)
4565 type is (real(kind=r4_kind))
4567 type is (real(kind=r8_kind))
4569 type is (
integer(kind=i4_kind))
4572 call mpp_error(fatal,
"Diag_field_add_attribute 1d:: unsupported type. The acceptable types "//&
4573 "are float, double, and integer")
4584 INTEGER,
INTENT(in) :: diag_field_id
4585 INTEGER,
INTENT(in),
OPTIONAL :: area
4586 INTEGER,
INTENT(in),
OPTIONAL :: volume
4590 IF ( diag_field_id.GT.0 )
THEN
4591 IF ( .NOT.
PRESENT(area) .AND. .NOT.
present(volume) )
THEN
4592 CALL error_mesg(
'diag_manager_mod::diag_field_add_cell_measures', &
4593 &
'either area or volume arguments must be present', fatal )
4596 if (use_modern_diag)
then
4597 call fms_diag_object%fms_diag_field_add_cell_measures(diag_field_id, area, volume)
4601 DO j=1, input_fields(diag_field_id)%num_output_fields
4602 ind = input_fields(diag_field_id)%output_fields(j)
4610 class(*),
intent(in) :: data_in(:,:,:)
4611 character(len=*),
intent(in) :: field_name
4612 class(*),
allocatable,
intent(out) :: data_out(:,:,:,:)
4615 select type(data_in)
4616 type is (real(kind=r8_kind))
4617 allocate(real(kind=r8_kind) :: data_out(1:
size(data_in,1), 1:
size(data_in,2), 1:
size(data_in,3), 1))
4618 select type (data_out)
4619 type is (real(kind=r8_kind))
4620 data_out(:,:,:,1) = data_in
4622 call mpp_error(fatal,
"The copy of "//trim(field_name)//&
4623 " was not allocated to the correct type (r8_kind). This shouldn't have happened")
4625 type is (real(kind=r4_kind))
4626 allocate(real(kind=r4_kind) :: data_out(1:
size(data_in,1), 1:
size(data_in,2), 1:
size(data_in,3), 1))
4627 select type (data_out)
4628 type is (real(kind=r4_kind))
4629 data_out(:,:,:,1) = data_in
4631 call mpp_error(fatal,
"The copy of "//trim(field_name)//&
4632 " was not allocated to the correct type (r4_kind). This shouldn't have happened")
4635 call mpp_error(fatal,
"The data for "//trim(field_name)//&
4636 &
" is not a valid type. Currently only r4 and r8 are supported")
4640 END MODULE diag_manager_mod
integer(i4_kind) function, public axis_compatible_check(id, varname)
Checks if the axes are compatible.
integer function, public get_axis_length(id)
Return the length of the axis.
integer function, public get_axis_num(axis_name, set_name)
Returns index into axis table corresponding to a given axis name.
type(domain2d) function, public get_domain2d(ids)
Return the 2D domain for the axis IDs given.
integer function, public get_tile_count(ids)
Return the tile count for the axis.
subroutine, public get_diag_axis_name(id, axis_name)
Return the short name of the axis.
integer(i4_kind), parameter, public diag_axis_2ddomain
For unstructured grid support.
integer function, public diag_axis_init(name, array_data, units, cart_name, long_name, direction, set_name, edges, Domain, Domain2, DomainU, aux, req, tile_count, domain_position)
Initialize the axis, and return the axis ID.
integer(i4_kind), parameter, public diag_axis_ugdomain
For unstructured grid support.
Add an arbitrary attribute and value to the diagnostic axis.
integer max_output_fields
Maximum number of output fields. Increase via diag_manager_nml.
real fill_value
Fill value used. Value will be NF90_FILL_REAL if using the netCDF module, otherwise will be 9....
integer pack_size
1 for double and 2 for float
integer function get_base_minute()
gets the module variable base_minute
integer function get_base_year()
gets the module variable base_year
integer function get_base_hour()
gets the module variable base_hour
logical use_cmor
Indicates if we should overwrite the MISSING_VALUE to use the CMOR missing value.
logical flush_nc_files
Control if diag_manager will force a flush of the netCDF file on each write. Note: changing this to ....
integer max_axis_attributes
Maximum number of user definable attributes per axis.
character(len=6) pack_size_str
Pack size as a string to be used in fms2_io register call set to "double" or "float".
logical use_modern_diag
Namelist flag to use the modernized diag_manager code.
type(time_type) function get_base_time()
gets the module variable base_time
integer max_axes
Maximum number of independent axes.
logical use_mpp_io
false is fms2_io (default); true is mpp_io
integer, parameter diag_field_not_found
Return value for a diag_field that isn't found in the diag_table.
integer max_out_per_in_field
Maximum number of output_fields per input_field. Increase via diag_manager_nml.
integer max_input_fields
Maximum number of input fields. Increase via diag_manager_nml.
logical use_clock_average
.TRUE. if the averaging of variable is done based on the clock For example, if doing daily averages a...
logical issue_oor_warnings
Issue warnings if the output field has values outside the given range for a variable.
logical region_out_use_alt_value
Will determine which value to use when checking a regional output if the region is the full axis or a...
integer num_output_fields
Number of output fields in use.
integer function get_base_day()
gets the module variable base_day
type(time_type) diag_init_time
Time diag_manager_init called. If init_time not included in diag_manager_init call,...
integer max_files
Maximum number of output files allowed. Increase via diag_manager_nml.
integer num_files
Number of output files currenly in use by the diag_manager.
integer max_file_attributes
Maximum number of user definable global attributes per file.
real(r8_kind), parameter cmor_missing_value
CMOR standard missing value.
logical prepend_date
Should the history file have the start date prepended to the file name. .TRUE. is only supported if t...
character(len=2), dimension(:), allocatable fnum_for_domain
If this file number in the array is for the "unstructured" or "2d" domain.
subroutine diag_data_init()
Initialize and write the version number of this file to the log file.
integer function get_base_month()
gets the module variable base_month
logical module_is_initialized
Indicate if diag_manager has been initialized.
logical oor_warnings_fatal
Cause a fatal error if the output field has a value outside the given range for a variable.
integer function get_base_second()
gets the module variable base_second
logical use_refactored_send
Namelist flag to use refactored send_data math funcitons.
integer max_field_attributes
Maximum number of user definable attributes per field. Liptak: Changed from 2 to 4 20170718.
Define the region for field output.
Type to hold the output field description.
subroutine, public diag_grid_init(domain, glo_lat, glo_lon, aglo_lat, aglo_lon)
Send the global grid to the diag_manager_mod for regional output.
subroutine, public diag_grid_end()
Unallocate the diag_global_grid variable.
logical function, public need_data(diag_field_id, next_model_time)
Determine whether data is needed for the current model time step.
logical function get_related_field(field, rel_field, out_field_id, out_file_id)
Finds the corresponding related output field and file for a given input field.
logical function send_data_2d(diag_field_id, field, time, is_in, js_in, mask, rmask, ie_in, je_in, weight, err_msg)
integer function register_diag_field_scalar(module_name, field_name, init_time, long_name, units, missing_value, range, standard_name, do_not_log, err_msg, area, volume, realm, multiple_send_data)
Registers a scalar field.
integer function, public register_static_field(module_name, field_name, axes, long_name, units, missing_value, range, mask_variant, standard_name, DYNAMIC, do_not_log, interp_method, tile_count, area, volume, realm)
Return field index for subsequent call to send_data.
subroutine copy_3d_to_4d(data_in, data_out, field_name)
Copies a 3d buffer to a 4d buffer.
logical function send_data_4d(diag_field_id, field, time, is_in, js_in, ks_in, mask, rmask, ie_in, je_in, ke_in, weight, err_msg)
Updates the output buffer for a field based on the data for current time step.
subroutine diag_field_attribute_init(diag_field_id, name, type, cval, ival, rval)
logical function send_tile_averaged_data3d(id, field, area, time, mask)
integer function register_diag_field_array(module_name, field_name, axes, init_time, long_name, units, missing_value, range, mask_variant, standard_name, verbose, do_not_log, err_msg, interp_method, tile_count, area, volume, realm, multiple_send_data)
Registers an array field.
integer function register_diag_field_scalar_old(module_name, field_name, init_time, long_name, units, missing_value, range, standard_name, do_not_log, err_msg, area, volume, realm)
Registers a scalar field.
integer function register_static_field_old(module_name, field_name, axes, long_name, units, missing_value, range, mask_variant, standard_name, DYNAMIC, do_not_log, interp_method, tile_count, area, volume, realm)
Return field index for subsequent call to send_data.
subroutine closing_file(file, time)
Replaces diag_manager_end; close just one file: files(file)
subroutine, public diag_field_add_cell_measures(diag_field_id, area, volume)
Add the cell_measures attribute to a diag out field.
subroutine init_field_cell_measures(output_field, area, volume, err_msg)
If needed, add cell_measures and associated_file attribute to out field/file.
integer function register_diag_field_array_old(module_name, field_name, axes, init_time, long_name, units, missing_value, range, mask_variant, standard_name, verbose, do_not_log, err_msg, interp_method, tile_count, area, volume, realm)
Registers an array field.
subroutine, public diag_send_complete_instant(time)
The subroutine 'diag_send_complete_instant' allows the user to save diagnostic data on variable inter...
subroutine average_tiles(diag_field_id, x, area, mask, out)
Calculates tile average of a field.
logical function send_data_0d(diag_field_id, field, time, err_msg)
subroutine add_associated_files(file_num, cm_file_num, cm_ind)
Add to the associated files attribute.
integer function writing_field(out_num, at_diag_end, error_string, time)
subroutine, public diag_manager_init(diag_model_subset, time_init, err_msg)
Initialize Diagnostics Manager.
integer function, public get_diag_field_id(module_name, field_name)
Return the diagnostic field ID of a given variable.
subroutine, public get_base_date(year, month, day, hour, minute, second)
Return base date for diagnostics.
logical function send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, mask, rmask, ie_in, je_in, ke_in, weight, err_msg)
subroutine average_tiles1d(diag_field_id, x, area, mask, out)
Calculates average for a field with the given area and land mask.
logical function diag_send_data(diag_field_id, field, time, is_in, js_in, ks_in, mask, rmask, ie_in, je_in, ke_in, weight, err_msg)
subroutine diag_field_add_attribute_0d(diag_field_id, att_name, att_value)
Add a scalr attribute to the diag field corresponding to a given id.
logical function send_tile_averaged_data1d(id, field, area, time, mask)
logical function send_data_1d(diag_field_id, field, time, is_in, mask, rmask, ie_in, weight, err_msg)
subroutine, public diag_manager_end(time)
Flushes diagnostic buffers where necessary. Close diagnostics files. A warning will be issued here if...
logical function send_tile_averaged_data2d(id, field, area, time, mask)
integer function init_diurnal_axis(n_samples)
Finds or initializes a diurnal time axis and returns its' ID.
subroutine diag_field_add_attribute_1d(diag_field_id, att_name, att_value)
Add an 1D array attribute to the diag field corresponding to a given id.
subroutine, public diag_send_complete(time_step, err_msg)
Saves diagnostic data for the given time value.
Add a attribute to the output field.
Register a diagnostic field for a given module.
Send data over to output fields.
Send tile-averaged data over to output fields.
subroutine, public get_diag_global_att(gAtt)
Return the global attribute type.
subroutine, public set_diag_global_att(component, gridType, tileName)
Set the global attribute type.
subroutine, public parse_diag_table(diag_subset, istat, err_msg)
Parse the diag_table in preparation for diagnostic output.
subroutine, public get_subfield_size(axes, outnum)
Get the size, start, and end indices for output fields.
subroutine, public init_input_field(module_name, field_name, tile_count)
Initialize the input field.
subroutine, public check_bounds_are_exact_static(out_num, diag_field_id, err_msg)
Check if the array indices for output_fields(out_num) are equal to the output_fields(out_num)buffer u...
integer function, public find_input_field(module_name, field_name, tile_count)
Return the field number for the given module name, field name, and tile number.
subroutine, public write_static(file)
Output all static fields in this file.
subroutine, public diag_data_out(file, field, dat, time, final_call_in, static_write_in, filename_time)
Write data out to file, and if necessary flush the buffers.
subroutine, public init_output_field(module_name, field_name, output_name, output_file, time_method, pack, tile_count, local_coord)
Initialize the output field.
type(time_type) function, public get_file_start_time(file_num)
Get the a diag_file's start_time as it is defined in the diag_table.
subroutine, public sync_file_times(file_id, init_time, err_msg)
Synchronize the file's start and close times with the model start and end times.
character(len=1), public field_log_separator
separator used for csv-style log of registered fields set by nml in diag_manager init
subroutine, public check_out_of_bounds(out_num, diag_field_id, err_msg)
Checks if the array indices for output_fields(out_num) are outside the output_fields(out_num)buffer u...
subroutine, public get_subfield_vert_size(axes, outnum)
Get size, start and end indices for output fields.
subroutine, public log_diag_field_info(module_name, field_name, axes, long_name, units, missing_value, range, dynamic)
Writes brief diagnostic field info to the log file.
subroutine, public update_bounds(out_num, lower_i, upper_i, lower_j, upper_j, lower_k, upper_k)
Update the output_fields x, y, and z min and max boundaries (array indices) with the six specified bo...
subroutine, public diag_util_init()
Write the version number of this file to the log file.
subroutine, public check_bounds_are_exact_dynamic(out_num, diag_field_id, Time, err_msg)
This is an adaptor to the check_bounds_are_exact_dynamic_modern function to maintain an interface ser...
Allocates the atttype in out_file.
Prepend a value to a string attribute in the output field or output file.
Interface fieldbuff_copy_fieldvals updates elements of the field output buffer with copies of corresp...
Interface fieldbuff_copy_missvals updates elements of the field output buffer with the missvalue inpu...
Interface fieldbuff_update updates elements of field output buffer based on input field data and math...
Class fmsDiagOutfield_type (along with class ms_diag_outfield_index_type ) contain information used i...
Class fms_diag_outfield_index_type which (along with class fmsDiagOutfield_type) encapsulate related ...
integer function, public check_nml_error(IOSTAT, NML_NAME)
Checks the iostat argument that is returned after reading a namelist and determines if the error code...
subroutine, public write_version_number(version, tag, unit)
Prints to the log file (or a specified unit) the version id string and tag name.
logical function, public fms_error_handler(routine, message, err_msg)
Facilitates the control of fatal error conditions.
subroutine, public error_mesg(routine, message, level)
Print notes, warnings and error messages; terminates program for warning and error messages....
character(:) function, allocatable, public string(v, fmt)
Converts a number or a Boolean value to a string.
integer function stdout()
This function returns the current standard fortran unit numbers for output.
integer function stdlog()
This function returns the current standard fortran unit numbers for log messages. Log messages,...
integer function mpp_npes()
Returns processor count for current pelist.
integer function mpp_pe()
Returns processor ID.
integer function, public get_ticks_per_second()
Returns the number of ticks per second.
subroutine, public get_time(Time, seconds, days, ticks, err_msg)
Returns days and seconds ( < 86400 ) corresponding to a time. err_msg should be checked for any error...
subroutine, public get_date(time, year, month, day, hour, minute, second, tick, err_msg)
Gets the date for different calendar types. Given a time_interval, returns the corresponding date und...
Given an input date in year, month, days, etc., creates a time_type that represents this time interva...
Given some number of seconds and days, returns the corresponding time_type.
Type to represent amounts of time. Implemented as seconds and days to allow for larger intervals.